basis/html/streams/streams.factor

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