1 ! Copyright (C) 2003, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs byte-arrays byte-vectors classes
4 classes.algebra.private classes.maybe classes.private
5 classes.tuple combinators continuations effects fry generic
6 hash-sets hashtables io.pathnames io.styles kernel lists make
7 math math.order math.parser namespaces prettyprint.config
8 prettyprint.custom prettyprint.sections prettyprint.stylesheet
9 quotations sbufs sequences strings vectors words ;
11 IN: prettyprint.backend
13 M: effect pprint* effect>string text ;
15 : ?effect-height ( word -- n )
16 stack-effect [ effect-height ] [ 0 ] if* ;
18 : ?start-group ( word -- )
19 ?effect-height 0 > [ start-group ] when ;
21 : ?end-group ( word -- )
22 ?effect-height 0 < [ end-group ] when ;
25 GENERIC: word-name* ( obj -- str )
28 class-name "maybe{ " " }" surround ;
30 M: anonymous-complement word-name*
31 class-name "not{ " " }" surround ;
33 M: anonymous-union word-name*
34 class-name "union{ " " }" surround ;
36 M: anonymous-intersection word-name*
37 class-name "intersection{ " " }" surround ;
40 [ name>> "( no name )" or ] [ record-vocab ] bi ;
42 : pprint-word ( word -- )
43 [ word-name* ] [ word-style ] bi styled-text ;
45 GENERIC: pprint-class ( obj -- )
47 M: classoid pprint-class pprint* ;
49 M: class pprint-class \ f or pprint-word ;
51 M: word pprint-class pprint-word ;
53 : pprint-prefix ( word quot -- )
54 <block swap pprint-word call block> ; inline
56 M: parsing-word pprint*
57 \ POSTPONE: [ pprint-word ] pprint-prefix ;
60 [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
64 [ \ M\ pprint-word "method-class" word-prop pprint* ]
65 [ "method-generic" word-prop pprint-word ] bi
68 : pprint-prefixed-number ( n quot: ( n -- n' ) pre -- )
70 [ [ neg ] [ call ] [ prepend ] tri* "-" prepend text ]
71 [ [ call ] [ prepend ] bi* text ] if ; inline
73 ERROR: unsupported-number-base n base ;
77 { 10 [ number>string text ] }
78 { 16 [ [ >hex ] "0x" pprint-prefixed-number ] }
79 { 8 [ [ >oct ] "0o" pprint-prefixed-number ] }
80 { 2 [ [ >bin ] "0b" pprint-prefixed-number ] }
81 [ unsupported-number-base ]
86 \ NAN: [ fp-nan-payload >hex text ] pprint-prefix
91 M: f pprint* drop \ f pprint-word ;
93 : pprint-effect ( effect -- )
94 [ effect>string ] [ effect-style ] bi styled-text ;
97 : ch>ascii-escape ( ch -- ch' ? )
108 { CHAR: \\ CHAR: \\ }
109 { CHAR: \" CHAR: \" }
112 : unparse-ch ( ch -- )
113 ch>ascii-escape [ CHAR: \\ , , ] [
114 dup 32 < [ dup 16 < "\\x0" "\\x" ? % >hex % ] [ , ] if
117 : do-string-limit ( str -- trimmed )
119 dup length margin get > [
120 margin get 3 - head "..." append
124 : unparse-string ( str prefix suffix -- str )
125 [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
127 : pprint-string ( obj str prefix suffix -- )
128 unparse-string swap string-style styled-text ;
131 dup "\"" "\"" pprint-string ;
134 dup "SBUF\" " "\"" pprint-string ;
137 dup string>> "P\" " "\"" pprint-string ;
140 : nesting-limit? ( -- ? )
141 nesting-limit get dup [ pprinter-stack get length < ] when ;
143 : present-text ( str obj -- )
144 presented associate styled-text ;
146 : check-recursion ( obj quot: ( obj -- ) -- )
149 [ class-of name>> "~" dup surround ] keep present-text
151 over recursion-check get member-eq? [
152 drop "~circularity~" swap present-text
154 over recursion-check get push
156 recursion-check get pop*
160 : filter-tuple-assoc ( slot,value -- name,value )
161 [ [ initial>> ] dip = ] assoc-reject
162 [ [ name>> ] dip ] assoc-map ;
164 : tuple>assoc ( tuple -- assoc )
165 [ class-of all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
167 : pprint-slot-value ( name value -- )
168 <flow \ { pprint-word
169 [ text ] [ f <inset pprint* block> ] bi*
170 \ } pprint-word block> ;
172 : (pprint-tuple) ( opener class slots closer -- )
176 [ t <inset [ pprint-slot-value ] assoc-each block> ]
180 : ?pprint-tuple ( tuple quot -- )
181 [ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
183 : pprint-tuple ( tuple -- )
184 [ [ \ T{ ] dip [ class-of ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
189 : recover-pprint ( try recovery -- )
190 pprinter-stack get clone
191 [ pprinter-stack set ] curry prepose recover ; inline
193 : pprint-c-object ( object content-quot pointer-quot -- )
194 [ c-object-pointers? get ] 2dip
196 [ [ drop ] prepose [ recover-pprint ] 2curry ] 2bi if ; inline
198 : do-length-limit ( seq -- trimmed n/f )
199 length-limit get dup [
200 1 - over length over [-]
201 dup 1 > [ [ head-slice ] dip ] [ 2drop f ] if
204 : pprint-elements ( seq -- )
206 [ [ pprint* ] each ] dip
207 [ number>string "~" " more~" surround text ] when* ;
209 M: quotation pprint-delims drop \ [ \ ] ;
210 M: curried pprint-delims drop \ [ \ ] ;
211 M: composed pprint-delims drop \ [ \ ] ;
212 M: array pprint-delims drop \ { \ } ;
213 M: byte-array pprint-delims drop \ B{ \ } ;
214 M: byte-vector pprint-delims drop \ BV{ \ } ;
215 M: vector pprint-delims drop \ V{ \ } ;
216 M: cons-state pprint-delims drop \ L{ \ } ;
217 M: +nil+ pprint-delims drop \ L{ \ } ;
218 M: hashtable pprint-delims drop \ H{ \ } ;
219 M: tuple pprint-delims drop \ T{ \ } ;
220 M: wrapper pprint-delims drop \ W{ \ } ;
221 M: callstack pprint-delims drop \ CS{ \ } ;
222 M: hash-set pprint-delims drop \ HS{ \ } ;
223 M: anonymous-union pprint-delims drop \ union{ \ } ;
224 M: anonymous-intersection pprint-delims drop \ intersection{ \ } ;
225 M: anonymous-complement pprint-delims drop \ not{ \ } ;
226 M: maybe pprint-delims drop \ maybe{ \ } ;
228 M: object >pprint-sequence ;
229 M: vector >pprint-sequence ;
230 M: byte-vector >pprint-sequence ;
231 M: callable >pprint-sequence ;
232 M: hashtable >pprint-sequence >alist ;
233 M: wrapper >pprint-sequence wrapped>> 1array ;
234 M: callstack >pprint-sequence callstack>array ;
235 M: hash-set >pprint-sequence sets:members ;
236 M: anonymous-union >pprint-sequence members>> ;
237 M: anonymous-intersection >pprint-sequence participants>> ;
238 M: anonymous-complement >pprint-sequence class>> 1array ;
239 M: maybe >pprint-sequence class>> 1array ;
241 : class-slot-sequence ( class slots -- sequence )
242 [ 1array ] [ [ f 2array ] dip append ] if-empty ;
244 M: tuple >pprint-sequence
245 [ class-of ] [ tuple-slots ] bi class-slot-sequence ;
247 M: object pprint-narrow? drop f ;
248 M: byte-vector pprint-narrow? drop f ;
249 M: array pprint-narrow? drop t ;
250 M: vector pprint-narrow? drop t ;
251 M: hashtable pprint-narrow? drop t ;
252 M: tuple pprint-narrow? drop t ;
254 M: object pprint-object
259 dup pprint-narrow? <inset
260 >pprint-sequence pprint-elements
262 ] dip pprint-word block>
265 M: object pprint* pprint-object ;
266 M: vector pprint* pprint-object ;
267 M: byte-vector pprint* pprint-object ;
269 M: cons-state pprint*
274 dup pprint-narrow? <inset
278 '[ dup cons-state? _ length _ < and ]
279 [ uncons swap , ] while
283 nil? [ "~more~" text ] unless
288 ] dip pprint-word block>
292 <flow pprint-delims [ pprint-word ] bi@ block> ;
294 : with-extra-nesting-level ( quot -- )
295 nesting-limit [ dup [ 1 + ] [ f ] if* ] change
296 [ nesting-limit set ] curry finally ; inline
299 [ pprint-object ] with-extra-nesting-level ;
300 M: curried pprint* pprint-object ;
301 M: composed pprint* pprint-object ;
302 M: hash-set pprint* pprint-object ;
303 M: anonymous-union pprint* pprint-object ;
304 M: anonymous-intersection pprint* pprint-object ;
305 M: anonymous-complement pprint* pprint-object ;
306 M: maybe pprint* pprint-object ;
310 { [ dup wrapped>> method? ] [ wrapped>> pprint* ] }
311 { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }