1 ! Copyright (C) 2004, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators destructors fry html io
4 io.backend io.pathnames io.styles kernel macros make math
5 math.functions math.order math.parser namespaces sequences
6 strings words splitting xml xml.syntax ;
9 GENERIC: url-of ( object -- url )
11 M: object url-of drop f ;
13 TUPLE: html-writer data ;
14 INSTANCE: html-writer output-stream
18 : new-html-writer ( class -- html-writer )
19 new V{ } clone >>data ; inline
21 TUPLE: html-sub-stream < html-writer style parent ;
23 : new-html-sub-stream ( style stream class -- stream )
28 : end-sub-stream ( substream -- string style stream )
29 [ data>> ] [ style>> ] [ parent>> ] tri ;
31 : object-link-tag ( xml style -- xml )
32 presented of [ url-of [ simple-link ] when* ] when* ;
34 : href-link-tag ( xml style -- xml )
35 href of [ simple-link ] when* ;
37 : hex-color, ( color -- )
38 [ red>> ] [ green>> ] [ blue>> ] tri
39 [ 255 * round >integer >hex 2 CHAR: 0 pad-head % ] tri@ ;
41 : fg-css, ( color -- )
42 "color: #" % hex-color, "; " % ;
44 : bg-css, ( color -- )
45 "background-color: #" % hex-color, "; " % ;
47 : style-css, ( flag -- )
49 { italic bold-italic } member?
50 "font-style: " % "italic" "normal" ? % "; " %
51 { bold bold-italic } member?
52 "font-weight: " % "bold" "normal" ? % "; " % ;
54 : size-css, ( size -- )
55 "font-size: " % # "pt; " % ;
57 : font-css, ( font -- )
58 "font-family: " % % "; " % ;
60 MACRO: make-css ( pairs -- str )
61 [ '[ _ of [ _ execute ] when* ] ] { } assoc>map
62 '[ [ _ cleave ] "" make ] ;
64 : span-css-style ( style -- str )
66 { foreground fg-css, }
67 { background bg-css, }
68 { font-name font-css, }
69 { font-style style-css, }
70 { font-size size-css, }
73 : span-tag ( xml style -- xml )
75 [ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
77 : emit-html ( stream quot -- )
78 dip data>> push ; inline
80 : img-tag ( xml style -- xml )
81 image-style of [ nip simple-image ] when* ;
83 : format-html-span ( string style stream -- )
93 TUPLE: html-span-stream < html-sub-stream ;
95 M: html-span-stream dispose
96 end-sub-stream format-html-span ;
98 : border-css, ( border -- )
99 "border: 1px solid #" % hex-color, "; " % ;
101 : (padding-css,) ( horizontal vertical -- )
103 drop "padding: " % # "px; " %
105 "padding: " % # "px " % # "px; " %
108 : padding-css, ( padding -- )
109 first2 (padding-css,) ;
111 : width-css, ( width -- )
112 "width: " % # "px; " % ;
114 : div-css-style ( style -- str )
118 { page-color bg-css, }
119 { border-color border-css, }
120 { inset padding-css, }
121 { wrap-margin width-css, }
123 ] bi "display: inline-block; " 3append ;
125 : div-tag ( xml style -- xml' )
127 [ swap [XML <div style=<->><-></div> XML] ] unless-empty ;
129 : format-html-div ( string style stream -- )
130 [ [ div-tag ] [ object-link-tag ] bi ] emit-html ;
132 TUPLE: html-block-stream < html-sub-stream ;
134 M: html-block-stream dispose
135 end-sub-stream format-html-div ;
137 : border-spacing-css, ( pair -- )
138 first2 [ 2 /i ] bi@ (padding-css,) ;
140 : table-style ( style -- str )
142 { table-border border-css, }
143 { table-gap border-spacing-css, }
149 M: html-writer stream-flush drop ;
151 M: html-writer stream-write1
152 [ 1string ] emit-html ;
154 M: html-writer stream-write
157 M: html-writer stream-format
160 M: html-writer stream-nl
161 [ [XML <br/> XML] ] emit-html ;
163 M: html-writer make-span-stream
164 html-span-stream new-html-sub-stream ;
166 M: html-writer make-block-stream
167 html-block-stream new-html-sub-stream ;
169 M: html-writer make-cell-stream
170 html-sub-stream new-html-sub-stream ;
172 M: html-writer stream-write-table
175 [ data>> [XML <td valign="top" style=<->><-></td> XML] ] with map
176 [XML <tr><-></tr> XML]
178 [XML <table style="display: inline-table; border-collapse: collapse;"><-></table> XML]
181 M: html-writer dispose drop ;
183 : <html-writer> ( -- html-writer )
184 html-writer new-html-writer ;
186 : with-html-writer ( quot -- xml )
187 <html-writer> [ swap with-output-stream* ] keep data>> ; inline