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.tuple classes.tuple.private colors colors.constants
5 combinators continuations effects generic hashtables io
6 io.pathnames io.styles kernel make math math.order math.parser
7 namespaces prettyprint.config prettyprint.custom
8 prettyprint.sections prettyprint.stylesheet quotations sbufs
9 sequences strings vectors words words.symbol hash-sets ;
10 FROM: sets => members ;
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 : word-name* ( word -- str )
26 name>> "( no name )" or ;
28 : pprint-word ( word -- )
30 [ [ word-name* ] [ word-style ] bi styled-text ] bi ;
32 : pprint-prefix ( word quot -- )
33 <block swap pprint-word call block> ; inline
35 M: parsing-word pprint*
36 \ POSTPONE: [ pprint-word ] pprint-prefix ;
39 [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
44 [ "M\\ " % "method-class" word-prop word-name* % ]
45 [ " " % "method-generic" word-prop word-name* % ] bi
47 ] [ word-style ] bi styled-text ;
51 { 16 [ \ HEX: [ >hex text ] pprint-prefix ] }
52 { 8 [ \ OCT: [ >oct text ] pprint-prefix ] }
53 { 2 [ \ BIN: [ >bin text ] pprint-prefix ] }
54 [ drop number>string text ]
59 \ NAN: [ fp-nan-payload >hex text ] pprint-prefix
62 { 16 [ \ HEX: [ >hex text ] pprint-prefix ] }
63 [ drop number>string text ]
67 M: f pprint* drop \ f pprint-word ;
69 : pprint-effect ( effect -- )
70 [ effect>string ] [ effect-style ] bi styled-text ;
73 : ch>ascii-escape ( ch -- str )
85 : unparse-ch ( ch -- )
86 dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
88 : do-string-limit ( str -- trimmed )
90 dup length margin get > [
91 margin get 3 - head "..." append
95 : unparse-string ( str prefix suffix -- str )
96 [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
98 : pprint-string ( obj str prefix suffix -- )
99 unparse-string swap string-style styled-text ;
102 dup "\"" "\"" pprint-string ;
105 dup "SBUF\" " "\"" pprint-string ;
108 dup string>> "P\" " "\"" pprint-string ;
111 : nesting-limit? ( -- ? )
112 nesting-limit get dup [ pprinter-stack get length < ] when ;
114 : present-text ( str obj -- )
115 presented associate styled-text ;
117 : check-recursion ( obj quot -- )
120 [ class name>> "~" dup surround ] keep present-text
122 over recursion-check get member-eq? [
123 drop "~circularity~" swap present-text
125 over recursion-check get push
127 recursion-check get pop*
131 : filter-tuple-assoc ( slot,value -- name,value )
132 [ [ initial>> ] dip = not ] assoc-filter
133 [ [ name>> ] dip ] assoc-map ;
135 : tuple>assoc ( tuple -- assoc )
136 [ class all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
138 : pprint-slot-value ( name value -- )
139 <flow \ { pprint-word
140 [ text ] [ f <inset pprint* block> ] bi*
141 \ } pprint-word block> ;
143 : (pprint-tuple) ( opener class slots closer -- )
147 [ t <inset [ pprint-slot-value ] assoc-each block> ]
151 : ?pprint-tuple ( tuple quot -- )
152 [ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
154 : pprint-tuple ( tuple -- )
155 [ [ \ T{ ] dip [ class ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
160 : recover-pprint ( try recovery -- )
161 pprinter-stack get clone
162 [ pprinter-stack set ] curry prepose recover ; inline
164 : pprint-c-object ( object content-quot pointer-quot -- )
165 [ c-object-pointers? get ] 2dip
167 [ [ drop ] prepose [ recover-pprint ] 2curry ] 2bi if ; inline
169 : do-length-limit ( seq -- trimmed n/f )
170 length-limit get dup [
172 dup zero? [ 2drop f ] [ [ head-slice ] dip ] if
175 : pprint-elements ( seq -- )
177 [ [ pprint* ] each ] dip
178 [ number>string "~" " more~" surround text ] when* ;
180 M: quotation pprint-delims drop \ [ \ ] ;
181 M: curry pprint-delims drop \ [ \ ] ;
182 M: compose pprint-delims drop \ [ \ ] ;
183 M: array pprint-delims drop \ { \ } ;
184 M: byte-array pprint-delims drop \ B{ \ } ;
185 M: byte-vector pprint-delims drop \ BV{ \ } ;
186 M: vector pprint-delims drop \ V{ \ } ;
187 M: hashtable pprint-delims drop \ H{ \ } ;
188 M: tuple pprint-delims drop \ T{ \ } ;
189 M: wrapper pprint-delims drop \ W{ \ } ;
190 M: callstack pprint-delims drop \ CS{ \ } ;
191 M: hash-set pprint-delims drop \ HS{ \ } ;
193 M: object >pprint-sequence ;
194 M: vector >pprint-sequence ;
195 M: byte-vector >pprint-sequence ;
196 M: callable >pprint-sequence ;
197 M: hashtable >pprint-sequence >alist ;
198 M: wrapper >pprint-sequence wrapped>> 1array ;
199 M: callstack >pprint-sequence callstack>array ;
200 M: hash-set >pprint-sequence members ;
202 : class-slot-sequence ( class slots -- sequence )
203 [ 1array ] [ [ f 2array ] dip append ] if-empty ;
205 M: tuple >pprint-sequence
206 [ class ] [ tuple-slots ] bi class-slot-sequence ;
208 M: object pprint-narrow? drop f ;
209 M: byte-vector pprint-narrow? drop f ;
210 M: array pprint-narrow? drop t ;
211 M: vector pprint-narrow? drop t ;
212 M: hashtable pprint-narrow? drop t ;
213 M: tuple pprint-narrow? drop t ;
215 M: object pprint-object ( obj -- )
220 dup pprint-narrow? <inset
221 >pprint-sequence pprint-elements
223 ] dip pprint-word block>
226 M: object pprint* pprint-object ;
227 M: vector pprint* pprint-object ;
228 M: byte-vector pprint* pprint-object ;
230 : with-extra-nesting-level ( quot -- )
231 nesting-limit [ dup [ 1 + ] [ f ] if* ] change
232 [ nesting-limit set ] curry [ ] cleanup ; inline
235 [ pprint-object ] with-extra-nesting-level ;
236 M: curry pprint* pprint-object ;
237 M: compose pprint* pprint-object ;
238 M: hash-set pprint* pprint-object ;
242 { [ dup wrapped>> method? ] [ wrapped>> pprint* ] }
243 { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }