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