diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor index fa82c54163..6a956c6694 100755 --- a/core/io/streams/duplex/duplex-docs.factor +++ b/core/io/streams/duplex/duplex-docs.factor @@ -10,7 +10,7 @@ ARTICLE: "io.streams.duplex" "Duplex streams" ABOUT: "io.streams.duplex" HELP: duplex-stream -{ $class-description "A bidirectional stream delegating to a pair of streams, sending input to one delegate and output to another." } ; +{ $class-description "A bidirectional stream wrapping an input and output stream." } ; HELP: { $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } } diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor index e32c90a2fc..6a8a09fbdb 100755 --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -1,30 +1,57 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: io.streams.nested USING: arrays generic assocs kernel namespaces strings -quotations io continuations ; +quotations io continuations accessors ; +IN: io.streams.nested -TUPLE: ignore-close-stream ; +TUPLE: filter-writer stream ; -: ignore-close-stream construct-delegate ; +M: filter-writer stream-format + stream>> stream-format ; -M: ignore-close-stream dispose drop ; +M: filter-writer stream-write + stream>> stream-write ; -TUPLE: style-stream style ; +M: filter-writer stream-write1 + stream>> stream-write1 ; -: do-nested-style ( style stream -- style delegate ) - [ style-stream-style swap union ] keep - delegate ; inline +M: filter-writer make-span-stream + stream>> make-span-stream ; -: ( style delegate -- stream ) - { set-style-stream-style set-delegate } - style-stream construct ; +M: filter-writer make-block-stream + stream>> make-block-stream ; + +M: filter-writer make-cell-stream + stream>> make-cell-stream ; + +M: filter-writer stream-flush + stream>> stream-flush ; + +M: filter-writer stream-nl + stream>> stream-nl ; + +M: filter-writer stream-write-table + stream>> stream-write-table ; + +M: filter-writer dispose + drop ; + +TUPLE: ignore-close-stream < filter-writer ; + +C: ignore-close-stream + +TUPLE: style-stream < filter-writer style ; + +: do-nested-style ( style style-stream -- style stream ) + [ style>> swap union ] [ stream>> ] bi ; inline + +C: style-stream M: style-stream stream-format do-nested-style stream-format ; M: style-stream stream-write - dup style-stream-style swap delegate stream-format ; + [ style>> ] [ stream>> ] bi stream-format ; M: style-stream stream-write1 >r 1string r> stream-write ; @@ -33,15 +60,9 @@ M: style-stream make-span-stream do-nested-style make-span-stream ; M: style-stream make-block-stream - [ do-nested-style make-block-stream ] keep - style-stream-style swap ; + [ do-nested-style make-block-stream ] [ style>> ] bi + ; M: style-stream make-cell-stream - [ do-nested-style make-cell-stream ] keep - style-stream-style swap ; - -TUPLE: block-stream ; - -: block-stream construct-delegate ; - -M: block-stream dispose drop ; + [ do-nested-style make-cell-stream ] [ style>> ] bi + ; diff --git a/core/io/streams/plain/plain.factor b/core/io/streams/plain/plain.factor index 4898a58fb1..8d8a0a8810 100644 --- a/core/io/streams/plain/plain.factor +++ b/core/io/streams/plain/plain.factor @@ -12,7 +12,7 @@ M: plain-writer stream-format nip stream-write ; M: plain-writer make-span-stream - ; + swap ; M: plain-writer make-block-stream nip ; diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor index e704df2085..3a86c014af 100755 --- a/core/prettyprint/sections/sections-docs.factor +++ b/core/prettyprint/sections/sections-docs.factor @@ -86,7 +86,7 @@ HELP: section { { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" } } } ; -HELP:
+HELP: construct-section { $values { "style" hashtable } { "length" integer } { "section" section } } { $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ; diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index c5b26ca837..848947e624 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -11,37 +11,38 @@ SYMBOL: position SYMBOL: recursion-check SYMBOL: pprinter-stack -SYMBOL: last-newline -SYMBOL: line-count -SYMBOL: end-printing -SYMBOL: indent - ! We record vocabs of all words SYMBOL: pprinter-in SYMBOL: pprinter-use +TUPLE: pprinter last-newline line-count end-printing indent ; + +: ( -- pprinter ) 0 1 f 0 pprinter construct-boa ; + : record-vocab ( word -- ) word-vocabulary [ dup pprinter-use get set-at ] when* ; ! Utility words : line-limit? ( -- ? ) - line-limit get dup [ line-count get <= ] when ; + line-limit get dup [ pprinter get line-count>> <= ] when ; -: do-indent ( -- ) indent get CHAR: \s write ; +: do-indent ( -- ) pprinter get indent>> CHAR: \s write ; : fresh-line ( n -- ) - dup last-newline get = [ + dup pprinter get last-newline>> = [ drop ] [ - last-newline set - line-limit? [ "..." write end-printing get continue ] when - line-count inc + pprinter get (>>last-newline) + line-limit? [ + "..." write pprinter get end-printing>> continue + ] when + pprinter get [ 1+ ] change-line-count drop nl do-indent ] if ; : text-fits? ( len -- ? ) margin get dup zero? - [ 2drop t ] [ >r indent get + r> <= ] if ; + [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ; ! break only if position margin 2 / > SYMBOL: soft @@ -78,7 +79,9 @@ style overhang ; 0 >>overhang ; inline M: section section-fits? ( section -- ? ) - [ end>> last-newline get - ] [ overhang>> ] bi + text-fits? ; + [ end>> pprinter get last-newline>> - ] + [ overhang>> ] bi + + text-fits? ; M: section indent-section? drop f ; @@ -88,12 +91,14 @@ M: section newline-after? drop f ; M: object short-section? section-fits? ; -: change-indent ( section n -- ) - swap indent-section? [ indent +@ ] [ drop ] if ; +: indent+ ( section n -- ) + swap indent-section? [ + pprinter get [ + ] change-indent drop + ] [ drop ] if ; -: ( section -- ) tab-size get neg change-indent ; +: indent> ( section -- ) tab-size get neg indent+ ; : > fresh-line ; @@ -108,17 +113,14 @@ M: object short-section? section-fits? ; : long-section> ( section -- ) dup indent> fresh-line> ; -: with-style* ( style quot -- ) - swap stdio [ ] change - call stdio [ delegate ] change ; inline - : pprint-section ( section -- ) dup short-section? [ - dup section-style [ short-section ] with-style* + dup section-style [ short-section ] with-style ] [ - dup + [ ] + tri ] if ; ! Break section @@ -159,7 +161,7 @@ TUPLE: block < section sections ; last-section t >>end-group? drop ; : advance ( section -- ) - [ start>> last-newline get = not ] + [ start>> pprinter get last-newline>> = not ] [ short-section? ] bi and [ bl ] when ; @@ -178,9 +180,10 @@ M: block short-section ( block -- ) [ advance ] pprint-sections ; : do-break ( break -- ) - dup type>> hard eq? - over section-end last-newline get - margin get 2/ > or - [ > hard eq? ] + [ end>> pprinter get last-newline>> - margin get 2/ > ] tri + or [ > empty? ; @@ -267,22 +270,17 @@ M: colon unindent-first-line? drop t ; pprinter-stack get pop [ [ save-end-position ] [ add-section ] bi ] if-nonempty ; -: with-section-state ( quot -- ) - [ - 0 indent set - 0 last-newline set - 1 line-count set - call - ] with-scope ; inline - : do-pprint ( block -- ) - [ + pprinter [ [ dup style>> [ - [ end-printing set dup short-section ] callcc0 - ] with-nesting drop + [ + >r pprinter get (>>end-printing) r> + short-section + ] curry callcc0 + ] with-nesting ] if-nonempty - ] with-section-state ; + ] with-variable ; ! Long section layout algorithm : chop-break ( seq -- seq )