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