basis/io/styles/styles.factor

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