: present-text ( str obj -- )
presented associate styled-text ;
-: check-recursion ( obj quot -- )
+: check-recursion ( obj quot: ( obj -- ) -- )
nesting-limit? [
drop
- [ class-of name>> "~" dup surround ] keep present-text
+ [ class-of name>> "~" dup surround ] keep present-text
] [
over recursion-check get member-eq? [
drop "~circularity~" swap present-text
M: section section-fits? ( section -- ? )
[ end>> 1 - pprinter get last-newline>> - ]
- [ overhang>> ] bi
- + text-fits? ;
+ [ overhang>> ] bi + text-fits? ;
M: section indent-section? drop f ;
TUPLE: line-break < section type ;
: <line-break> ( type -- section )
- 0 \ line-break new-section
+ 0 line-break new-section
swap >>type ;
M: line-break short-section drop ;
: empty-block? ( block -- ? ) sections>> empty? ;
-: if-nonempty ( block quot -- )
+: unless-empty-block ( block quot: ( block -- ) -- )
[ dup empty-block? [ drop ] ] dip if ; inline
: (<block) ( block -- ) pprinter-stack get push ;
position get >>end drop ;
: block> ( -- )
- pprinter-stack get pop
- [ [ save-end-position ] [ add-section ] bi ] if-nonempty ;
+ pprinter-stack get pop [
+ [ save-end-position ] [ add-section ] bi
+ ] unless-empty-block ;
: do-pprint ( block -- )
<pprinter> pprinter [
short-section
] curry with-return
] with-nesting
- ] if-nonempty
+ ] unless-empty-block
] with-variable ;
! Long section layout algorithm
] if
] each
] each
- ] if-nonempty ;
+ ] unless-empty-block ;
: pprinter-manifest ( -- manifest )
<manifest>
- [ [ pprinter-use get members >vector ] dip search-vocabs<< ]
- [ [ pprinter-in get ] dip current-vocab<< ]
- [ ]
- tri ;
+ pprinter-use get members V{ } like >>search-vocabs
+ pprinter-in get >>current-vocab ;
: make-pprint ( obj quot manifest? -- block manifest/f )
[
- 0 position ,,
- HS{ } clone pprinter-use ,,
- V{ } clone recursion-check ,,
- V{ } clone pprinter-stack ,,
- ] H{ } make [
+ 0 position set
+ HS{ } clone pprinter-use set
+ V{ } clone recursion-check set
+ V{ } clone pprinter-stack set
+
[ over <object call pprinter-block ] dip
[ pprinter-manifest ] [ f ] if
- ] with-variables ; inline
+ ] with-scope ; inline
: with-pprint ( obj quot -- )
f make-pprint drop do-pprint ; inline