1 ! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: io io.styles kernel namespaces prettyprint quotations
4 sequences strings words xml.entities compiler.units effects
5 xml.data urls math math.parser combinators
6 present fry io.streams.string xml.writer html ;
11 : write-html ( str -- )
12 H{ { html t } } format ;
14 : print-html ( str -- )
15 write-html "\n" write-html ;
19 CONSTANT: elements-vocab "html.elements"
21 : html-word ( name def effect -- )
22 #! Define 'word creating' word to allow
23 #! dynamically creating words.
24 [ elements-vocab create ] 2dip define-declared ;
26 : <foo> ( str -- <str> ) "<" ">" surround ;
28 : def-for-html-word-<foo> ( name -- )
29 #! Return the name and code for the <foo> patterned
31 dup <foo> swap '[ _ <foo> write-html ]
34 : <foo ( str -- <str ) "<" prepend ;
36 : def-for-html-word-<foo ( name -- )
37 #! Return the name and code for the <foo patterned
39 <foo dup '[ _ write-html ]
42 : foo> ( str -- foo> ) ">" append ;
44 : def-for-html-word-foo> ( name -- )
45 #! Return the name and code for the foo> patterned
47 foo> [ ">" write-html ] ( -- ) html-word ;
49 : </foo> ( str -- </str> ) "</" ">" surround ;
51 : def-for-html-word-</foo> ( name -- )
52 #! Return the name and code for the </foo> patterned
54 </foo> dup '[ _ write-html ] ( -- ) html-word ;
56 : <foo/> ( str -- <str/> ) "<" "/>" surround ;
58 : def-for-html-word-<foo/> ( name -- )
59 #! Return the name and code for the <foo/> patterned
61 dup <foo/> swap '[ _ <foo/> write-html ]
64 : foo/> ( str -- str/> ) "/>" append ;
66 : def-for-html-word-foo/> ( name -- )
67 #! Return the name and code for the foo/> patterned
69 foo/> [ "/>" write-html ] ( -- ) html-word ;
71 : define-closed-html-word ( name -- )
72 #! Given an HTML tag name, define the words for
73 #! that closable HTML tag.
74 dup def-for-html-word-<foo>
75 dup def-for-html-word-<foo
76 dup def-for-html-word-foo>
77 def-for-html-word-</foo> ;
79 : define-open-html-word ( name -- )
80 #! Given an HTML tag name, define the words for
81 #! that open HTML tag.
82 dup def-for-html-word-<foo/>
83 dup def-for-html-word-<foo
84 def-for-html-word-foo/> ;
86 : write-attr ( value name -- )
90 present escape-quoted-string write-html
93 : define-attribute-word ( name -- )
95 '[ _ write-attr ] ( string -- ) html-word ;
97 ! Define some closed HTML tags
99 "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
100 "ol" "li" "form" "a" "p" "html" "head" "body" "title"
101 "b" "i" "ul" "table" "thead" "tfoot" "tbody" "tr" "td" "th" "pre" "textarea"
102 "script" "div" "span" "select" "option" "style" "input"
104 ] [ define-closed-html-word ] each
106 ! Define some open HTML tags
114 ] [ define-open-html-word ] each
116 ! Define some attributes
118 "method" "action" "type" "value" "name"
119 "size" "href" "class" "border" "rows" "cols"
120 "id" "onclick" "style" "valign" "accesskey"
121 "src" "language" "colspan" "onchange" "rel"
122 "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
123 "media" "title" "multiple" "checked"
124 "summary" "cellspacing" "align" "scope" "abbr"
125 "nofollow" "alt" "target"
126 ] [ define-attribute-word ] each