factor/basis/html/elements/elements.factor

! cont-html v0.6
!
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.

USING: io kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects
urls math math.parser combinators present fry ;

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" ;

: html-word ( name def effect -- )
    #! Define 'word creating' word to allow
    #! dynamically creating words.
    [ elements-vocab create ] 2dip define-declared ;

: <foo> ( str -- <str> ) "<" ">" surround ;

: def-for-html-word-<foo> ( name -- )
    #! Return the name and code for the <foo> patterned
    #! word.
    dup <foo> swap '[ _ <foo> write-html ]
    (( -- )) html-word ;

: <foo ( str -- <str ) "<" prepend ;

: def-for-html-word-<foo ( name -- )
    #! Return the name and code for the <foo patterned
    #! word.
    <foo dup '[ _ write-html ]
    (( -- )) html-word ;

: foo> ( str -- foo> ) ">" append ;

: def-for-html-word-foo> ( name -- )
    #! Return the name and code for the foo> patterned
    #! word.
    foo> [ ">" write-html ] (( -- )) html-word ;

: </foo> ( str -- </str> ) "</" ">" surround ;

: def-for-html-word-</foo> ( name -- )
    #! Return the name and code for the </foo> patterned
    #! word.
    </foo> dup '[ _ write-html ] (( -- )) html-word ;

: <foo/> ( str -- <str/> ) "<" "/>" surround ;

: def-for-html-word-<foo/> ( name -- )
    #! Return the name and code for the <foo/> patterned
    #! word.
    dup <foo/> swap '[ _ <foo/> write-html ]
    (( -- )) html-word ;

: foo/> ( str -- str/> ) "/>" append ;

: def-for-html-word-foo/> ( name -- )
    #! Return the name and code for the foo/> patterned
    #! word.
    foo/> [ "/>" write-html ] (( -- )) html-word ;

: define-closed-html-word ( name -- )
    #! Given an HTML tag name, define the words for
    #! that closable HTML tag.
    dup def-for-html-word-<foo>
    dup def-for-html-word-<foo
    dup def-for-html-word-foo>
    def-for-html-word-</foo> ;

: define-open-html-word ( name -- )
    #! Given an HTML tag name, define the words for
    #! that open HTML tag.
    dup def-for-html-word-<foo/>
    dup def-for-html-word-<foo
    def-for-html-word-foo/> ;

: write-attr ( value name -- )
    " " write-html
    write-html
    "='" write-html
    present escape-quoted-string write-html
    "'" write-html ;

: define-attribute-word ( name -- )
    dup "=" prepend swap
    '[ _ write-attr ] (( string -- )) 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"
    "strong"
] [ define-closed-html-word ] each

! Define some open HTML tags
[
    "input"
    "br"
    "hr"
    "link"
    "img"
    "base"
] [ 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" "checked"
    "summary" "cellspacing" "align" "scope" "abbr"
    "nofollow" "alt" "target"
] [ define-attribute-word ] each

>>

: xhtml-preamble ( -- )
    "<?xml version=\"1.0\"?>" write-html
    "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;

: simple-page ( title head-quot body-quot -- )
    #! Call the quotation, with all output going to the
    #! body of an html page with the given title.
    spin
    xhtml-preamble
    <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
        <head>
            <title> write </title>
            call
        </head>
        <body> call </body>
    </html> ; inline

: render-error ( message -- )
    <span "error" =class span> escape-string write </span> ;
Initial import 2007-09-20 18:09:08 -04:00			`! cont-html v0.6`
			`!`
			`! Copyright (C) 2004 Chris Double.`
			`! See http://factorcode.org/license.txt for BSD license.`

			`USING: io kernel namespaces prettyprint quotations`
Web framework refactoring work in progress 2008-06-01 18:22:39 -04:00			`sequences strings words xml.entities compiler.units effects`
Use fry in html 2008-06-18 01:35:34 -04:00			`urls math math.parser combinators present fry ;`
Initial import 2007-09-20 18:09:08 -04:00
			`IN: html.elements`

			`SYMBOL: html`

			`: write-html ( str -- )`
			`H{ { html t } } format ;`

			`: print-html ( str -- )`
			`write-html "\n" write-html ;`

Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00			`<<`

Fix html.elements load problem 2008-09-19 16:45:45 -04:00			`: elements-vocab ( -- vocab-name ) "html.elements" ;`

Fixing httpd 2008-01-11 00:48:04 -05:00			`: html-word ( name def effect -- )`
Initial import 2007-09-20 18:09:08 -04:00			`#! Define 'word creating' word to allow`
			`#! dynamically creating words.`
Removing more >r/r> usages 2008-12-03 09:46:16 -05:00			`[ elements-vocab create ] 2dip define-declared ;`
Fixing httpd 2008-01-11 00:48:04 -05:00
swap ... 3append -> surround in basis 2008-12-06 19:58:45 -05:00			`: <foo> ( str -- <str> ) "<" ">" surround ;`
Initial import 2007-09-20 18:09:08 -04:00
			`: def-for-html-word-<foo> ( name -- )`
			`#! Return the name and code for the <foo> patterned`
			`#! word.`
Updating code for make and fry changes 2008-09-10 23:11:40 -04:00			`dup <foo> swap '[ _ <foo> write-html ]`
Mandatory stack effect annotations 2008-06-08 16:32:55 -04:00			`(( -- )) html-word ;`
Initial import 2007-09-20 18:09:08 -04:00
Fixing everything for mandatory stack effects 2008-06-09 03:14:14 -04:00			`: <foo ( str -- <str ) "<" prepend ;`
Initial import 2007-09-20 18:09:08 -04:00
			`: def-for-html-word-<foo ( name -- )`
			`#! Return the name and code for the <foo patterned`
			`#! word.`
Updating code for make and fry changes 2008-09-10 23:11:40 -04:00			`<foo dup '[ _ write-html ]`
Mandatory stack effect annotations 2008-06-08 16:32:55 -04:00			`(( -- )) html-word ;`
Initial import 2007-09-20 18:09:08 -04:00
Fixing everything for mandatory stack effects 2008-06-09 03:14:14 -04:00			`: foo> ( str -- foo> ) ">" append ;`
Initial import 2007-09-20 18:09:08 -04:00
			`: def-for-html-word-foo> ( name -- )`
			`#! Return the name and code for the foo> patterned`
			`#! word.`
Mandatory stack effect annotations 2008-06-08 16:32:55 -04:00			`foo> [ ">" write-html ] (( -- )) html-word ;`
Initial import 2007-09-20 18:09:08 -04:00
swap ... 3append -> surround in basis 2008-12-06 19:58:45 -05:00			`: </foo> ( str -- </str> ) "</" ">" surround ;`
Initial import 2007-09-20 18:09:08 -04:00
			`: def-for-html-word-</foo> ( name -- )`
			`#! Return the name and code for the </foo> patterned`
Fixing httpd 2008-01-11 00:48:04 -05:00			`#! word.`
Updating code for make and fry changes 2008-09-10 23:11:40 -04:00			`</foo> dup '[ _ write-html ] (( -- )) html-word ;`
Initial import 2007-09-20 18:09:08 -04:00
swap ... 3append -> surround in basis 2008-12-06 19:58:45 -05:00			`: <foo/> ( str -- <str/> ) "<" "/>" surround ;`
Initial import 2007-09-20 18:09:08 -04:00
			`: def-for-html-word-<foo/> ( name -- )`
			`#! Return the name and code for the <foo/> patterned`
			`#! word.`
Updating code for make and fry changes 2008-09-10 23:11:40 -04:00			`dup <foo/> swap '[ _ <foo/> write-html ]`
Mandatory stack effect annotations 2008-06-08 16:32:55 -04:00			`(( -- )) html-word ;`
Initial import 2007-09-20 18:09:08 -04:00
Fixing everything for mandatory stack effects 2008-06-09 03:14:14 -04:00			`: foo/> ( str -- str/> ) "/>" append ;`
Initial import 2007-09-20 18:09:08 -04:00
			`: def-for-html-word-foo/> ( name -- )`
			`#! Return the name and code for the foo/> patterned`
Fixing httpd 2008-01-11 00:48:04 -05:00			`#! word.`
Mandatory stack effect annotations 2008-06-08 16:32:55 -04:00			`foo/> [ "/>" write-html ] (( -- )) html-word ;`
Initial import 2007-09-20 18:09:08 -04:00
Fixing httpd 2008-01-11 00:48:04 -05:00			`: define-closed-html-word ( name -- )`
Initial import 2007-09-20 18:09:08 -04:00			`#! Given an HTML tag name, define the words for`
			`#! that closable HTML tag.`
			`dup def-for-html-word-<foo>`
			`dup def-for-html-word-<foo`
			`dup def-for-html-word-foo>`
			`def-for-html-word-</foo> ;`

Fixing httpd 2008-01-11 00:48:04 -05:00			`: define-open-html-word ( name -- )`
Initial import 2007-09-20 18:09:08 -04:00			`#! Given an HTML tag name, define the words for`
			`#! that open HTML tag.`
			`dup def-for-html-word-<foo/>`
			`dup def-for-html-word-<foo`
			`def-for-html-word-foo/> ;`

			`: write-attr ( value name -- )`
			`" " write-html`
			`write-html`
			`"='" write-html`
Various furnace improvements; add present vocabulary for converting objects to human-readable strings 2008-06-05 01:18:36 -04:00			`present escape-quoted-string write-html`
Initial import 2007-09-20 18:09:08 -04:00			`"'" write-html ;`

			`: define-attribute-word ( name -- )`
swap append to swap append refactoring path+ to append-path swap path+ to prepend-path calendar gmt-offset to duration 2008-03-19 20:15:32 -04:00			`dup "=" prepend swap`
Updating code for make and fry changes 2008-09-10 23:11:40 -04:00			`'[ _ write-attr ] (( string -- )) html-word ;`
Initial import 2007-09-20 18:09:08 -04:00
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00			`! 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"`
Some improvements to farkup link handling 2008-09-07 19:06:20 -04:00			`"strong"`
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00			`] [ define-closed-html-word ] each`

			`! Define some open HTML tags`
			`[`
			`"input"`
			`"br"`
<hr/>, it's what farkup craves 2008-09-23 02:50:34 -04:00			`"hr"`
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00			`"link"`
			`"img"`
Clean up some web framework code 2008-09-29 05:10:00 -04:00			`"base"`
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00			`] [ define-open-html-word ] each`

			`! Define some attributes`
Initial import 2007-09-20 18:09:08 -04:00			`[`
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00			`"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"`
Web framework refactoring work in progress 2008-06-01 18:22:39 -04:00			`"media" "title" "multiple" "checked"`
Some improvements to farkup link handling 2008-09-07 19:06:20 -04:00			`"summary" "cellspacing" "align" "scope" "abbr"`
Clean up some web framework code 2008-09-29 05:10:00 -04:00			`"nofollow" "alt" "target"`
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00			`] [ define-attribute-word ] each`

			`>>`

			`: xhtml-preamble ( -- )`
			`"<?xml version=\"1.0\"?>" write-html`
Docs for html.* 2008-09-23 23:01:26 -04:00			`"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;`
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00
Clean up some web framework code 2008-09-29 05:10:00 -04:00			`: simple-page ( title head-quot body-quot -- )`
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00			`#! Call the quotation, with all output going to the`
			`#! body of an html page with the given title.`
Clean up some web framework code 2008-09-29 05:10:00 -04:00			`spin`
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00			`xhtml-preamble`
			`<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>`
Clean up some web framework code 2008-09-29 05:10:00 -04:00			`<head>`
			`<title> write </title>`
			`call`
			`</head>`
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00			`<body> call </body>`
Big web framework refactoring 2008-06-02 16:00:03 -04:00			`</html> ; inline`
Move HTML components to html.components, refactor 2008-05-23 18:33:31 -04:00
			`: render-error ( message -- )`
			`<span "error" =class span> escape-string write </span> ;`