! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators destructors fry html io
io.backend io.pathnames io.styles kernel macros make math
-math.order math.parser namespaces sequences strings words
-splitting xml xml.syntax ;
+math.functions math.order math.parser namespaces sequences
+strings words splitting xml xml.syntax ;
IN: html.streams
GENERIC: url-of ( object -- url )
M: object url-of drop f ;
TUPLE: html-writer data ;
+INSTANCE: html-writer output-stream
<PRIVATE
[ data>> ] [ style>> ] [ parent>> ] tri ;
: object-link-tag ( xml style -- xml )
- presented swap at [ url-of [ simple-link ] when* ] when* ;
+ presented of [ url-of [ simple-link ] when* ] when* ;
: href-link-tag ( xml style -- xml )
- href swap at [ simple-link ] when* ;
+ href of [ simple-link ] when* ;
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
- [ 255 * >integer >hex 2 CHAR: 0 pad-head % ] tri@ ;
+ [ 255 * round >integer >hex 2 CHAR: 0 pad-head % ] tri@ ;
: fg-css, ( color -- )
"color: #" % hex-color, "; " % ;
"font-family: " % % "; " % ;
MACRO: make-css ( pairs -- str )
- [ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map
+ [ '[ _ of [ _ execute ] when* ] ] { } assoc>map
'[ [ _ cleave ] "" make ] ;
: span-css-style ( style -- str )
span-css-style
[ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
-: emit-html ( quot stream -- )
+: emit-html ( stream quot -- )
dip data>> push ; inline
-: image-path ( path -- images-path )
- "vocab:definitions/icons/" ?head [ "/icons/" prepend ] when ;
-
: img-tag ( xml style -- xml )
- image swap at [ nip image-path simple-image ] when* ;
+ image-style of [ nip simple-image ] when* ;
: format-html-span ( string style stream -- )
[
: border-css, ( border -- )
"border: 1px solid #" % hex-color, "; " % ;
+: (padding-css,) ( horizontal vertical -- )
+ 2dup = [
+ drop "padding: " % # "px; " %
+ ] [
+ "padding: " % # "px " % # "px; " %
+ ] if ;
+
: padding-css, ( padding -- )
- first2 "padding: " % # "px " % # "px; " % ;
+ first2 (padding-css,) ;
-CONSTANT: pre-css "white-space: pre; font-family: monospace;"
+: width-css, ( width -- )
+ "width: " % # "px; " % ;
: div-css-style ( style -- str )
+ [ span-css-style ]
[
{
{ page-color bg-css, }
{ border-color border-css, }
{ inset padding-css, }
+ { wrap-margin width-css, }
} make-css
- ] [ wrap-margin swap at [ pre-css append ] unless ] bi
- " display: inline-block;" append ;
+ ] bi "display: inline-block; " 3append ;
: div-tag ( xml style -- xml' )
div-css-style
TUPLE: html-block-stream < html-sub-stream ;
-M: html-block-stream dispose ( quot style stream -- )
+M: html-block-stream dispose
end-sub-stream format-html-div ;
: border-spacing-css, ( pair -- )
- "padding: " % first2 max 2 /i # "px; " % ;
+ first2 [ 2 /i ] bi@ (padding-css,) ;
: table-style ( style -- str )
{
{ table-border border-css, }
{ table-gap border-spacing-css, }
- } make-css
- " border-collapse: collapse;" append ;
+ } make-css ;
PRIVATE>
[ data>> [XML <td valign="top" style=<->><-></td> XML] ] with map
[XML <tr><-></tr> XML]
] with map
- [XML <table style="display: inline-table;"><-></table> XML]
+ [XML <table style="display: inline-table; border-collapse: collapse;"><-></table> XML]
] emit-html ;
M: html-writer dispose drop ;