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 assocs combinators destructors fry html io
   4 io.backend io.pathnames io.styles kernel macros make math
   5 math.order math.parser namespaces sequences strings words
   6 splitting xml xml.syntax ;
   7 IN: html.streams
   8
   9 GENERIC: url-of ( object -- url )
  10
  11 M: object url-of drop f ;
  12
  13 TUPLE: html-writer data ;
  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 swap at [ url-of [ simple-link ] when* ] when* ;
  32
  33 : href-link-tag ( xml style -- xml )
  34     href swap at [ simple-link ] when* ;
  35
  36 : hex-color, ( color -- )
  37     [ red>> ] [ green>> ] [ blue>> ] tri
  38     [ 255 * >integer >hex 2 CHAR: 0 pad-head % ] tri@ ;
  39
  40 : fg-css, ( color -- )
  41     "color: #" % hex-color, "; " % ;
  42
  43 : bg-css, ( color -- )
  44     "background-color: #" % hex-color, "; " % ;
  45
  46 : style-css, ( flag -- )
  47     dup
  48     { italic bold-italic } member?
  49     "font-style: " % "italic" "normal" ? % "; " %
  50     { bold bold-italic } member?
  51     "font-weight: " % "bold" "normal" ? % "; " % ;
  52
  53 : size-css, ( size -- )
  54     "font-size: " % # "pt; " % ;
  55
  56 : font-css, ( font -- )
  57     "font-family: " % % "; " % ;
  58
  59 MACRO: make-css ( pairs -- str )
  60     [ '[ _ swap at [ _ execute ] when* ] ] { } assoc>map
  61     '[ [ _ cleave ] "" make ] ;
  62
  63 : span-css-style ( style -- str )
  64     {
  65         { foreground fg-css, }
  66         { background bg-css, }
  67         { font-name font-css, }
  68         { font-style style-css, }
  69         { font-size size-css, }
  70     } make-css ;
  71
  72 : span-tag ( xml style -- xml )
  73     span-css-style
  74     [ swap [XML <span style=<->><-></span> XML] ] unless-empty ; inline
  75
  76 : emit-html ( quot stream -- )
  77     dip data>> push ; inline
  78
  79 : image-path ( path -- images-path )
  80     "vocab:definitions/icons/" ?head [ "/icons/" prepend ] when ;
  81
  82 : img-tag ( xml style -- xml )
  83     image swap at [ nip image-path simple-image ] when* ;
  84
  85 : format-html-span ( string style stream -- )
  86     [
  87         {
  88             [ span-tag ]
  89             [ href-link-tag ]
  90             [ object-link-tag ]
  91             [ img-tag ]
  92         } cleave
  93     ] emit-html ;
  94
  95 TUPLE: html-span-stream < html-sub-stream ;
  96
  97 M: html-span-stream dispose
  98     end-sub-stream format-html-span ;
  99
 100 : border-css, ( border -- )
 101     "border: 1px solid #" % hex-color, "; " % ;
 102
 103 : padding-css, ( padding -- )
 104     first2 "padding: " % # "px " % # "px; " % ;
 105
 106 CONSTANT: pre-css "white-space: pre; font-family: monospace;"
 107
 108 : div-css-style ( style -- str )
 109     [
 110         {
 111             { page-color bg-css, }
 112             { border-color border-css, }
 113             { inset padding-css, }
 114         } make-css
 115     ] [ wrap-margin swap at [ pre-css append ] unless ] bi
 116     " display: inline-block;" append ;
 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 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     [ 1string ] emit-html ;
 147
 148 M: html-writer stream-write
 149     [ ] emit-html ;
 150
 151 M: html-writer stream-format
 152     format-html-span ;
 153
 154 M: html-writer stream-nl
 155     [ [XML <br/> XML] ] emit-html ;
 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     [
 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 style="display: inline-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