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 ;
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 -- )
15 PROTOCOL: formatted-output-stream-protocol
16 stream-format make-span-stream make-block-stream
17 make-cell-stream stream-write-table ;
19 : format ( str style -- ) output-stream get stream-format ;
21 : tabular-output ( style quot -- )
22 swap [ { } make ] dip output-stream get stream-write-table ; inline
24 : with-row ( quot -- )
27 : with-cell ( quot -- )
28 H{ } output-stream get make-cell-stream
29 [ swap with-output-stream ] keep , ; inline
31 : write-cell ( str -- )
32 [ write ] with-cell ; inline
34 : with-style ( style quot -- )
35 swap dup assoc-empty? [
38 output-stream get make-span-stream swap with-output-stream
41 : with-nesting ( style quot -- )
42 [ output-stream get make-block-stream ] dip
43 with-output-stream ; inline
45 TUPLE: filter-writer stream ;
47 CONSULT: output-stream-protocol filter-writer stream>> ;
49 CONSULT: formatted-output-stream-protocol filter-writer stream>> ;
51 M: filter-writer dispose stream>> dispose ;
53 TUPLE: ignore-close-stream < filter-writer ;
55 M: ignore-close-stream dispose drop ;
57 C: <ignore-close-stream> ignore-close-stream
59 TUPLE: style-stream < filter-writer style ;
61 : do-nested-style ( style style-stream -- style stream )
62 [ style>> swap assoc-union ] [ stream>> ] bi ; inline
64 C: <style-stream> style-stream
66 M: style-stream stream-format
67 do-nested-style stream-format ;
69 M: style-stream stream-write
70 [ style>> ] [ stream>> ] bi stream-format ;
72 M: style-stream stream-write1
73 [ 1string ] dip stream-write ;
75 M: style-stream make-span-stream
76 do-nested-style make-span-stream ;
78 M: style-stream make-block-stream
79 [ do-nested-style make-block-stream ] [ style>> ] bi
82 M: style-stream make-cell-stream
83 [ do-nested-style make-cell-stream ] [ style>> ] bi
86 M: style-stream stream-write-table
87 [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
90 M: plain-writer stream-format
93 M: plain-writer make-span-stream
94 swap <style-stream> <ignore-close-stream> ;
96 M: plain-writer make-block-stream
97 nip <ignore-close-stream> ;
99 M: plain-writer stream-write-table
100 [ drop format-table [ print ] each ] with-output-stream* ;
102 M: plain-writer make-cell-stream 2drop <string-writer> ;
136 : standard-table-style ( -- style )
138 { table-gap { 5 5 } }
139 { table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
143 TUPLE: input string ;
147 M: input present string>> ;
153 [ % ] [ "..." "" ? % ] bi*
156 : write-object ( str obj -- ) presented associate format ;