basis/io/styles/styles.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: hashtables io io.streams.plain io.streams.string
   4 colors summary make accessors splitting math.order
   5 kernel namespaces assocs destructors strings sequences ;
   6 IN: io.styles
   7
   8 GENERIC: stream-format ( str style stream -- )
   9 GENERIC: make-span-stream ( style stream -- stream' )
  10 GENERIC: make-block-stream ( style stream -- stream' )
  11 GENERIC: make-cell-stream ( style stream -- stream' )
  12 GENERIC: stream-write-table ( table-cells style stream -- )
  13
  14 : format ( str style -- ) output-stream get stream-format ;
  15
  16 : tabular-output ( style quot -- )
  17     swap [ { } make ] dip output-stream get stream-write-table ; inline
  18
  19 : with-row ( quot -- )
  20     { } make , ; inline
  21
  22 : with-cell ( quot -- )
  23     H{ } output-stream get make-cell-stream
  24     [ swap with-output-stream ] keep , ; inline
  25
  26 : write-cell ( str -- )
  27     [ write ] with-cell ; inline
  28
  29 : with-style ( style quot -- )
  30     swap dup assoc-empty? [
  31         drop call
  32     ] [
  33         output-stream get make-span-stream swap with-output-stream
  34     ] if ; inline
  35
  36 : with-nesting ( style quot -- )
  37     [ output-stream get make-block-stream ] dip
  38     with-output-stream ; inline
  39
  40 TUPLE: filter-writer stream ;
  41
  42 M: filter-writer stream-format
  43     stream>> stream-format ;
  44
  45 M: filter-writer stream-write
  46     stream>> stream-write ;
  47
  48 M: filter-writer stream-write1
  49     stream>> stream-write1 ;
  50
  51 M: filter-writer make-span-stream
  52     stream>> make-span-stream ;
  53
  54 M: filter-writer make-block-stream
  55     stream>> make-block-stream ;
  56
  57 M: filter-writer make-cell-stream
  58     stream>> make-cell-stream ;
  59
  60 M: filter-writer stream-flush
  61     stream>> stream-flush ;
  62
  63 M: filter-writer stream-nl
  64     stream>> stream-nl ;
  65
  66 M: filter-writer stream-write-table
  67     stream>> stream-write-table ;
  68
  69 M: filter-writer dispose
  70     stream>> dispose ;
  71
  72 TUPLE: ignore-close-stream < filter-writer ;
  73
  74 M: ignore-close-stream dispose drop ;
  75
  76 C: <ignore-close-stream> ignore-close-stream
  77
  78 TUPLE: style-stream < filter-writer style ;
  79
  80 : do-nested-style ( style style-stream -- style stream )
  81     [ style>> swap assoc-union ] [ stream>> ] bi ; inline
  82
  83 C: <style-stream> style-stream
  84
  85 M: style-stream stream-format
  86     do-nested-style stream-format ;
  87
  88 M: style-stream stream-write
  89     [ style>> ] [ stream>> ] bi stream-format ;
  90
  91 M: style-stream stream-write1
  92     [ 1string ] dip stream-write ;
  93
  94 M: style-stream make-span-stream
  95     do-nested-style make-span-stream ;
  96
  97 M: style-stream make-block-stream
  98     [ do-nested-style make-block-stream ] [ style>> ] bi
  99     <style-stream> ;
 100
 101 M: style-stream make-cell-stream
 102     [ do-nested-style make-cell-stream ] [ style>> ] bi
 103     <style-stream> ;
 104
 105 M: style-stream stream-write-table
 106     [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
 107     stream-write-table ;
 108
 109 M: plain-writer stream-format
 110     nip stream-write ;
 111
 112 M: plain-writer make-span-stream
 113     swap <style-stream> <ignore-close-stream> ;
 114
 115 M: plain-writer make-block-stream
 116     nip <ignore-close-stream> ;
 117
 118 : format-column ( seq ? -- seq )
 119     [
 120         [ 0 [ length max ] reduce ] keep
 121         swap [ CHAR: \s pad-tail ] curry map
 122     ] unless ;
 123
 124 : map-last ( seq quot -- seq )
 125     [ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
 126
 127 : format-table ( table -- seq )
 128     flip [ format-column ] map-last
 129     flip [ " " join ] map ;
 130
 131 M: plain-writer stream-write-table
 132     [ drop format-table [ print ] each ] with-output-stream* ;
 133
 134 M: plain-writer make-cell-stream 2drop <string-writer> ;
 135
 136 ! Font styles
 137 SYMBOL: plain
 138 SYMBOL: bold
 139 SYMBOL: italic
 140 SYMBOL: bold-italic
 141
 142 ! Character styles
 143 SYMBOL: foreground
 144 SYMBOL: background
 145 SYMBOL: font
 146 SYMBOL: font-size
 147 SYMBOL: font-style
 148
 149 ! Presentation
 150 SYMBOL: presented
 151 SYMBOL: presented-path
 152 SYMBOL: presented-printer
 153
 154 SYMBOL: href
 155
 156 ! Paragraph styles
 157 SYMBOL: page-color
 158 SYMBOL: border-color
 159 SYMBOL: border-width
 160 SYMBOL: wrap-margin
 161
 162 ! Table styles
 163 SYMBOL: table-gap
 164 SYMBOL: table-border
 165
 166 : standard-table-style ( -- style )
 167     H{
 168         { table-gap { 5 5 } }
 169         { table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
 170     } ;
 171
 172 ! Input history
 173 TUPLE: input string ;
 174
 175 C: <input> input
 176
 177 M: input summary
 178     [
 179         "Input: " %
 180         string>> "\n" split1 swap %
 181         "..." "" ? %
 182     ] "" make ;
 183
 184 : write-object ( str obj -- ) presented associate format ;