1 ! Copyright (C) 2004, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel assocs io io.styles math math.order math.parser
4 sequences strings make words combinators macros xml.syntax html fry
8 GENERIC: url-of ( object -- url )
10 M: object url-of drop f ;
12 TUPLE: html-writer data last-div ;
16 ! stream-nl after with-nesting or tabular-output is
17 ! ignored, so that HTML stream output looks like
19 : last-div? ( stream -- ? )
20 [ f ] change-last-div drop ;
22 : not-a-div ( stream -- stream )
25 : a-div ( stream -- stream )
28 : new-html-writer ( class -- html-writer )
29 new V{ } clone >>data ; inline
31 TUPLE: html-sub-stream < html-writer style parent ;
33 : new-html-sub-stream ( style stream class -- stream )
38 : end-sub-stream ( substream -- string style stream )
39 [ data>> ] [ style>> ] [ parent>> ] tri ;
41 : object-link-tag ( xml style -- xml )
42 presented swap at [ url-of [ simple-link ] when* ] when* ;
44 : href-link-tag ( xml style -- xml )
45 href swap at [ simple-link ] when* ;
47 : hex-color, ( color -- )
48 [ red>> ] [ green>> ] [ blue>> ] tri
49 [ 255 * >integer >hex 2 CHAR: 0 pad-head % ] tri@ ;
51 : fg-css, ( color -- )
52 "color: #" % hex-color, "; " % ;
54 : bg-css, ( color -- )
55 "background-color: #" % hex-color, "; " % ;
57 : style-css, ( flag -- )
59 { italic bold-italic } member?
60 "font-style: " % "italic" "normal" ? % "; " %
61 { bold bold-italic } member?
62 "font-weight: " % "bold" "normal" ? % "; " % ;
64 : size-css, ( size -- )
65 "font-size: " % # "pt; " % ;
67 : font-css, ( font -- )
68 "font-family: " % % "; " % ;
70 MACRO: make-css ( pairs -- str )
71 [ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map
72 '[ [ _ cleave ] "" make ] ;
74 : span-css-style ( style -- str )
76 { foreground fg-css, }
77 { background bg-css, }
78 { font-name font-css, }
79 { font-style style-css, }
80 { font-size size-css, }
83 : span-tag ( xml style -- xml )
85 [ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
87 : emit-html ( quot stream -- )
88 dip data>> push ; inline
90 : format-html-span ( string style stream -- )
91 [ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ]
94 TUPLE: html-span-stream < html-sub-stream ;
96 M: html-span-stream dispose
97 end-sub-stream not-a-div format-html-span ;
99 : border-css, ( border -- )
100 "border: 1px solid #" % hex-color, "; " % ;
102 : padding-css, ( padding -- )
103 first2 "padding: " % # "px " % # "px; " % ;
105 CONSTANT: pre-css "white-space: pre; font-family: monospace;"
107 : div-css-style ( style -- str )
110 { page-color bg-css, }
111 { border-color border-css, }
112 { inset padding-css, }
116 [ pre-css append ] unless
119 : div-tag ( xml style -- xml' )
121 [ swap [XML <div style=<->><-></div> XML] ] unless-empty ;
123 : format-html-div ( string style stream -- )
124 [ [ div-tag ] [ object-link-tag ] bi ] emit-html ;
126 TUPLE: html-block-stream < html-sub-stream ;
128 M: html-block-stream dispose ( quot style stream -- )
129 end-sub-stream a-div format-html-div ;
131 : border-spacing-css, ( pair -- )
132 "padding: " % first2 max 2 /i # "px; " % ;
134 : table-style ( style -- str )
136 { table-border border-css, }
137 { table-gap border-spacing-css, }
139 " border-collapse: collapse;" append ;
144 M: html-writer stream-flush drop ;
146 M: html-writer stream-write1
147 not-a-div [ 1string ] emit-html ;
149 M: html-writer stream-write
150 not-a-div [ ] emit-html ;
152 M: html-writer stream-format
155 M: html-writer stream-nl
156 dup last-div? [ drop ] [ [ [XML <br/> XML] ] emit-html ] if ;
158 M: html-writer make-span-stream
159 html-span-stream new-html-sub-stream ;
161 M: html-writer make-block-stream
162 html-block-stream new-html-sub-stream ;
164 M: html-writer make-cell-stream
165 html-sub-stream new-html-sub-stream ;
167 M: html-writer stream-write-table
170 [ data>> [XML <td valign="top" style=<->><-></td> XML] ] with map
171 [XML <tr><-></tr> XML]
173 [XML <table><-></table> XML]
176 M: html-writer dispose drop ;
178 : <html-writer> ( -- html-writer )
179 html-writer new-html-writer ;
181 : with-html-writer ( quot -- xml )
182 <html-writer> [ swap with-output-stream* ] keep data>> ; inline