basis/html/streams/streams.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: combinators generic assocs help http io io.styles io.files
   5        continuations io.streams.string kernel math math.order math.parser
   6        namespaces quotations assocs sequences strings words html.elements
   7        xml.entities sbufs continuations destructors accessors arrays ;
   8
   9 IN: html.streams
  10
  11 GENERIC: browser-link-href ( presented -- href )
  12
  13 M: object browser-link-href drop f ;
  14
  15 TUPLE: html-stream stream last-div ;
  16
  17 ! stream-nl after with-nesting or tabular-output is
  18 ! ignored, so that HTML stream output looks like
  19 ! UI pane output
  20 : last-div? ( stream -- ? )
  21     [ f ] change-last-div drop ;
  22
  23 : not-a-div ( stream -- stream )
  24     f >>last-div ; inline
  25
  26 : a-div ( stream -- straem )
  27     t >>last-div ; inline
  28
  29 : <html-stream> ( stream -- stream )
  30     f html-stream boa ;
  31
  32 <PRIVATE
  33
  34 TUPLE: html-sub-stream < html-stream style parent ;
  35
  36 : new-html-sub-stream ( style stream class -- stream )
  37     new
  38         512 <sbuf> >>stream
  39         swap >>parent
  40         swap >>style ; inline
  41
  42 : end-sub-stream ( substream -- string style stream )
  43     [ stream>> >string ] [ style>> ] [ parent>> ] tri ;
  44
  45 : object-link-tag ( style quot -- )
  46     presented pick at [
  47         browser-link-href [
  48             <a =href a> call </a>
  49         ] [ call ] if*
  50     ] [ call ] if* ; inline
  51
  52 : hex-color, ( color -- )
  53     [ red>> ] [ green>> ] [ blue>> ] tri
  54     [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
  55
  56 : fg-css, ( color -- )
  57     "color: #" % hex-color, "; " % ;
  58
  59 : bg-css, ( color -- )
  60     "background-color: #" % hex-color, "; " % ;
  61
  62 : style-css, ( flag -- )
  63     dup
  64     { italic bold-italic } member?
  65     "font-style: " % "italic" "normal" ? % "; " %
  66     { bold bold-italic } member?
  67     "font-weight: " % "bold" "normal" ? % "; " % ;
  68
  69 : size-css, ( size -- )
  70     "font-size: " % # "pt; " % ;
  71
  72 : font-css, ( font -- )
  73     "font-family: " % % "; " % ;
  74
  75 : apply-style ( style key quot -- style gadget )
  76     >r over at r> when* ; inline
  77
  78 : make-css ( style quot -- str )
  79     "" make nip ; inline
  80
  81 : span-css-style ( style -- str )
  82     [
  83         foreground [ fg-css,    ] apply-style
  84         background [ bg-css,    ] apply-style
  85         font       [ font-css,  ] apply-style
  86         font-style [ style-css, ] apply-style
  87         font-size  [ size-css,  ] apply-style
  88     ] make-css ;
  89
  90 : span-tag ( style quot -- )
  91     over span-css-style [
  92         call
  93     ] [
  94         <span =style span> call </span>
  95     ] if-empty ; inline
  96
  97 : format-html-span ( string style stream -- )
  98     stream>> [
  99         [ [ drop write ] span-tag ] object-link-tag
 100     ] with-output-stream* ;
 101
 102 TUPLE: html-span-stream < html-sub-stream ;
 103
 104 M: html-span-stream dispose
 105     end-sub-stream not-a-div format-html-span ;
 106
 107 : border-css, ( border -- )
 108     "border: 1px solid #" % hex-color, "; " % ;
 109
 110 : padding-css, ( padding -- ) "padding: " % # "px; " % ;
 111
 112 : pre-css, ( margin -- )
 113     [ "white-space: pre; font-family: monospace; " % ] unless ;
 114
 115 : div-css-style ( style -- str )
 116     [
 117         page-color   [ bg-css,      ] apply-style
 118         border-color [ border-css,  ] apply-style
 119         border-width [ padding-css, ] apply-style
 120         wrap-margin over at pre-css,
 121     ] make-css ;
 122
 123 : div-tag ( style quot -- )
 124     swap div-css-style [
 125         call
 126     ] [
 127         <div =style div> call </div>
 128     ] if-empty ; inline
 129
 130 : format-html-div ( string style stream -- )
 131     stream>> [
 132         [ [ write ] div-tag ] object-link-tag
 133     ] with-output-stream* ;
 134
 135 TUPLE: html-block-stream < html-sub-stream ;
 136
 137 M: html-block-stream dispose ( quot style stream -- )
 138     end-sub-stream a-div format-html-div ;
 139
 140 : border-spacing-css, ( pair -- )
 141     "padding: " % first2 max 2 /i # "px; " % ;
 142
 143 : table-style ( style -- str )
 144     [
 145         table-border [ border-css,         ] apply-style
 146         table-gap    [ border-spacing-css, ] apply-style
 147     ] make-css ;
 148
 149 : table-attrs ( style -- )
 150     table-style " border-collapse: collapse;" append =style ;
 151
 152 : do-escaping ( string style -- string )
 153     html swap at [ escape-string ] unless ;
 154
 155 PRIVATE>
 156
 157 ! Stream protocol
 158 M: html-stream stream-flush
 159     stream>> stream-flush ;
 160
 161 M: html-stream stream-write1
 162     >r 1string r> stream-write ;
 163
 164 M: html-stream stream-write
 165     not-a-div >r escape-string r> stream>> stream-write ;
 166
 167 M: html-stream stream-format
 168     >r html over at [ >r escape-string r> ] unless r>
 169     format-html-span ;
 170
 171 M: html-stream stream-nl
 172     dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
 173
 174 M: html-stream make-span-stream
 175     html-span-stream new-html-sub-stream ;
 176
 177 M: html-stream make-block-stream
 178     html-block-stream new-html-sub-stream ;
 179
 180 M: html-stream make-cell-stream
 181     html-sub-stream new-html-sub-stream ;
 182
 183 M: html-stream stream-write-table
 184     a-div stream>> [
 185         <table dup table-attrs table> swap [
 186             <tr> [
 187                 <td "top" =valign swap table-style =style td>
 188                     stream>> >string write
 189                 </td>
 190             ] with each </tr>
 191         ] with each </table>
 192     ] with-output-stream* ;
 193
 194 M: html-stream dispose stream>> dispose ;
 195
 196 : with-html-stream ( quot -- )
 197     output-stream get <html-stream> swap with-output-stream* ; inline