182 lines
4.6 KiB
Factor
182 lines
4.6 KiB
Factor
! Copyright (C) 2004, 2009 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors kernel assocs io io.styles math math.order math.parser
|
|
sequences strings make words combinators macros xml.syntax html fry
|
|
destructors ;
|
|
IN: html.streams
|
|
|
|
GENERIC: url-of ( object -- url )
|
|
|
|
M: object url-of drop f ;
|
|
|
|
TUPLE: html-writer data last-div ;
|
|
|
|
<PRIVATE
|
|
|
|
! stream-nl after with-nesting or tabular-output is
|
|
! ignored, so that HTML stream output looks like
|
|
! UI pane output
|
|
: last-div? ( stream -- ? )
|
|
[ f ] change-last-div drop ;
|
|
|
|
: not-a-div ( stream -- stream )
|
|
f >>last-div ; inline
|
|
|
|
: a-div ( stream -- stream )
|
|
t >>last-div ; inline
|
|
|
|
: new-html-writer ( class -- html-writer )
|
|
new V{ } clone >>data ; inline
|
|
|
|
TUPLE: html-sub-stream < html-writer style parent ;
|
|
|
|
: new-html-sub-stream ( style stream class -- stream )
|
|
new-html-writer
|
|
swap >>parent
|
|
swap >>style ; inline
|
|
|
|
: end-sub-stream ( substream -- string style stream )
|
|
[ data>> ] [ style>> ] [ parent>> ] tri ;
|
|
|
|
: object-link-tag ( xml style -- xml )
|
|
presented swap at [ url-of [ simple-link ] when* ] when* ;
|
|
|
|
: href-link-tag ( xml style -- xml )
|
|
href swap at [ simple-link ] when* ;
|
|
|
|
: hex-color, ( color -- )
|
|
[ red>> ] [ green>> ] [ blue>> ] tri
|
|
[ 255 * >integer >hex 2 CHAR: 0 pad-head % ] tri@ ;
|
|
|
|
: fg-css, ( color -- )
|
|
"color: #" % hex-color, "; " % ;
|
|
|
|
: bg-css, ( color -- )
|
|
"background-color: #" % hex-color, "; " % ;
|
|
|
|
: style-css, ( flag -- )
|
|
dup
|
|
{ italic bold-italic } member?
|
|
"font-style: " % "italic" "normal" ? % "; " %
|
|
{ bold bold-italic } member?
|
|
"font-weight: " % "bold" "normal" ? % "; " % ;
|
|
|
|
: size-css, ( size -- )
|
|
"font-size: " % # "pt; " % ;
|
|
|
|
: font-css, ( font -- )
|
|
"font-family: " % % "; " % ;
|
|
|
|
MACRO: make-css ( pairs -- str )
|
|
[ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map
|
|
'[ [ _ cleave ] "" make ] ;
|
|
|
|
: span-css-style ( style -- str )
|
|
{
|
|
{ foreground fg-css, }
|
|
{ background bg-css, }
|
|
{ font-name font-css, }
|
|
{ font-style style-css, }
|
|
{ font-size size-css, }
|
|
} make-css ;
|
|
|
|
: span-tag ( xml style -- xml )
|
|
span-css-style
|
|
[ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
|
|
|
|
: emit-html ( quot stream -- )
|
|
dip data>> push ; inline
|
|
|
|
: format-html-span ( string style stream -- )
|
|
[ [ span-tag ] [ href-link-tag ] [ object-link-tag ] tri ]
|
|
emit-html ;
|
|
|
|
TUPLE: html-span-stream < html-sub-stream ;
|
|
|
|
M: html-span-stream dispose
|
|
end-sub-stream not-a-div format-html-span ;
|
|
|
|
: border-css, ( border -- )
|
|
"border: 1px solid #" % hex-color, "; " % ;
|
|
|
|
: padding-css, ( padding -- ) "padding: " % # "px; " % ;
|
|
|
|
CONSTANT: pre-css "white-space: pre; font-family: monospace;"
|
|
|
|
: div-css-style ( style -- str )
|
|
[
|
|
{
|
|
{ page-color bg-css, }
|
|
{ border-color border-css, }
|
|
{ border-width padding-css, }
|
|
} make-css
|
|
] [
|
|
wrap-margin swap at
|
|
[ pre-css append ] unless
|
|
] bi ;
|
|
|
|
: div-tag ( xml style -- xml' )
|
|
div-css-style
|
|
[ swap [XML <div style=<->><-></div> XML] ] unless-empty ;
|
|
|
|
: format-html-div ( string style stream -- )
|
|
[ [ div-tag ] [ object-link-tag ] bi ] emit-html ;
|
|
|
|
TUPLE: html-block-stream < html-sub-stream ;
|
|
|
|
M: html-block-stream dispose ( quot style stream -- )
|
|
end-sub-stream a-div format-html-div ;
|
|
|
|
: border-spacing-css, ( pair -- )
|
|
"padding: " % first2 max 2 /i # "px; " % ;
|
|
|
|
: table-style ( style -- str )
|
|
{
|
|
{ table-border border-css, }
|
|
{ table-gap border-spacing-css, }
|
|
} make-css
|
|
" border-collapse: collapse;" append ;
|
|
|
|
PRIVATE>
|
|
|
|
! Stream protocol
|
|
M: html-writer stream-flush drop ;
|
|
|
|
M: html-writer stream-write1
|
|
not-a-div [ 1string ] emit-html ;
|
|
|
|
M: html-writer stream-write
|
|
not-a-div [ ] emit-html ;
|
|
|
|
M: html-writer stream-format
|
|
format-html-span ;
|
|
|
|
M: html-writer stream-nl
|
|
dup last-div? [ drop ] [ [ [XML <br/> XML] ] emit-html ] if ;
|
|
|
|
M: html-writer make-span-stream
|
|
html-span-stream new-html-sub-stream ;
|
|
|
|
M: html-writer make-block-stream
|
|
html-block-stream new-html-sub-stream ;
|
|
|
|
M: html-writer make-cell-stream
|
|
html-sub-stream new-html-sub-stream ;
|
|
|
|
M: html-writer stream-write-table
|
|
a-div [
|
|
table-style swap [
|
|
[ data>> [XML <td valign="top" style=<->><-></td> XML] ] with map
|
|
[XML <tr><-></tr> XML]
|
|
] with map
|
|
[XML <table><-></table> XML]
|
|
] emit-html ;
|
|
|
|
M: html-writer dispose drop ;
|
|
|
|
: <html-writer> ( -- html-writer )
|
|
html-writer new-html-writer ;
|
|
|
|
: with-html-writer ( quot -- xml )
|
|
<html-writer> [ swap with-output-stream* ] keep data>> ; inline
|