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 ;
   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 -- straem )
  26     t >>last-div ; inline
  27
  28 : <html-stream> ( stream -- 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 =href a> call </a>
  48         ] [ call ] if*
  49     ] [ call ] if* ; inline
  50
  51 : hex-color, ( color -- )
  52     [ red>> ] [ green>> ] [ blue>> ] tri
  53     [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
  54
  55 : fg-css, ( color -- )
  56     "color: #" % hex-color, "; " % ;
  57
  58 : bg-css, ( color -- )
  59     "background-color: #" % hex-color, "; " % ;
  60
  61 : style-css, ( flag -- )
  62     dup
  63     { italic bold-italic } member?
  64     "font-style: " % "italic" "normal" ? % "; " %
  65     { bold bold-italic } member?
  66     "font-weight: " % "bold" "normal" ? % "; " % ;
  67
  68 : size-css, ( size -- )
  69     "font-size: " % # "pt; " % ;
  70
  71 : font-css, ( font -- )
  72     "font-family: " % % "; " % ;
  73
  74 : apply-style ( style key quot -- style gadget )
  75     >r over at r> when* ; inline
  76
  77 : make-css ( style quot -- str )
  78     "" make nip ; inline
  79
  80 : span-css-style ( style -- str )
  81     [
  82         foreground [ fg-css,    ] apply-style
  83         background [ bg-css,    ] apply-style
  84         font       [ font-css,  ] apply-style
  85         font-style [ style-css, ] apply-style
  86         font-size  [ size-css,  ] apply-style
  87     ] make-css ;
  88
  89 : span-tag ( style quot -- )
  90     over span-css-style [
  91         call
  92     ] [
  93         <span =style span> call </span>
  94     ] if-empty ; inline
  95
  96 : format-html-span ( string style stream -- )
  97     stream>> [
  98         [ [ drop write ] span-tag ] object-link-tag
  99     ] with-output-stream* ;
 100
 101 TUPLE: html-span-stream < html-sub-stream ;
 102
 103 M: html-span-stream dispose
 104     end-sub-stream not-a-div format-html-span ;
 105
 106 : border-css, ( border -- )
 107     "border: 1px solid #" % hex-color, "; " % ;
 108
 109 : padding-css, ( padding -- ) "padding: " % # "px; " % ;
 110
 111 : pre-css, ( margin -- )
 112     [ "white-space: pre; font-family: monospace; " % ] unless ;
 113
 114 : div-css-style ( style -- str )
 115     [
 116         page-color   [ bg-css,      ] apply-style
 117         border-color [ border-css,  ] apply-style
 118         border-width [ padding-css, ] apply-style
 119         wrap-margin over at pre-css,
 120     ] make-css ;
 121
 122 : div-tag ( style quot -- )
 123     swap div-css-style [
 124         call
 125     ] [
 126         <div =style div> call </div>
 127     ] if-empty ; inline
 128
 129 : format-html-div ( string style stream -- )
 130     stream>> [
 131         [ [ write ] div-tag ] object-link-tag
 132     ] with-output-stream* ;
 133
 134 TUPLE: html-block-stream < html-sub-stream ;
 135
 136 M: html-block-stream dispose ( quot style stream -- )
 137     end-sub-stream a-div format-html-div ;
 138
 139 : border-spacing-css, ( pair -- )
 140     "padding: " % first2 max 2 /i # "px; " % ;
 141
 142 : table-style ( style -- str )
 143     [
 144         table-border [ border-css,         ] apply-style
 145         table-gap    [ border-spacing-css, ] apply-style
 146     ] make-css ;
 147
 148 : table-attrs ( style -- )
 149     table-style " border-collapse: collapse;" append =style ;
 150
 151 : do-escaping ( string style -- string )
 152     html swap at [ escape-string ] unless ;
 153
 154 PRIVATE>
 155
 156 ! Stream protocol
 157 M: html-stream stream-flush
 158     stream>> stream-flush ;
 159
 160 M: html-stream stream-write1
 161     >r 1string r> stream-write ;
 162
 163 M: html-stream stream-write
 164     not-a-div >r escape-string r> stream>> stream-write ;
 165
 166 M: html-stream stream-format
 167     >r html over at [ >r escape-string r> ] unless r>
 168     format-html-span ;
 169
 170 M: html-stream stream-nl
 171     dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
 172
 173 M: html-stream make-span-stream
 174     html-span-stream new-html-sub-stream ;
 175
 176 M: html-stream make-block-stream
 177     html-block-stream new-html-sub-stream ;
 178
 179 M: html-stream make-cell-stream
 180     html-sub-stream new-html-sub-stream ;
 181
 182 M: html-stream stream-write-table
 183     a-div stream>> [
 184         <table dup table-attrs table> swap [
 185             <tr> [
 186                 <td "top" =valign swap table-style =style td>
 187                     stream>> >string write
 188                 </td>
 189             ] with each </tr>
 190         ] with each </table>
 191     ] with-output-stream* ;
 192
 193 M: html-stream dispose stream>> dispose ;
 194
 195 : with-html-stream ( quot -- )
 196     output-stream get <html-stream> swap with-output-stream* ; inline