diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor index 39c17a4708..ce4bddde6a 100644 --- a/basis/html/components/components-docs.factor +++ b/basis/html/components/components-docs.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Your name. +! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax io.streams.string kernel strings urls lcs inspector present io ; @@ -100,6 +100,6 @@ $nl { $subsection farkup } "Creating custom components:" { $subsection render* } -"Custom components can emit HTML using the " { $vocab-link "html.elements" } " vocabulary." ; +"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ; ABOUT: "html.components" diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index 09bb5860ad..b3ea0319a8 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -1,7 +1,8 @@ IN: html.components.tests USING: tools.test kernel io.streams.string io.streams.null accessors inspector html.streams -html.elements html.components html.forms namespaces ; +html.components html.forms namespaces +xml.writer ; [ ] [ begin-form ] unit-test @@ -163,9 +164,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ; [ t ] [ [ "object" inspector render ] with-string-writer - USING: splitting sequences ; - "\"" split "'" join ! replace " with ' for now - [ "object" value [ describe ] with-html-writer ] with-string-writer + "object" value [ describe ] with-html-writer xml>string = ] unit-test diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index be197d10e6..40621bc29f 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -22,13 +22,6 @@ GENERIC: render* ( value name renderer -- xml ) render* write-xml [ render-error ] when* ; - name=<-> type=<->/> XML] ; - -PRIVATE> - SINGLETON: label M: label render* @@ -37,7 +30,7 @@ M: label render* SINGLETON: hidden M: hidden render* - drop "hidden" render-input ; + drop [XML name=<-> type="hidden"/> XML] ; : render-field ( value name size type -- xml ) [XML name=<-> size=<-> type=<->/> XML] ; @@ -163,9 +156,7 @@ M: farkup render* SINGLETON: inspector M: inspector render* - 2drop [ - [ describe ] with-html-writer - ] with-string-writer ; + 2drop [ describe ] with-html-writer ; ! Diff component SINGLETON: comparison diff --git a/basis/html/elements/elements-docs.factor b/basis/html/elements/elements-docs.factor index 05b202e08e..7f60eca93f 100644 --- a/basis/html/elements/elements-docs.factor +++ b/basis/html/elements/elements-docs.factor @@ -20,10 +20,6 @@ $nl $nl "Writing unescaped HTML to " { $vocab-link "html.streams" } ":" { $subsection write-html } -{ $subsection print-html } -"Writing some common HTML patterns:" -{ $subsection xhtml-preamble } -{ $subsection simple-page } -{ $subsection render-error } ; +{ $subsection print-html } ; ABOUT: "html.elements" diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index b0e46984d7..e23d929d6d 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -6,6 +6,14 @@ xml.data xml.literals urls math math.parser combinators present fry io.streams.string xml.writer html ; IN: html.elements +SYMBOL: html + +: write-html ( str -- ) + H{ { html t } } format ; + +: print-html ( str -- ) + write-html "\n" write-html ; + << : elements-vocab ( -- vocab-name ) "html.elements" ; diff --git a/basis/html/html.factor b/basis/html/html.factor index 5469941972..5e86add10e 100644 --- a/basis/html/html.factor +++ b/basis/html/html.factor @@ -1,23 +1,10 @@ -! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg. +! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg, +! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel xml.data xml.writer io.streams.string -xml.literals io.styles ; +USING: kernel xml.data xml.writer xml.literals urls.encoding ; IN: html -SYMBOL: html - -: write-html ( str -- ) - H{ { html t } } format ; - -: print-html ( str -- ) - write-html "\n" write-html ; - -: xhtml-preamble ( -- ) - "" write-html - "" write-html ; - -: simple-page ( title head-quot body-quot -- ) - [ with-string-writer ] bi@ +: simple-page ( title head body -- xml ) @@ -28,7 +15,10 @@ SYMBOL: html <-> - XML> write-xml ; inline + XML> ; inline -: render-error ( message -- ) - [XML <-> XML] write-xml ; +: render-error ( message -- xml ) + [XML <-> XML] ; + +: simple-link ( xml url -- xml' ) + url-encode swap [XML ><-> XML] ; \ No newline at end of file diff --git a/basis/html/streams/streams-docs.factor b/basis/html/streams/streams-docs.factor index f05eeb30fc..c85ab739b8 100644 --- a/basis/html/streams/streams-docs.factor +++ b/basis/html/streams/streams-docs.factor @@ -1,33 +1,33 @@ IN: html.streams USING: help.markup help.syntax kernel strings io io.styles -quotations ; +quotations xml.data ; -HELP: browser-link-href -{ $values { "presented" object } { "href" string } } -{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-stream } " instances." } ; +HELP: url-of +{ $values { "object" object } { "url" string } } +{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-writer } " instances." } ; -HELP: html-stream -{ $class-description "A formatted output stream which emits HTML markup." } ; +HELP: html-writer +{ $class-description "A formatted output stream which accumulates HTML markup as " { $vocab-link "xml.data" } " types. The " { $slot "data" } " slot contains a sequence with all markup so far." } ; -HELP: -{ $values { "stream" "an output stream" } { "html-stream" html-stream } } -{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ; +HELP: +{ $values { "html-writer" html-writer } } +{ $description "Creates a new formatted output stream which accumulates HTML markup in its " { $snippet "data" } " slot." } ; HELP: with-html-writer -{ $values { "quot" quotation } } -{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." } +{ $values { "quot" quotation } { "xml" xml-chunk } } +{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-writer } ". When the quotation returns, outputs the accumulated HTML markup." } { $examples { $example - "USING: io io.styles html.streams ;" - "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer" - "Hello
" + "USING: io io.styles html.streams xml.writer ;" + "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer write-xml" + "Hello
" } } ; ARTICLE: "html.streams" "HTML streams" -"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream." -{ $subsection html-stream } -{ $subsection } +"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "io.styles" } " by constructing HTML markup in the form of " { $vocab-link "xml.data" } " types." +{ $subsection html-writer } +{ $subsection } { $subsection with-html-writer } ; ABOUT: "html.streams" diff --git a/basis/html/streams/streams-tests.factor b/basis/html/streams/streams-tests.factor index 94229b3aea..249861b12a 100644 --- a/basis/html/streams/streams-tests.factor +++ b/basis/html/streams/streams-tests.factor @@ -1,17 +1,14 @@ USING: html.streams html.streams.private accessors io io.streams.string io.styles kernel namespaces tools.test -xml.writer sbufs sequences inspector colors ; +xml.writer sbufs sequences inspector colors xml.writer +classes.predicate prettyprint ; IN: html.streams.tests -: make-html-string - [ with-html-writer ] with-string-writer ; inline +: make-html-string ( quot -- string ) + [ with-html-writer write-xml ] with-string-writer ; inline [ [ ] make-html-string ] must-infer -[ ] [ - 512 drop -] unit-test - [ "" ] [ [ "" write ] make-html-string ] unit-test @@ -24,31 +21,26 @@ IN: html.streams.tests [ "<" write ] make-html-string ] unit-test -[ "<" ] [ - [ "<" H{ } output-stream get format-html-span ] make-html-string -] unit-test - TUPLE: funky town ; -M: funky browser-link-href - "http://www.funky-town.com/" swap town>> append ; +M: funky url-of "http://www.funky-town.com/" swap town>> append ; -[ "<" ] [ +[ "<" ] [ [ "<" "austin" funky boa write-object ] make-html-string ] unit-test -[ "car" ] +[ "car" ] [ [ "car" - H{ { font "monospace" } } + H{ { font-name "monospace" } } format ] make-html-string ] unit-test -[ "car" ] +[ "car" ] [ [ "car" @@ -57,7 +49,7 @@ M: funky browser-link-href ] make-html-string ] unit-test -[ "
cdr
" ] +[ "
cdr
" ] [ [ H{ { page-color T{ rgba f 1 0 1 1 } } } @@ -65,10 +57,10 @@ M: funky browser-link-href ] make-html-string ] unit-test -[ - "
" -] [ +[ "
" ] [ [ H{ } [ ] with-nesting nl ] make-html-string ] unit-test -[ ] [ [ { 1 2 3 } describe ] with-html-writer ] unit-test +[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test + +[ ] [ [ \ predicate-instance? def>> . ] with-html-writer drop ] unit-test diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 51eb37b83d..768f2bbaa8 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -1,17 +1,17 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators generic assocs io io.styles -io.files continuations io.streams.string kernel math math.order -math.parser namespaces make quotations assocs sequences strings -words html.elements xml.entities sbufs continuations destructors -accessors arrays urls.encoding html ; +USING: accessors kernel assocs io io.styles math math.order math.parser +sequences strings make words combinators macros xml.literals html fry +destructors ; IN: html.streams -GENERIC: browser-link-href ( presented -- href ) +GENERIC: url-of ( object -- url ) -M: object browser-link-href drop f ; +M: object url-of drop f ; -TUPLE: html-stream stream last-div ; +TUPLE: html-writer data last-div ; + +>last-div ; inline -: ( stream -- html-stream ) - f html-stream boa ; +: new-html-writer ( class -- html-writer ) + new V{ } clone >>data ; inline - >>stream + new-html-writer swap >>parent swap >>style ; inline : end-sub-stream ( substream -- string style stream ) - [ stream>> >string ] [ style>> ] [ parent>> ] tri ; + [ data>> ] [ style>> ] [ parent>> ] tri ; -: object-link-tag ( style quot -- ) - presented pick at [ - browser-link-href [ - call - ] [ call ] if* - ] [ call ] if* ; inline +: object-link-tag ( xml style -- xml ) + presented swap at [ url-of [ simple-link ] when* ] when* ; -: href-link-tag ( style quot -- ) - href pick at [ - call - ] [ call ] if* ; inline +: href-link-tag ( xml style -- xml ) + href swap at [ simple-link ] when* ; : hex-color, ( color -- ) [ red>> ] [ green>> ] [ blue>> ] tri - [ 255 * >fixnum >hex 2 CHAR: 0 pad-head % ] tri@ ; + [ 255 * >integer >hex 2 CHAR: 0 pad-head % ] tri@ ; : fg-css, ( color -- ) "color: #" % hex-color, "; " % ; @@ -76,32 +67,29 @@ TUPLE: html-sub-stream < html-stream style parent ; : font-css, ( font -- ) "font-family: " % % "; " % ; -: apply-style ( style key quot -- style gadget ) - [ over at ] dip when* ; inline - -: make-css ( style quot -- str ) - "" make nip ; inline +MACRO: make-css ( pairs -- str ) + [ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map + '[ [ _ cleave ] "" make ] ; : span-css-style ( style -- str ) - [ - foreground [ fg-css, ] apply-style - background [ bg-css, ] apply-style - font [ font-css, ] apply-style - font-style [ style-css, ] apply-style - font-size [ size-css, ] apply-style - ] make-css ; + { + { foreground fg-css, } + { background bg-css, } + { font-name font-css, } + { font-style style-css, } + { font-size size-css, } + } make-css ; -: span-tag ( style quot -- ) - over span-css-style [ - call - ] [ - call - ] if-empty ; inline +: span-tag ( xml style -- xml ) + span-css-style + [ swap [XML ><-> XML] ] unless-empty ; inline + +: emit-html ( quot stream -- ) + dip data>> push ; inline : format-html-span ( string style stream -- ) - stream>> [ - [ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag - ] with-output-stream* ; + [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ] + emit-html ; TUPLE: html-span-stream < html-sub-stream ; @@ -113,28 +101,26 @@ M: html-span-stream dispose : padding-css, ( padding -- ) "padding: " % # "px; " % ; -: pre-css, ( margin -- ) - [ "white-space: pre; font-family: monospace; " % ] unless ; +CONSTANT: pre-css "white-space: pre; font-family: monospace;" : div-css-style ( style -- str ) [ - page-color [ bg-css, ] apply-style - border-color [ border-css, ] apply-style - border-width [ padding-css, ] apply-style - wrap-margin over at pre-css, - ] make-css ; - -: div-tag ( style quot -- ) - swap div-css-style [ - call + { + { page-color bg-css, } + { border-color border-css, } + { border-width padding-css, } + } make-css ] [ -
call
- ] if-empty ; inline + wrap-margin swap at + [ pre-css append ] unless + ] bi ; + +: div-tag ( xml style -- xml' ) + div-css-style + [ swap [XML
><->
XML] ] unless-empty ; : format-html-div ( string style stream -- ) - stream>> [ - [ [ write ] div-tag ] object-link-tag - ] with-output-stream* ; + [ [ div-tag ] [ object-link-tag ] bi ] emit-html ; TUPLE: html-block-stream < html-sub-stream ; @@ -145,57 +131,51 @@ M: html-block-stream dispose ( quot style stream -- ) "padding: " % first2 max 2 /i # "px; " % ; : table-style ( style -- str ) - [ - table-border [ border-css, ] apply-style - table-gap [ border-spacing-css, ] apply-style - ] make-css ; - -: table-attrs ( style -- ) - table-style " border-collapse: collapse;" append =style ; - -: do-escaping ( string style -- string ) - html swap at [ escape-string ] unless ; + { + { table-border border-css, } + { table-gap border-spacing-css, } + } make-css + " border-collapse: collapse;" append ; PRIVATE> ! Stream protocol -M: html-stream stream-flush - stream>> stream-flush ; +M: html-writer stream-flush drop ; -M: html-stream stream-write1 - [ 1string ] dip stream-write ; +M: html-writer stream-write1 + not-a-div [ 1string ] emit-html ; -M: html-stream stream-write - not-a-div [ escape-string ] dip stream>> stream-write ; +M: html-writer stream-write + not-a-div [ ] emit-html ; -M: html-stream stream-format - [ html over at [ [ escape-string ] dip ] unless ] dip +M: html-writer stream-format format-html-span ; -M: html-stream stream-nl - dup last-div? [ drop ] [ [
] with-output-stream* ] if ; +M: html-writer stream-nl + dup last-div? [ drop ] [ [ [XML
XML] ] emit-html ] if ; -M: html-stream make-span-stream +M: html-writer make-span-stream html-span-stream new-html-sub-stream ; -M: html-stream make-block-stream +M: html-writer make-block-stream html-block-stream new-html-sub-stream ; -M: html-stream make-cell-stream +M: html-writer make-cell-stream html-sub-stream new-html-sub-stream ; -M: html-stream stream-write-table - a-div stream>> [ - swap [ - [ - - ] with each - ] with each
- stream>> >string write -
- ] with-output-stream* ; +M: html-writer stream-write-table + a-div [ + table-style swap [ + [ data>> [XML ><-> XML] ] with map + [XML <-> XML] + ] with map + [XML <->
XML] + ] emit-html ; -M: html-stream dispose stream>> dispose ; +M: html-writer dispose drop ; -: with-html-writer ( quot -- ) - output-stream get swap with-output-stream* ; inline +: ( -- html-writer ) + html-writer new-html-writer ; + +: with-html-writer ( quot -- xml ) + [ swap with-output-stream* ] keep data>> ; inline diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index 23bb469627..c419c4a197 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -1,12 +1,10 @@ ! Copyright (C) 2005 Alex Chapman -! Copyright (C) 2006, 2008 Slava Pestov +! Copyright (C) 2006, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel namespaces debugger -combinators math quotations generic strings splitting -accessors assocs fry vocabs.parser -parser lexer io io.files io.streams.string io.encodings.utf8 -html -html.templates ; +combinators math quotations generic strings splitting accessors +assocs fry vocabs.parser parser lexer io io.files +io.streams.string io.encodings.utf8 html.templates ; IN: html.templates.fhtml ! We use a custom lexer so that %> ends a token even if not @@ -34,13 +32,13 @@ DEFER: <% delimiter [ over line-text>> [ column>> ] 2dip subseq parsed - \ write-html parsed + \ write parsed ] 2keep 2 + >>column drop ; : still-looking ( accum lexer -- accum ) [ [ line-text>> ] [ column>> ] bi tail - parsed \ print-html parsed + parsed \ print parsed ] keep next-line ; : parse-%> ( accum lexer -- accum ) diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index 6951f09efe..efaf8d6a62 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -67,7 +67,7 @@ SYMBOL: nested-template? SYMBOL: next-template : call-next-template ( -- ) - next-template get write-html ; + next-template get write ; M: f call-template* drop call-next-template ;