1 ! Copyright (C) 2003, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays generic hashtables io kernel math assocs
4 namespaces make sequences strings io.styles vectors words
5 prettyprint.config splitting classes continuations
6 accessors sets vocabs.parser combinators vocabs ;
7 FROM: namespaces => set ;
8 IN: prettyprint.sections
12 SYMBOL: recursion-check
13 SYMBOL: pprinter-stack
15 ! We record vocabs of all words
19 TUPLE: pprinter last-newline line-count indent ;
21 : <pprinter> ( -- pprinter ) 0 1 0 pprinter boa ;
23 : (record-vocab) ( vocab -- )
24 dup pprinter-in get dup [ vocab-name ] when =
25 [ drop ] [ pprinter-use get conjoin ] if ;
27 : record-vocab ( word -- )
35 : line-limit? ( -- ? )
36 line-limit get dup [ pprinter get line-count>> <= ] when ;
38 : do-indent ( -- ) pprinter get indent>> CHAR: \s <string> write ;
41 dup pprinter get last-newline>> = [
44 pprinter get (>>last-newline)
46 "..." write pprinter get return
48 pprinter get [ 1 + ] change-line-count drop
52 : text-fits? ( len -- ? )
54 [ 2drop t ] [ [ pprinter get indent>> + ] dip <= ] if ;
56 ! break only if position margin 2 / >
63 GENERIC: section-fits? ( section -- ? )
65 GENERIC: short-section ( section -- )
67 GENERIC: long-section ( section -- )
69 GENERIC: indent-section? ( section -- ? )
71 GENERIC: unindent-first-line? ( section -- ? )
73 GENERIC: newline-after? ( section -- ? )
75 GENERIC: short-section? ( section -- ? )
80 start-group? end-group?
83 : new-section ( length class -- section )
86 swap position [ + ] change
90 M: section section-fits? ( section -- ? )
91 [ end>> pprinter get last-newline>> - ]
95 M: section indent-section? drop f ;
97 M: section unindent-first-line? drop f ;
99 M: section newline-after? drop f ;
101 M: object short-section? section-fits? ;
103 : indent+ ( section n -- )
104 swap indent-section? [
105 pprinter get [ + ] change-indent drop
108 : <indent ( section -- ) tab-size get indent+ ;
110 : indent> ( section -- ) tab-size get neg indent+ ;
112 : <fresh-line ( section -- )
115 : fresh-line> ( section -- )
116 dup newline-after? [ end>> fresh-line ] [ drop ] if ;
118 : <long-section ( section -- )
119 dup unindent-first-line?
120 [ dup <fresh-line <indent ] [ dup <indent <fresh-line ] if ;
122 : long-section> ( section -- )
123 dup indent> fresh-line> ;
125 : pprint-section ( section -- )
127 dup style>> [ short-section ] with-style
130 [ dup style>> [ long-section ] with-style ]
136 TUPLE: line-break < section type ;
138 : <line-break> ( type -- section )
139 0 \ line-break new-section
142 M: line-break short-section drop ;
144 M: line-break long-section drop ;
147 TUPLE: block < section sections ;
149 : new-block ( style class -- block )
151 V{ } clone >>sections
152 swap >>style ; inline
154 : <block> ( style -- block )
157 : pprinter-block ( -- block ) pprinter-stack get last ;
159 : add-section ( section -- )
160 pprinter-block sections>> push ;
162 : last-section ( -- section )
163 pprinter-block sections>>
164 [ line-break? not ] find-last nip ;
167 last-section t >>start-group? drop ;
170 last-section t >>end-group? drop ;
172 : advance ( section -- )
173 [ start>> pprinter get last-newline>> = not ]
174 [ short-section? ] bi
177 : line-break ( type -- ) [ <line-break> add-section ] when* ;
179 M: block section-fits? ( section -- ? )
180 line-limit? [ drop t ] [ call-next-method ] if ;
182 : pprint-sections ( block advancer -- )
184 sections>> [ line-break? not ] filter
185 unclip-slice pprint-section
187 [ [ pprint-section ] bi ] curry each ; inline
189 M: block short-section ( block -- )
190 [ advance ] pprint-sections ;
192 : do-break ( break -- )
195 [ end>> pprinter get last-newline>> - margin get 2/ > ] tri
196 or [ <fresh-line ] [ drop ] if ;
198 : empty-block? ( block -- ? ) sections>> empty? ;
200 : if-nonempty ( block quot -- )
201 [ dup empty-block? [ drop ] ] dip if ; inline
203 : (<block) ( block -- ) pprinter-stack get push ;
205 : <block ( -- ) f <block> (<block) ;
207 : <object ( obj -- ) presented associate <block> (<block) ;
210 TUPLE: text < section string ;
212 : <text> ( string style -- text )
213 over length 1 + \ text new-section
217 M: text short-section string>> write ;
219 M: text long-section short-section ;
221 : styled-text ( string style -- ) <text> add-section ;
223 : text ( string -- ) H{ } styled-text ;
226 TUPLE: inset < block narrow? ;
228 : <inset> ( narrow? -- block )
233 M: inset long-section
235 [ <fresh-line ] pprint-sections
240 M: inset indent-section? drop t ;
242 M: inset newline-after? drop t ;
244 : <inset ( narrow? -- ) <inset> (<block) ;
247 TUPLE: flow < block ;
249 : <flow> ( -- block )
250 H{ } flow new-block ;
252 M: flow short-section? ( section -- ? )
253 #! If we can make room for this entire block by inserting
254 #! a newline, do it; otherwise, don't bother, print it as
257 [ [ end>> ] [ start>> ] bi - text-fits? not ] bi
260 : <flow ( -- ) <flow> (<block) ;
262 ! Colon definition section
263 TUPLE: colon < block ;
265 : <colon> ( -- block )
266 H{ } colon new-block ;
268 M: colon long-section short-section ;
270 M: colon indent-section? drop t ;
272 M: colon unindent-first-line? drop t ;
274 : <colon ( -- ) <colon> (<block) ;
276 : save-end-position ( block -- )
277 position get >>end drop ;
280 pprinter-stack get pop
281 [ [ save-end-position ] [ add-section ] bi ] if-nonempty ;
283 : do-pprint ( block -- )
284 <pprinter> pprinter [
294 ! Long section layout algorithm
295 : chop-break ( seq -- seq )
296 dup last line-break? [ but-last-slice chop-break ] when ;
301 : split-groups ( ? -- ) [ t , ] when ;
303 : split-before ( section -- )
304 [ start-group?>> prev get [ end-group?>> ] [ t ] if* and ]
305 [ flow? prev get flow? not and ]
308 : split-after ( section -- )
309 [ end-group?>> ] [ f ] if* split-groups ;
311 : group-flow ( seq -- newseq )
314 2dup 1 - swap ?nth prev set
315 2dup 1 + swap ?nth next set
316 swap nth dup split-before dup , split-after
318 ] { } make { t } split harvest ;
320 : break-group? ( seq -- ? )
321 [ first section-fits? ] [ last section-fits? not ] bi and ;
323 : ?break-group ( seq -- )
324 dup break-group? [ first <fresh-line ] [ drop ] if ;
326 M: block long-section ( block -- )
328 sections>> chop-break group-flow [
333 [ advance ] [ pprint-section ] bi
339 : pprinter-manifest ( -- manifest )
341 [ [ pprinter-use get keys >vector ] dip (>>search-vocabs) ]
342 [ [ pprinter-in get ] dip (>>current-vocab) ]
346 : make-pprint ( obj quot -- block manifest )
349 H{ } clone pprinter-use set
350 V{ } clone recursion-check set
351 V{ } clone pprinter-stack set
356 ] with-scope ; inline
358 : with-pprint ( obj quot -- )
359 make-pprint drop do-pprint ; inline