basis/html/streams/streams.factor

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