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 stream-element-type stream>> stream-element-type ;
  52
  53 M: filter-writer dispose stream>> dispose ;
  54
  55 TUPLE: ignore-close-stream < filter-writer ;
  56
  57 M: ignore-close-stream dispose drop ;
  58
  59 C: <ignore-close-stream> ignore-close-stream
  60
  61 TUPLE: style-stream < filter-writer style ;
  62
  63 : do-nested-style ( style style-stream -- style stream )
  64     [ style>> swap assoc-union ] [ stream>> ] bi ; inline
  65
  66 C: <style-stream> style-stream
  67
  68 M: style-stream stream-format
  69     do-nested-style stream-format ;
  70
  71 M: style-stream stream-write
  72     [ style>> ] [ stream>> ] bi stream-format ;
  73
  74 M: style-stream stream-write1
  75     [ 1string ] dip stream-write ;
  76
  77 M: style-stream make-span-stream
  78     do-nested-style make-span-stream ;
  79
  80 M: style-stream make-block-stream
  81     [ do-nested-style make-block-stream ] [ style>> ] bi
  82     <style-stream> ;
  83
  84 M: style-stream make-cell-stream
  85     [ do-nested-style make-cell-stream ] [ style>> ] bi
  86     <style-stream> ;
  87
  88 M: style-stream stream-write-table
  89     [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
  90     stream-write-table ;
  91
  92 M: plain-writer stream-format
  93     nip stream-write ;
  94
  95 M: plain-writer make-span-stream
  96     swap <style-stream> <ignore-close-stream> ;
  97
  98 M: plain-writer make-block-stream
  99     nip <ignore-close-stream> ;
 100
 101 M: plain-writer stream-write-table
 102     [
 103         drop
 104         [ [ >string ] map ] map format-table
 105         [ nl ] [ write ] interleave
 106     ] with-output-stream* ;
 107
 108 M: plain-writer make-cell-stream 2drop <string-writer> ;
 109
 110 ! Font styles
 111 SYMBOL: plain
 112 SYMBOL: bold
 113 SYMBOL: italic
 114 SYMBOL: bold-italic
 115
 116 ! Character styles
 117 SYMBOL: foreground
 118 SYMBOL: background
 119 SYMBOL: font-name
 120 SYMBOL: font-size
 121 SYMBOL: font-style
 122
 123 ! Presentation
 124 SYMBOL: presented
 125
 126 ! Link
 127 SYMBOL: href
 128
 129 ! Image
 130 SYMBOL: image
 131
 132 ! Paragraph styles
 133 SYMBOL: page-color
 134 SYMBOL: border-color
 135 SYMBOL: inset
 136 SYMBOL: wrap-margin
 137
 138 ! Table styles
 139 SYMBOL: table-gap
 140 SYMBOL: table-border
 141
 142 CONSTANT: standard-table-style
 143     H{
 144         { table-gap { 5 5 } }
 145         { table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
 146     }
 147
 148 ! Input history
 149 TUPLE: input string ;
 150
 151 C: <input> input
 152
 153 M: input present string>> ;
 154
 155 M: input summary
 156     [
 157         "Input: " %
 158         string>> "\n" split1
 159         [ % ] [ "..." "" ? % ] bi*
 160     ] "" make ;
 161
 162 : write-object ( str obj -- ) presented associate format ;
 163
 164 : write-image ( image -- ) [ "" ] dip image associate format ;