3 ! Copyright (C) 2004 Chris Double.
4 ! See http://factorcode.org/license.txt for BSD license.
6 USING: io kernel namespaces prettyprint quotations
7 sequences strings words xml.entities compiler.units effects
8 urls math math.parser combinators calendar calendar.format ;
12 ! These words are used to provide a means of writing
13 ! formatted HTML to standard output with a familiar 'html' look
14 ! and feel in the code.
16 ! HTML tags can be used in a number of different ways. The highest
17 ! level involves a similar syntax to HTML:
19 ! <p> "someoutput" write </p>
21 ! <p> will output the opening tag and </p> will output the closing
22 ! tag with no attributes.
24 ! <p "red" =class p> "someoutput" write </p>
26 ! This time the opening tag does not have the '>'. It pushes
27 ! a namespace on the stack to hold the attributes and values.
28 ! Any attribute words used will store the attribute and values
29 ! in that namespace. Before the attribute word should come the
30 ! value of that attribute.
31 ! The finishing word will print out the operning tag including
33 ! Any writes after this will appear after the opening tag.
35 ! Values for attributes can be used directly without any stack
39 ! <a =href a> "Click me" write </a>
42 ! <a "http://" prepend =href a> "click" write </a>
45 ! <a [ "http://" % % ] "" make =href a> "click" write </a>
47 ! Tags that have no 'closing' equivalent have a trailing tag/> form:
49 ! <input "text" =type "name" =name "20" =size input/>
51 : elements-vocab ( -- vocab-name ) "html.elements" ;
55 : write-html ( str -- )
56 H{ { html t } } format ;
58 : print-html ( str -- )
59 write-html "\n" write-html ;
63 : html-word ( name def effect -- )
64 #! Define 'word creating' word to allow
65 #! dynamically creating words.
66 >r >r elements-vocab create r> r> define-declared ;
68 : <foo> "<" swap ">" 3append ;
70 : empty-effect T{ effect f 0 0 } ;
72 : def-for-html-word-<foo> ( name -- )
73 #! Return the name and code for the <foo> patterned
75 dup <foo> swap [ <foo> write-html ] curry
76 empty-effect html-word ;
80 : def-for-html-word-<foo ( name -- )
81 #! Return the name and code for the <foo patterned
83 <foo dup [ write-html ] curry
84 empty-effect html-word ;
88 : def-for-html-word-foo> ( name -- )
89 #! Return the name and code for the foo> patterned
91 foo> [ ">" write-html ] empty-effect html-word ;
93 : </foo> "</" swap ">" 3append ;
95 : def-for-html-word-</foo> ( name -- )
96 #! Return the name and code for the </foo> patterned
98 </foo> dup [ write-html ] curry empty-effect html-word ;
100 : <foo/> "<" swap "/>" 3append ;
102 : def-for-html-word-<foo/> ( name -- )
103 #! Return the name and code for the <foo/> patterned
105 dup <foo/> swap [ <foo/> write-html ] curry
106 empty-effect html-word ;
108 : foo/> "/>" append ;
110 : def-for-html-word-foo/> ( name -- )
111 #! Return the name and code for the foo/> patterned
113 foo/> [ "/>" write-html ] empty-effect html-word ;
115 : define-closed-html-word ( name -- )
116 #! Given an HTML tag name, define the words for
117 #! that closable HTML tag.
118 dup def-for-html-word-<foo>
119 dup def-for-html-word-<foo
120 dup def-for-html-word-foo>
121 def-for-html-word-</foo> ;
123 : define-open-html-word ( name -- )
124 #! Given an HTML tag name, define the words for
125 #! that open HTML tag.
126 dup def-for-html-word-<foo/>
127 dup def-for-html-word-<foo
128 def-for-html-word-foo/> ;
130 : object>string ( object -- string )
131 #! Should this be generic and in the core?
133 { [ dup real? ] [ number>string ] }
134 { [ dup timestamp? ] [ timestamp>string ] }
135 { [ dup url? ] [ url>string ] }
136 { [ dup string? ] [ ] }
137 { [ dup word? ] [ word-name ] }
138 { [ dup not ] [ drop "" ] }
141 : write-attr ( value name -- )
145 object>string escape-quoted-string write-html
148 : attribute-effect T{ effect f { "string" } 0 } ;
150 : define-attribute-word ( name -- )
152 [ write-attr ] curry attribute-effect html-word ;
154 ! Define some closed HTML tags
156 "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
157 "ol" "li" "form" "a" "p" "html" "head" "body" "title"
158 "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
159 "script" "div" "span" "select" "option" "style" "input"
160 ] [ define-closed-html-word ] each
162 ! Define some open HTML tags
168 ] [ define-open-html-word ] each
170 ! Define some attributes
172 "method" "action" "type" "value" "name"
173 "size" "href" "class" "border" "rows" "cols"
174 "id" "onclick" "style" "valign" "accesskey"
175 "src" "language" "colspan" "onchange" "rel"
176 "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
177 "media" "title" "multiple" "checked"
178 ] [ define-attribute-word ] each
182 : xhtml-preamble ( -- )
183 "<?xml version=\"1.0\"?>" write-html
184 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
186 : simple-page ( title quot -- )
187 #! Call the quotation, with all output going to the
188 #! body of an html page with the given title.
190 <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
191 <head> <title> swap write </title> </head>
195 : render-error ( message -- )
196 <span "error" =class span> escape-string write </span> ;