basis/io/styles/styles.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs colors delegate delegate.protocols
   4 destructors hashtables io io.streams.plain io.streams.string
   5 kernel make namespaces present sequences sets splitting strings
   6 strings.tables summary ;
   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 INSTANCE: style-stream output-stream
  63
  64 <PRIVATE
  65
  66 : nested-style ( style style-stream -- style stream )
  67     [ style>> swap assoc-union ] [ stream>> ] bi ; inline
  68
  69 PRIVATE>
  70
  71 C: <style-stream> style-stream
  72
  73 M: style-stream stream-format
  74     nested-style stream-format ;
  75
  76 M: style-stream stream-write
  77     [ style>> ] [ stream>> ] bi stream-format ;
  78
  79 M: style-stream stream-write1
  80     [ 1string ] dip stream-write ;
  81
  82 M: style-stream make-span-stream
  83     nested-style make-span-stream ;
  84
  85 M: style-stream make-block-stream
  86     nested-style make-block-stream ;
  87
  88 M: style-stream make-cell-stream
  89     nested-style make-cell-stream ;
  90
  91 M: style-stream stream-write-table
  92     nested-style stream-write-table ;
  93
  94 M: plain-writer stream-format
  95     nip stream-write ;
  96
  97 M: plain-writer make-span-stream
  98     swap <style-stream> <ignore-close-stream> ;
  99
 100 M: plain-writer make-block-stream
 101     nip <ignore-close-stream> ;
 102
 103 M: plain-writer stream-write-table
 104     [
 105         drop
 106         [ [ >string ] map ] map format-table
 107         [ nl ] [ write ] interleave
 108     ] with-output-stream* ;
 109
 110 M: plain-writer make-cell-stream 2drop <string-writer> ;
 111
 112 ! Font styles
 113 SYMBOL: plain
 114 SYMBOL: bold
 115 SYMBOL: italic
 116 SYMBOL: bold-italic
 117 SYMBOL: faint
 118 SYMBOL: underline
 119 SYMBOL: blink
 120
 121 ! Character styles
 122 SYMBOL: foreground
 123 SYMBOL: background
 124 SYMBOL: font-name
 125 SYMBOL: font-size
 126 SYMBOL: font-style
 127
 128 ! Presentation
 129 SYMBOL: presented
 130
 131 ! Link
 132 SYMBOL: href
 133
 134 ! Image
 135 SYMBOL: image-style
 136
 137 ! Paragraph styles
 138 SYMBOL: page-color
 139 SYMBOL: border-color
 140 SYMBOL: inset
 141 SYMBOL: wrap-margin
 142
 143 ! Table styles
 144 SYMBOL: table-gap
 145 SYMBOL: table-border
 146
 147 CONSTANT: standard-table-style
 148     H{
 149         { table-gap { 5 5 } }
 150         { table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
 151     }
 152
 153 ! Input history
 154 TUPLE: input string ;
 155
 156 C: <input> input
 157
 158 M: input present string>> ;
 159
 160 M: input summary
 161     [
 162         "Input: " %
 163         string>> "\n" split1
 164         [ % ] [ "..." "" ? % ] bi*
 165     ] "" make ;
 166
 167 : write-object ( str obj -- ) presented associate format ;
 168
 169 : write-image ( image -- ) [ "" ] dip image-style associate format ;