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

prettyprint: speed up unparse by not making the manifest sometimes.

db4
John Benediktsson 2013-04-06 12:45:15 -07:00
parent 64111e1342
commit 85acdb2520
2 changed files with 20 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/prettyprint/prettyprint.factor
View File

@ -10,12 +10,12 @@ FROM: namespaces => set ;
IN: prettyprint IN: prettyprint
: with-use ( obj quot -- ) : with-use ( obj quot -- )
make-pprint (pprint-manifest t make-pprint (pprint-manifest
[ pprint-manifest) ] [ [ drop nl ] unless-empty ] bi [ pprint-manifest) ] [ [ drop nl ] unless-empty ] bi
do-pprint ; inline do-pprint ; inline
: with-in ( obj quot -- ) : with-in ( obj quot -- )
make-pprint current-vocab>> [ pprint-in bl ] when* do-pprint ; inline t make-pprint current-vocab>> [ pprint-in bl ] when* do-pprint ; inline
: pprint ( obj -- ) [ pprint* ] with-pprint ; : pprint ( obj -- ) [ pprint* ] with-pprint ;

35
basis/prettyprint/sections/sections.factor
View File

@ -4,7 +4,7 @@ USING: arrays generic hashtables io kernel math assocs
namespaces make sequences strings io.styles vectors words namespaces make sequences strings io.styles vectors words
prettyprint.config splitting classes continuations prettyprint.config splitting classes continuations
accessors sets vocabs.parser combinators vocabs accessors sets vocabs.parser combinators vocabs
classes.maybe ; classes.maybe combinators.short-circuit ;
FROM: sets => members ; FROM: sets => members ;
FROM: namespaces => set ; FROM: namespaces => set ;
IN: prettyprint.sections IN: prettyprint.sections
@ -180,9 +180,10 @@ TUPLE: block < section sections ;
last-section t >>end-group? drop ; last-section t >>end-group? drop ;
: advance ( section -- ) : advance ( section -- )
[ start>> pprinter get last-newline>> = not ] {
[ short-section? ] bi [ start>> pprinter get last-newline>> = not ]
and [ bl ] when ; [ short-section? ]
} 1&& [ bl ] when ;
: add-line-break ( type -- ) [ <line-break> add-section ] when* ; : add-line-break ( type -- ) [ <line-break> add-section ] when* ;
@ -263,9 +264,10 @@ M: flow short-section? ( section -- ? )
#! If we can make room for this entire block by inserting #! If we can make room for this entire block by inserting
#! a newline, do it; otherwise, don't bother, print it as #! a newline, do it; otherwise, don't bother, print it as
#! a short section #! a short section
[ section-fits? ] {
[ [ end>> ] [ start>> ] bi - text-fits? not ] bi [ section-fits? ]
or ; [ [ end>> ] [ start>> ] bi - text-fits? not ]
} 1|| ;
: <flow ( -- ) <flow> (<block) ; : <flow ( -- ) <flow> (<block) ;
@ -311,9 +313,10 @@ SYMBOL: next
: split-groups ( ? -- ) [ t , ] when ; : split-groups ( ? -- ) [ t , ] when ;
: split-before ( section -- ) : split-before ( section -- )
[ start-group?>> prev get [ end-group?>> ] [ t ] if* and ] {
[ flow? prev get flow? not and ] [ start-group?>> prev get [ end-group?>> ] [ t ] if* and ]
bi or split-groups ; [ flow? prev get flow? not and ]
} 1|| split-groups ;
: split-after ( section -- ) : split-after ( section -- )
[ end-group?>> ] [ f ] if* split-groups ; [ end-group?>> ] [ f ] if* split-groups ;
@ -328,7 +331,7 @@ SYMBOL: next
] { } make { t } split harvest ; ] { } make { t } split harvest ;
: break-group? ( seq -- ? ) : break-group? ( seq -- ? )
[ first section-fits? ] [ last section-fits? not ] bi and ; { [ first section-fits? ] [ last section-fits? not ] } 1&& ;
: ?break-group ( seq -- ) : ?break-group ( seq -- )
dup break-group? [ first <fresh-line ] [ drop ] if ; dup break-group? [ first <fresh-line ] [ drop ] if ;
@ -353,18 +356,16 @@ M: block long-section ( block -- )
[ ] [ ]
tri ; tri ;
: make-pprint ( obj quot -- block manifest ) : make-pprint ( obj quot manifest? -- block manifest/f )
[ [
0 position ,, 0 position ,,
HS{ } clone pprinter-use ,, HS{ } clone pprinter-use ,,
V{ } clone recursion-check ,, V{ } clone recursion-check ,,
V{ } clone pprinter-stack ,, V{ } clone pprinter-stack ,,
] H{ } make [ ] H{ } make [
over <object [ over <object call pprinter-block ] dip
call [ pprinter-manifest ] [ f ] if
pprinter-block
pprinter-manifest
] with-variables ; inline ] with-variables ; inline
: with-pprint ( obj quot -- ) : with-pprint ( obj quot -- )
make-pprint drop do-pprint ; inline f make-pprint drop do-pprint ; inline