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