1 ! Copyright (C) 2003, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays byte-arrays byte-vectors generic
4 hashtables io assocs kernel math namespaces make sequences
5 strings sbufs io.styles vectors words prettyprint.config
6 prettyprint.sections quotations io io.files math.parser effects
7 classes.tuple math.order classes.tuple.private classes
9 IN: prettyprint.backend
11 GENERIC: pprint* ( obj -- )
13 M: effect pprint* effect>string "(" swap ")" 3append 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-style ( word -- style )
26 dup "word-style" word-prop >hashtable [
30 [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
31 [ bold font-style set ] when
36 : word-name* ( word -- str )
37 name>> "( no name )" or ;
39 : pprint-word ( word -- )
41 dup word-name* swap word-style styled-text ;
43 : pprint-prefix ( word quot -- )
44 <block swap pprint-word call block> ; inline
48 \ POSTPONE: [ pprint-word ] pprint-prefix
51 [ "break-before" word-prop line-break ]
55 [ "break-after" word-prop line-break ]
59 M: real pprint* number>string text ;
61 M: f pprint* drop \ f pprint-word ;
64 : ch>ascii-escape ( ch -- str )
76 : unparse-ch ( ch -- )
77 dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
79 : do-string-limit ( str -- trimmed )
81 dup length margin get > [
82 margin get 3 - head "..." append
86 : string-style ( obj -- hash )
89 T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
92 : unparse-string ( str prefix suffix -- str )
93 [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
95 : pprint-string ( obj str prefix suffix -- )
96 unparse-string swap string-style styled-text ;
99 dup "\"" "\"" pprint-string ;
102 dup "SBUF\" " "\"" pprint-string ;
105 dup string>> "P\" " "\"" pprint-string ;
108 : nesting-limit? ( -- ? )
109 nesting-limit get dup [ pprinter-stack get length < ] when ;
111 : present-text ( str obj -- )
112 presented associate styled-text ;
114 : check-recursion ( obj quot -- )
117 "~" over class name>> "~" 3append
120 over recursion-check get memq? [
121 drop "~circularity~" swap present-text
123 over recursion-check get push
125 recursion-check get pop*
129 : tuple>assoc ( tuple -- assoc )
130 [ class all-slots ] [ tuple-slots ] bi zip
131 [ [ initial>> ] dip = not ] assoc-filter
132 [ [ name>> ] dip ] assoc-map ;
134 : pprint-slot-value ( name value -- )
135 <flow \ { pprint-word
136 [ text ] [ f <inset pprint* block> ] bi*
137 \ } pprint-word block> ;
140 boa-tuples? get [ call-next-method ] [
144 dup class pprint-word
146 tuple>assoc [ pprint-slot-value ] assoc-each
153 : do-length-limit ( seq -- trimmed n/f )
154 length-limit get dup [
156 dup zero? [ 2drop f ] [ [ head ] dip ] if
159 : pprint-elements ( seq -- )
161 [ [ pprint* ] each ] dip
162 [ "~" swap number>string " more~" 3append text ] when* ;
164 GENERIC: pprint-delims ( obj -- start end )
166 M: quotation pprint-delims drop \ [ \ ] ;
167 M: curry pprint-delims drop \ [ \ ] ;
168 M: compose pprint-delims drop \ [ \ ] ;
169 M: array pprint-delims drop \ { \ } ;
170 M: byte-array pprint-delims drop \ B{ \ } ;
171 M: byte-vector pprint-delims drop \ BV{ \ } ;
172 M: vector pprint-delims drop \ V{ \ } ;
173 M: hashtable pprint-delims drop \ H{ \ } ;
174 M: tuple pprint-delims drop \ T{ \ } ;
175 M: wrapper pprint-delims drop \ W{ \ } ;
176 M: callstack pprint-delims drop \ CS{ \ } ;
178 GENERIC: >pprint-sequence ( obj -- seq )
180 M: object >pprint-sequence ;
182 M: vector >pprint-sequence ;
183 M: byte-vector >pprint-sequence ;
184 M: curry >pprint-sequence ;
185 M: compose >pprint-sequence ;
186 M: hashtable >pprint-sequence >alist ;
187 M: wrapper >pprint-sequence wrapped>> 1array ;
188 M: callstack >pprint-sequence callstack>array ;
190 M: tuple >pprint-sequence
191 [ class ] [ tuple-slots ] bi
192 [ 1array ] [ [ f 2array ] dip append ] if-empty ;
194 GENERIC: pprint-narrow? ( obj -- ? )
196 M: object pprint-narrow? drop f ;
198 M: array pprint-narrow? drop t ;
199 M: vector pprint-narrow? drop t ;
200 M: hashtable pprint-narrow? drop t ;
201 M: tuple pprint-narrow? drop t ;
203 : pprint-object ( obj -- )
208 dup pprint-narrow? <inset
209 >pprint-sequence pprint-elements
211 ] dip pprint-word block>
214 M: object pprint* pprint-object ;
215 M: vector pprint* pprint-object ;
216 M: byte-vector pprint* pprint-object ;
217 M: hashtable pprint* pprint-object ;
218 M: curry pprint* pprint-object ;
219 M: compose pprint* pprint-object ;
222 dup wrapped>> word? [
223 <block \ \ pprint-word wrapped>> pprint-word block>