extra/html/streams/streams.factor

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