+++ /dev/null
-Slava Pestov
-Matthew Willis
-Chris Double
--- /dev/null
+IN: html.components.tests
+USING: html.components tools.test kernel io.streams.string
+io.streams.null accessors ;
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ 3 "hi" set-value ] unit-test
+
+[ 3 ] [ "hi" value ] unit-test
+
+TUPLE: color red green blue ;
+
+[ ] [ 1 2 3 color boa from-tuple ] unit-test
+
+[ 1 ] [ "red" value ] unit-test
+
+[ ] [ "jimmy" "red" set-value ] unit-test
+
+[ "123.5" ] [ 123.5 object>string ] unit-test
+
+[ "jimmy" ] [
+ [
+ "red" label render
+ ] with-string-writer
+] unit-test
+
+[ ] [ "<jimmy>" "red" set-value ] unit-test
+
+[ "<jimmy>" ] [
+ [
+ "red" label render
+ ] with-string-writer
+] unit-test
+
+[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
+ [
+ "red" hidden render
+ ] with-string-writer
+] unit-test
+
+[ ] [ "'jimmy'" "red" set-value ] unit-test
+
+[ "<input type='text' size='5' name='red' value=''jimmy''/>" ] [
+ [
+ "red" <field> 5 >>size render
+ ] with-string-writer
+] unit-test
+
+[ "<input type='password' size='5' name='red' value=''/>" ] [
+ [
+ "red" <password> 5 >>size render
+ ] with-string-writer
+] unit-test
+
+[ ] [
+ [
+ "green" <textarea> render
+ ] with-null-writer
+] unit-test
+
+[ ] [
+ [
+ "green" <textarea> 25 >>rows 30 >>columns render
+ ] with-null-writer
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ "new york" "city1" set-value ] unit-test
+
+[ ] [
+ [
+ "city1"
+ <choice>
+ { "new york" "los angeles" "chicago" } >>choices
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [ { "los angeles" "new york" } "city2" set-value ] unit-test
+
+[ ] [
+ [
+ "city2"
+ <choice>
+ { "new york" "los angeles" "chicago" } >>choices
+ t >>multiple
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [
+ [
+ "city2"
+ <choice>
+ { "new york" "los angeles" "chicago" } >>choices
+ t >>multiple
+ 5 >>size
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ t "delivery" set-value ] unit-test
+
+[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
+ [
+ "delivery"
+ <checkbox>
+ "Delivery" >>label
+ render
+ ] with-string-writer
+] unit-test
+
+[ ] [ f "delivery" set-value ] unit-test
+
+[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
+ [
+ "delivery"
+ <checkbox>
+ "Delivery" >>label
+ render
+ ] with-string-writer
+] unit-test
+
+SINGLETON: link-test
+
+M: link-test link-title drop "<Link Title>" ;
+
+M: link-test link-href drop "http://www.apple.com/foo&bar" ;
+
+[ ] [ link-test "link" set-value ] unit-test
+
+[ "<a href='http://www.apple.com/foo&bar'><Link Title></a>" ] [
+ [ "link" link render ] with-string-writer
+] unit-test
+
+[ ] [
+ "<html>arbitrary <b>markup</b> for the win!</html>" "html" set-value
+] unit-test
+
+[ "<html>arbitrary <b>markup</b> for the win!</html>" ] [
+ [ "html" html render ] with-string-writer
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces io math.parser assocs classes
+classes.tuple words arrays sequences splitting mirrors
+hashtables combinators continuations math strings
+fry locals calendar calendar.format xml.entities validators
+html.elements ;
+IN: html.components
+
+SYMBOL: values
+
+: value values get at ;
+
+: set-value values get set-at ;
+
+: blank-values H{ } clone values set ;
+
+: from-tuple <mirror> values set ;
+
+: values-tuple values get object>> ;
+
+: object>string ( object -- string )
+ {
+ { [ dup real? ] [ number>string ] }
+ { [ dup timestamp? ] [ timestamp>string ] }
+ { [ dup string? ] [ ] }
+ { [ dup not ] [ drop "" ] }
+ } cond ;
+
+GENERIC: render* ( value name render -- )
+
+: render ( name renderer -- )
+ over validation-messages get at [
+ [ value>> ] [ message>> ] bi
+ [ -rot render* ] dip
+ render-error
+ ] [
+ [ [ value ] keep ] dip render*
+ ] if* ;
+
+<PRIVATE
+
+: render-input ( value name type -- )
+ <input =type =name object>string =value input/> ;
+
+PRIVATE>
+
+SINGLETON: label
+
+M: label render* 2drop object>string escape-string write ;
+
+SINGLETON: hidden
+
+M: hidden render* drop "hidden" render-input ;
+
+: render-field ( value name size type -- )
+ <input
+ =type
+ [ number>string =size ] when*
+ =name
+ object>string =value
+ input/> ;
+
+TUPLE: field size ;
+
+: <field> ( -- field )
+ field new ;
+
+M: field render* size>> "text" render-field ;
+
+TUPLE: password size ;
+
+: <password> ( -- password )
+ password new ;
+
+M: password render*
+ #! Don't send passwords back to the user
+ [ drop "" ] 2dip size>> "password" render-field ;
+
+! Text areas
+TUPLE: textarea rows columns ;
+
+: <textarea> ( -- renderer )
+ textarea new ;
+
+M: textarea render*
+ <textarea
+ [ rows>> [ number>string =rows ] when* ]
+ [ columns>> [ number>string =cols ] when* ] bi
+ =name
+ textarea>
+ object>string escape-string write
+ </textarea> ;
+
+! Choice
+TUPLE: choice size choices multiple ;
+
+: <choice> ( -- choice )
+ choice new ;
+
+: render-option ( text selected? -- )
+ <option [ "true" =selected ] when option>
+ escape-string write
+ </option> ;
+
+: render-options ( options selected -- )
+ '[ dup , member? render-option ] each ;
+
+M: choice render*
+ <select
+ swap =name
+ dup size>> [ number>string =size ] when*
+ dup multiple>> [ "true" =multiple ] when
+ select>
+ [ choices>> ] [ multiple>> ] bi
+ [ swap ] [ swap 1array ] if
+ render-options
+ </select> ;
+
+! Checkboxes
+TUPLE: checkbox label ;
+
+: <checkbox> ( -- checkbox )
+ checkbox new ;
+
+M: checkbox render*
+ <input
+ "checkbox" =type
+ swap =name
+ swap [ "true" =selected ] when
+ input>
+ label>> escape-string write
+ </input> ;
+
+! Link components
+GENERIC: link-title ( obj -- string )
+GENERIC: link-href ( obj -- url )
+
+SINGLETON: link
+
+M: link render*
+ 2drop
+ <a dup link-href =href a>
+ link-title object>string escape-string write
+ </a> ;
+
+! HTML component
+SINGLETON: html
+
+M: html render* 2drop write ;
IN: html.elements.tests
-USING: tools.test html html.elements io.streams.string ;
-
-: make-html-string
- [ with-html-stream ] with-string-writer ;
+USING: tools.test html.elements io.streams.string ;
[ "<a href='h&o'>" ]
-[ [ <a "h&o" =href a> ] make-html-string ] unit-test
+[ [ <a "h&o" =href a> ] with-string-writer ] unit-test
: print-html ( str -- )
write-html "\n" write-html ;
+<<
+
: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
dup "=" prepend swap
[ write-attr ] curry attribute-effect html-word ;
+! Define some closed HTML tags
+[
+ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
+ "ol" "li" "form" "a" "p" "html" "head" "body" "title"
+ "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
+ "script" "div" "span" "select" "option" "style" "input"
+] [ define-closed-html-word ] each
+
+! Define some open HTML tags
+[
+ "input"
+ "br"
+ "link"
+ "img"
+] [ define-open-html-word ] each
+
+! Define some attributes
[
- ! Define some closed HTML tags
- [
- "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
- "ol" "li" "form" "a" "p" "html" "head" "body" "title"
- "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
- "script" "div" "span" "select" "option" "style" "input"
- ] [ define-closed-html-word ] each
-
- ! Define some open HTML tags
- [
- "input"
- "br"
- "link"
- "img"
- ] [ define-open-html-word ] each
-
- ! Define some attributes
- [
- "method" "action" "type" "value" "name"
- "size" "href" "class" "border" "rows" "cols"
- "id" "onclick" "style" "valign" "accesskey"
- "src" "language" "colspan" "onchange" "rel"
- "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
- "media" "title" "multiple"
- ] [ define-attribute-word ] each
-] with-compilation-unit
+ "method" "action" "type" "value" "name"
+ "size" "href" "class" "border" "rows" "cols"
+ "id" "onclick" "style" "valign" "accesskey"
+ "src" "language" "colspan" "onchange" "rel"
+ "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
+ "media" "title" "multiple"
+] [ define-attribute-word ] each
+
+>>
+
+: xhtml-preamble ( -- )
+ "<?xml version=\"1.0\"?>" write-html
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
+
+: simple-page ( title quot -- )
+ #! Call the quotation, with all output going to the
+ #! body of an html page with the given title.
+ xhtml-preamble
+ <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
+ <head> <title> swap write </title> </head>
+ <body> call </body>
+ </html> ;
+
+: render-error ( message -- )
+ <span "error" =class span> escape-string write </span> ;
+++ /dev/null
-USING: html http io io.streams.string io.styles kernel
-namespaces tools.test xml.writer sbufs sequences html.private ;
-IN: html.tests
-
-: make-html-string
- [ with-html-stream ] with-string-writer ; inline
-
-[ [ ] make-html-string ] must-infer
-
-[ ] [
- 512 <sbuf> <html-stream> drop
-] unit-test
-
-[ "" ] [
- [ "" write ] make-html-string
-] unit-test
-
-[ "a" ] [
- [ CHAR: a write1 ] make-html-string
-] unit-test
-
-[ "<" ] [
- [ "<" 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 funky-town append ;
-
-[ "<a href='http://www.funky-town.com/austin'><</a>" ] [
- [
- "<" "austin" funky boa write-object
- ] make-html-string
-] unit-test
-
-[ "<span style='font-family: monospace; '>car</span>" ]
-[
- [
- "car"
- H{ { font "monospace" } }
- format
- ] make-html-string
-] unit-test
-
-[ "<span style='color: #ff00ff; '>car</span>" ]
-[
- [
- "car"
- H{ { foreground { 1 0 1 1 } } }
- format
- ] make-html-string
-] unit-test
-
-[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
-[
- [
- H{ { page-color { 1 0 1 1 } } }
- [ "cdr" write ] with-nesting
- ] make-html-string
-] unit-test
-
-[
- "<div style='white-space: pre; font-family: monospace; '></div>"
-] [
- [ H{ } [ ] with-nesting nl ] make-html-string
-] unit-test
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic assocs help http io io.styles io.files continuations
-io.streams.string kernel math math.order math.parser namespaces
-quotations assocs sequences strings words html.elements
-xml.entities sbufs continuations destructors ;
-IN: html
-
-GENERIC: browser-link-href ( presented -- href )
-
-M: object browser-link-href drop f ;
-
-TUPLE: html-stream last-div? ;
-
-! A hack: stream-nl after with-nesting or tabular-output is
-! ignored, so that HTML stream output looks like UI pane output
-: test-last-div? ( stream -- ? )
- dup html-stream-last-div?
- f rot set-html-stream-last-div? ;
-
-: not-a-div ( stream -- stream )
- dup test-last-div? drop ; inline
-
-: a-div ( stream -- straem )
- t over set-html-stream-last-div? ; inline
-
-: <html-stream> ( stream -- stream )
- html-stream construct-delegate ;
-
-<PRIVATE
-
-TUPLE: html-sub-stream style stream ;
-
-: (html-sub-stream) ( style stream -- stream )
- html-sub-stream boa
- 512 <sbuf> <html-stream> over set-delegate ;
-
-: <html-sub-stream> ( style stream class -- stream )
- >r (html-sub-stream) r> construct-delegate ; inline
-
-: end-sub-stream ( substream -- string style stream )
- dup delegate >string
- over html-sub-stream-style
- rot html-sub-stream-stream ;
-
-: delegate-write ( string -- )
- output-stream get delegate stream-write ;
-
-: object-link-tag ( style quot -- )
- presented pick at [
- browser-link-href [
- <a =href a> call </a>
- ] [ call ] if*
- ] [ call ] if* ; inline
-
-: hex-color, ( triplet -- )
- 3 head-slice
- [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
-
-: fg-css, ( color -- )
- "color: #" % hex-color, "; " % ;
-
-: bg-css, ( color -- )
- "background-color: #" % hex-color, "; " % ;
-
-: style-css, ( flag -- )
- dup
- { italic bold-italic } member?
- "font-style: " % "italic" "normal" ? % "; " %
- { bold bold-italic } member?
- "font-weight: " % "bold" "normal" ? % "; " % ;
-
-: size-css, ( size -- )
- "font-size: " % # "pt; " % ;
-
-: font-css, ( font -- )
- "font-family: " % % "; " % ;
-
-: apply-style ( style key quot -- style gadget )
- >r over at r> when* ; inline
-
-: make-css ( style quot -- str )
- "" make nip ; inline
-
-: 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 ;
-
-: span-tag ( style quot -- )
- over span-css-style dup empty? [
- drop call
- ] [
- <span =style span> call </span>
- ] if ; inline
-
-: format-html-span ( string style stream -- )
- [
- [ [ drop delegate-write ] span-tag ] object-link-tag
- ] with-output-stream* ;
-
-TUPLE: html-span-stream ;
-
-M: html-span-stream dispose
- end-sub-stream not-a-div format-html-span ;
-
-: border-css, ( border -- )
- "border: 1px solid #" % hex-color, "; " % ;
-
-: padding-css, ( padding -- ) "padding: " % # "px; " % ;
-
-: pre-css, ( margin -- )
- [ "white-space: pre; font-family: monospace; " % ] unless ;
-
-: 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 dup empty? [
- drop call
- ] [
- <div =style div> call </div>
- ] if ; inline
-
-: format-html-div ( string style stream -- )
- [
- [ [ delegate-write ] div-tag ] object-link-tag
- ] with-output-stream* ;
-
-TUPLE: html-block-stream ;
-
-M: html-block-stream dispose ( quot style stream -- )
- end-sub-stream a-div format-html-div ;
-
-: border-spacing-css,
- "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 ;
-
-PRIVATE>
-
-! Stream protocol
-M: html-stream stream-write1 ( char stream -- )
- >r 1string r> stream-write ;
-
-M: html-stream stream-write ( str stream -- )
- not-a-div >r escape-string r> delegate stream-write ;
-
-M: html-stream make-span-stream ( style stream -- stream' )
- html-span-stream <html-sub-stream> ;
-
-M: html-stream stream-format ( str style stream -- )
- >r html over at [ >r escape-string r> ] unless r>
- format-html-span ;
-
-M: html-stream make-block-stream ( style stream -- stream' )
- html-block-stream <html-sub-stream> ;
-
-M: html-stream stream-write-table ( grid style stream -- )
- a-div [
- <table dup table-attrs table> swap [
- <tr> [
- <td "top" =valign swap table-style =style td>
- >string write-html
- </td>
- ] with each </tr>
- ] with each </table>
- ] with-output-stream* ;
-
-M: html-stream make-cell-stream ( style stream -- stream' )
- (html-sub-stream) ;
-
-M: html-stream stream-nl ( stream -- )
- dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
-
-! Utilities
-: with-html-stream ( quot -- )
- output-stream get <html-stream> swap with-output-stream* ; inline
-
-: xhtml-preamble
- "<?xml version=\"1.0\"?>" write-html
- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
-
-: html-document ( body-quot head-quot -- )
- #! head-quot is called to produce output to go
- #! in the html head portion of the document.
- #! body-quot is called to produce output to go
- #! in the html body portion of the document.
- xhtml-preamble
- <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
- <head> call </head>
- <body> call </body>
- </html> ;
-
-: default-css ( -- )
- <link
- "stylesheet" =rel "text/css" =type
- "/responder/resources/extra/html/stylesheet.css" =href
- link/> ;
-
-: simple-html-document ( title quot -- )
- swap [
- <title> write </title>
- default-css
- ] html-document ;
-
-: vertical-layout ( list -- )
- #! Given a list of HTML components, arrange them vertically.
- <table>
- [ <tr> <td> call </td> </tr> ] each
- </table> ;
-
-: horizontal-layout ( list -- )
- #! Given a list of HTML components, arrange them horizontally.
- <table>
- <tr "top" =valign tr> [ <td> call </td> ] each </tr>
- </table> ;
-
-: button ( label -- )
- #! Output an HTML submit button with the given label.
- <input "submit" =type =value input/> ;
-
-: paragraph ( str -- )
- #! Output the string as an html paragraph
- <p> write </p> ;
-
-: simple-page ( title quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title.
- <html>
- <head> <title> swap write </title> </head>
- <body> call </body>
- </html> ;
-
-: styled-page ( title stylesheet-quot quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title. stylesheet-quot
- #! is called to generate the required stylesheet.
- <html>
- <head>
- <title> rot write </title>
- swap call
- </head>
- <body> call </body>
- </html> ;
-
-: render-error ( message -- )
- <span "error" =class span> escape-string write </span> ;
--- /dev/null
+Slava Pestov
+Matthew Willis
+Chris Double
--- /dev/null
+USING: html.streams html.streams.private
+io io.streams.string io.styles kernel
+namespaces tools.test xml.writer sbufs sequences ;
+IN: html.streams.tests
+
+: make-html-string
+ [ with-html-stream ] with-string-writer ; inline
+
+[ [ ] make-html-string ] must-infer
+
+[ ] [
+ 512 <sbuf> <html-stream> drop
+] unit-test
+
+[ "" ] [
+ [ "" write ] make-html-string
+] unit-test
+
+[ "a" ] [
+ [ CHAR: a write1 ] make-html-string
+] unit-test
+
+[ "<" ] [
+ [ "<" 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 funky-town append ;
+
+[ "<a href='http://www.funky-town.com/austin'><</a>" ] [
+ [
+ "<" "austin" funky boa write-object
+ ] make-html-string
+] unit-test
+
+[ "<span style='font-family: monospace; '>car</span>" ]
+[
+ [
+ "car"
+ H{ { font "monospace" } }
+ format
+ ] make-html-string
+] unit-test
+
+[ "<span style='color: #ff00ff; '>car</span>" ]
+[
+ [
+ "car"
+ H{ { foreground { 1 0 1 1 } } }
+ format
+ ] make-html-string
+] unit-test
+
+[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
+[
+ [
+ H{ { page-color { 1 0 1 1 } } }
+ [ "cdr" write ] with-nesting
+ ] make-html-string
+] unit-test
+
+[
+ "<div style='white-space: pre; font-family: monospace; '></div>"
+] [
+ [ H{ } [ ] with-nesting nl ] make-html-string
+] unit-test
--- /dev/null
+! Copyright (C) 2004, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: generic assocs help http io io.styles io.files continuations
+io.streams.string kernel math math.order math.parser namespaces
+quotations assocs sequences strings words html.elements
+xml.entities sbufs continuations destructors ;
+IN: html.streams
+
+GENERIC: browser-link-href ( presented -- href )
+
+M: object browser-link-href drop f ;
+
+TUPLE: html-stream last-div? ;
+
+! A hack: stream-nl after with-nesting or tabular-output is
+! ignored, so that HTML stream output looks like UI pane output
+: test-last-div? ( stream -- ? )
+ dup html-stream-last-div?
+ f rot set-html-stream-last-div? ;
+
+: not-a-div ( stream -- stream )
+ dup test-last-div? drop ; inline
+
+: a-div ( stream -- straem )
+ t over set-html-stream-last-div? ; inline
+
+: <html-stream> ( stream -- stream )
+ html-stream construct-delegate ;
+
+<PRIVATE
+
+TUPLE: html-sub-stream style stream ;
+
+: (html-sub-stream) ( style stream -- stream )
+ html-sub-stream boa
+ 512 <sbuf> <html-stream> over set-delegate ;
+
+: <html-sub-stream> ( style stream class -- stream )
+ >r (html-sub-stream) r> construct-delegate ; inline
+
+: end-sub-stream ( substream -- string style stream )
+ dup delegate >string
+ over html-sub-stream-style
+ rot html-sub-stream-stream ;
+
+: delegate-write ( string -- )
+ output-stream get delegate stream-write ;
+
+: object-link-tag ( style quot -- )
+ presented pick at [
+ browser-link-href [
+ <a =href a> call </a>
+ ] [ call ] if*
+ ] [ call ] if* ; inline
+
+: hex-color, ( triplet -- )
+ 3 head-slice
+ [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
+
+: fg-css, ( color -- )
+ "color: #" % hex-color, "; " % ;
+
+: bg-css, ( color -- )
+ "background-color: #" % hex-color, "; " % ;
+
+: style-css, ( flag -- )
+ dup
+ { italic bold-italic } member?
+ "font-style: " % "italic" "normal" ? % "; " %
+ { bold bold-italic } member?
+ "font-weight: " % "bold" "normal" ? % "; " % ;
+
+: size-css, ( size -- )
+ "font-size: " % # "pt; " % ;
+
+: font-css, ( font -- )
+ "font-family: " % % "; " % ;
+
+: apply-style ( style key quot -- style gadget )
+ >r over at r> when* ; inline
+
+: make-css ( style quot -- str )
+ "" make nip ; inline
+
+: 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 ;
+
+: span-tag ( style quot -- )
+ over span-css-style dup empty? [
+ drop call
+ ] [
+ <span =style span> call </span>
+ ] if ; inline
+
+: format-html-span ( string style stream -- )
+ [
+ [ [ drop delegate-write ] span-tag ] object-link-tag
+ ] with-output-stream* ;
+
+TUPLE: html-span-stream ;
+
+M: html-span-stream dispose
+ end-sub-stream not-a-div format-html-span ;
+
+: border-css, ( border -- )
+ "border: 1px solid #" % hex-color, "; " % ;
+
+: padding-css, ( padding -- ) "padding: " % # "px; " % ;
+
+: pre-css, ( margin -- )
+ [ "white-space: pre; font-family: monospace; " % ] unless ;
+
+: 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 dup empty? [
+ drop call
+ ] [
+ <div =style div> call </div>
+ ] if ; inline
+
+: format-html-div ( string style stream -- )
+ [
+ [ [ delegate-write ] div-tag ] object-link-tag
+ ] with-output-stream* ;
+
+TUPLE: html-block-stream ;
+
+M: html-block-stream dispose ( quot style stream -- )
+ end-sub-stream a-div format-html-div ;
+
+: border-spacing-css,
+ "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 ;
+
+PRIVATE>
+
+! Stream protocol
+M: html-stream stream-write1 ( char stream -- )
+ >r 1string r> stream-write ;
+
+M: html-stream stream-write ( str stream -- )
+ not-a-div >r escape-string r> delegate stream-write ;
+
+M: html-stream make-span-stream ( style stream -- stream' )
+ html-span-stream <html-sub-stream> ;
+
+M: html-stream stream-format ( str style stream -- )
+ >r html over at [ >r escape-string r> ] unless r>
+ format-html-span ;
+
+M: html-stream make-block-stream ( style stream -- stream' )
+ html-block-stream <html-sub-stream> ;
+
+M: html-stream stream-write-table ( grid style stream -- )
+ a-div [
+ <table dup table-attrs table> swap [
+ <tr> [
+ <td "top" =valign swap table-style =style td>
+ >string write-html
+ </td>
+ ] with each </tr>
+ ] with each </table>
+ ] with-output-stream* ;
+
+M: html-stream make-cell-stream ( style stream -- stream' )
+ (html-sub-stream) ;
+
+M: html-stream stream-nl ( stream -- )
+ dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
+
+: with-html-stream ( quot -- )
+ output-stream get <html-stream> swap with-output-stream* ; inline
--- /dev/null
+HTML reader, writer and utilities
+++ /dev/null
-a:link { text-decoration: none; color: black; }
-a:visited { text-decoration: none; color: black; }
-a:active { text-decoration: none; color: black; }
-a:hover { text-decoration: underline; color: black; }
+++ /dev/null
-HTML reader, writer and utilities
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
+ 60 v-max-length
"e-mail"
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
v-regexp ;
projects / factor.git / commitdiff