steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Remove usages of delegation from core io

db4
Slava Pestov 2008-04-04 06:21:50 -05:00
parent 6b626f108c
commit 5cc78f5b39
5 changed files with 86 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/io/streams/duplex/duplex-docs.factor
View File

@ -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: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }

67
core/io/streams/nested/nested.factor
View File

@ -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> 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-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> 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> 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 <style-stream> ;
[ do-nested-style make-block-stream ] [ style>> ] bi
<style-stream> ;
M: style-stream make-cell-stream
[ do-nested-style make-cell-stream ] keep
style-stream-style swap <style-stream> ;
TUPLE: block-stream ;
: <block-stream> block-stream construct-delegate ;
M: block-stream dispose drop ;
[ do-nested-style make-cell-stream ] [ style>> ] bi
<style-stream> ;

2
core/io/streams/plain/plain.factor
View File

@ -12,7 +12,7 @@ M: plain-writer stream-format
nip stream-write ;
M: plain-writer make-span-stream
<style-stream> <ignore-close-stream> ;
swap <style-stream> ;
M: plain-writer make-block-stream
nip <ignore-close-stream> ;

2
core/prettyprint/sections/sections-docs.factor
View File

@ -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: <section>
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 } "." } ;

80
core/prettyprint/sections/sections.factor
View File

@ -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> ( -- 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 <string> write ;
: do-indent ( -- ) pprinter get indent>> CHAR: \s <string> 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 ;
: <indent ( section -- ) tab-size get change-indent ;
: <indent ( section -- ) tab-size get indent+ ;
: indent> ( section -- ) tab-size get neg change-indent ;
: indent> ( section -- ) tab-size get neg indent+ ;
: <fresh-line ( section -- )
start>> 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 [ <style-stream> ] 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 <long-section
dup section-style [ dup long-section ] with-style*
long-section>
[ <long-section ]
[ dup section-style [ long-section ] with-style ]
[ long-section> ]
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
[ <fresh-line ] [ drop ] if ;
[ ]
[ type>> hard eq? ]
[ end>> pprinter get last-newline>> - margin get 2/ > ] tri
or [ <fresh-line ] [ drop ] if ;
: empty-block? ( block -- ? ) sections>> 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> 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 )