basis/html/streams/streams.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators destructors html io
   4 io.styles kernel make math math.functions math.parser sequences
   5 strings xml.syntax ;
   6 IN: html.streams
   7
   8 GENERIC: url-of ( object -- url )
   9
  10 M: object url-of drop f ;
  11
  12 TUPLE: html-writer data ;
  13 INSTANCE: html-writer output-stream
  14
  15 <PRIVATE
  16
  17 : new-html-writer ( class -- html-writer )
  18     new V{ } clone >>data ; inline
  19
  20 TUPLE: html-sub-stream < html-writer style parent ;
  21
  22 : new-html-sub-stream ( style stream class -- stream )
  23     new-html-writer
  24         swap >>parent
  25         swap >>style ; inline
  26
  27 : end-sub-stream ( substream -- string style stream )
  28     [ data>> ] [ style>> ] [ parent>> ] tri ;
  29
  30 : object-link-tag ( xml style -- xml )
  31     presented of [ url-of [ simple-link ] when* ] when* ;
  32
  33 : href-link-tag ( xml style -- xml )
  34     href of [ simple-link ] when* ;
  35
  36 : hex-color, ( color -- )
  37     [ red>> ] [ green>> ] [ blue>> ] tri
  38     [ 255 * round >integer >hex 2 CHAR: 0 pad-head % ] tri@ ;
  39
  40 : fg-css, ( color -- )
  41     "color: #" % hex-color, "; " % ;
  42
  43 : bg-css, ( color -- )
  44     "background-color: #" % hex-color, "; " % ;
  45
  46 : style-css, ( flag -- )
  47     dup
  48     { italic bold-italic } member?
  49     "font-style: " % "italic" "normal" ? % "; " %
  50     { bold bold-italic } member?
  51     "font-weight: " % "bold" "normal" ? % "; " % ;
  52
  53 : size-css, ( size -- )
  54     "font-size: " % # "pt; " % ;
  55
  56 : font-css, ( font -- )
  57     "font-family: " % % "; " % ;
  58
  59 MACRO: make-css ( pairs -- str )
  60     [ '[ _ of [ _ execute ] when* ] ] { } assoc>map
  61     '[ [ _ cleave ] "" make ] ;
  62
  63 : span-css-style ( style -- str )
  64     {
  65         { foreground fg-css, }
  66         { background bg-css, }
  67         { font-name font-css, }
  68         { font-style style-css, }
  69         { font-size size-css, }
  70     } make-css ;
  71
  72 : span-tag ( xml style -- xml )
  73     span-css-style
  74     [ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
  75
  76 : emit-html ( stream quot -- )
  77     dip data>> push ; inline
  78
  79 : img-tag ( xml style -- xml )
  80     image-style of [ nip simple-image ] when* ;
  81
  82 : format-html-span ( string style stream -- )
  83     [
  84         {
  85             [ span-tag ]
  86             [ href-link-tag ]
  87             [ object-link-tag ]
  88             [ img-tag ]
  89         } cleave
  90     ] emit-html ;
  91
  92 TUPLE: html-span-stream < html-sub-stream ;
  93
  94 M: html-span-stream dispose
  95     end-sub-stream format-html-span ;
  96
  97 : border-css, ( border -- )
  98     "border: 1px solid #" % hex-color, "; " % ;
  99
 100 : (padding-css,) ( horizontal vertical -- )
 101     2dup = [
 102         drop "padding: " % # "px; " %
 103     ] [
 104         "padding: " % # "px " % # "px; " %
 105     ] if ;
 106
 107 : padding-css, ( padding -- )
 108     first2 (padding-css,) ;
 109
 110 : width-css, ( width -- )
 111     "width: " % # "px; " % ;
 112
 113 : div-css-style ( style -- str )
 114     [ span-css-style ]
 115     [
 116         {
 117             { page-color bg-css, }
 118             { border-color border-css, }
 119             { inset padding-css, }
 120             { wrap-margin width-css, }
 121         } make-css
 122     ] bi "display: inline-block; " 3append ;
 123
 124 : div-tag ( xml style -- xml' )
 125     div-css-style
 126     [ swap [XML <div style=<->><-></div> XML] ] unless-empty ;
 127
 128 : format-html-div ( string style stream -- )
 129     [ [ div-tag ] [ object-link-tag ] bi ] emit-html ;
 130
 131 TUPLE: html-block-stream < html-sub-stream ;
 132
 133 M: html-block-stream dispose
 134     end-sub-stream format-html-div ;
 135
 136 : border-spacing-css, ( pair -- )
 137     first2 [ 2 /i ] bi@ (padding-css,) ;
 138
 139 : table-style ( style -- str )
 140     {
 141         { table-border border-css, }
 142         { table-gap border-spacing-css, }
 143     } make-css ;
 144
 145 PRIVATE>
 146
 147 ! Stream protocol
 148 M: html-writer stream-flush drop ;
 149
 150 M: html-writer stream-write1
 151     [ 1string ] emit-html ;
 152
 153 M: html-writer stream-write
 154     [ ] emit-html ;
 155
 156 M: html-writer stream-format
 157     format-html-span ;
 158
 159 M: html-writer stream-nl
 160     [ [XML <br/> XML] ] emit-html ;
 161
 162 M: html-writer make-span-stream
 163     html-span-stream new-html-sub-stream ;
 164
 165 M: html-writer make-block-stream
 166     html-block-stream new-html-sub-stream ;
 167
 168 M: html-writer make-cell-stream
 169     html-sub-stream new-html-sub-stream ;
 170
 171 M: html-writer stream-write-table
 172     [
 173         table-style swap [
 174             [ data>> [XML <td valign="top" style=<->><-></td> XML] ] with map
 175             [XML <tr><-></tr> XML]
 176         ] with map
 177         [XML <table style="display: inline-table; border-collapse: collapse;"><-></table> XML]
 178     ] emit-html ;
 179
 180 M: html-writer dispose drop ;
 181
 182 : <html-writer> ( -- html-writer )
 183     html-writer new-html-writer ;
 184
 185 : with-html-writer ( quot -- xml )
 186     <html-writer> [ swap with-output-stream* ] keep data>> ; inline