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 sequences strings
5 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 ;
24 \ >r hard "break-before" set-word-prop
25 \ r> hard "break-after" set-word-prop
28 : word-style ( word -- style )
29 dup "word-style" word-prop >hashtable [
33 [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
34 [ bold font-style set ] when
39 : word-name* ( word -- str )
40 name>> "( no name )" or ;
42 : pprint-word ( word -- )
44 dup word-name* swap word-style styled-text ;
46 : pprint-prefix ( word quot -- )
47 <block swap pprint-word call block> ; inline
51 \ POSTPONE: [ pprint-word ] pprint-prefix
54 [ "break-before" word-prop line-break ]
58 [ "break-after" word-prop line-break ]
62 M: real pprint* number>string text ;
64 M: f pprint* drop \ f pprint-word ;
67 : ch>ascii-escape ( ch -- str )
79 : unparse-ch ( ch -- )
80 dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
82 : do-string-limit ( str -- trimmed )
84 dup length margin get > [
85 margin get 3 - head "..." append
89 : string-style ( obj -- hash )
92 T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
95 : unparse-string ( str prefix suffix -- str )
96 [ >r % do-string-limit [ unparse-ch ] each r> % ] "" 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 "~" over class name>> "~" 3append
123 over recursion-check get memq? [
124 drop "~circularity~" swap present-text
126 over recursion-check get push
128 recursion-check get pop*
132 : tuple>assoc ( tuple -- assoc )
133 [ class all-slots ] [ tuple-slots ] bi zip
134 [ [ initial>> ] dip = not ] assoc-filter
135 [ [ name>> ] dip ] assoc-map ;
137 : pprint-slot-value ( name value -- )
138 <flow \ { pprint-word
139 [ text ] [ f <inset pprint* block> ] bi*
140 \ } pprint-word block> ;
143 boa-tuples? get [ call-next-method ] [
147 dup class pprint-word
149 tuple>assoc [ pprint-slot-value ] assoc-each
156 : do-length-limit ( seq -- trimmed n/f )
157 length-limit get dup [
159 dup zero? [ 2drop f ] [ >r head r> ] if
162 : pprint-elements ( seq -- )
165 r> [ "~" swap number>string " more~" 3append text ] when* ;
167 GENERIC: pprint-delims ( obj -- start end )
169 M: quotation pprint-delims drop \ [ \ ] ;
170 M: curry pprint-delims drop \ [ \ ] ;
171 M: compose pprint-delims drop \ [ \ ] ;
172 M: array pprint-delims drop \ { \ } ;
173 M: byte-array pprint-delims drop \ B{ \ } ;
174 M: byte-vector pprint-delims drop \ BV{ \ } ;
175 M: vector pprint-delims drop \ V{ \ } ;
176 M: hashtable pprint-delims drop \ H{ \ } ;
177 M: tuple pprint-delims drop \ T{ \ } ;
178 M: wrapper pprint-delims drop \ W{ \ } ;
179 M: callstack pprint-delims drop \ CS{ \ } ;
181 GENERIC: >pprint-sequence ( obj -- seq )
183 M: object >pprint-sequence ;
185 M: vector >pprint-sequence ;
186 M: byte-vector >pprint-sequence ;
187 M: curry >pprint-sequence ;
188 M: compose >pprint-sequence ;
189 M: hashtable >pprint-sequence >alist ;
190 M: wrapper >pprint-sequence wrapped>> 1array ;
191 M: callstack >pprint-sequence callstack>array ;
193 M: tuple >pprint-sequence
194 [ class ] [ tuple-slots ] bi
195 [ 1array ] [ [ f 2array ] dip append ] if-empty ;
197 GENERIC: pprint-narrow? ( obj -- ? )
199 M: object pprint-narrow? drop f ;
201 M: array pprint-narrow? drop t ;
202 M: vector pprint-narrow? drop t ;
203 M: hashtable pprint-narrow? drop t ;
204 M: tuple pprint-narrow? drop t ;
206 : pprint-object ( obj -- )
209 dup pprint-delims >r pprint-word
210 dup pprint-narrow? <inset
211 >pprint-sequence pprint-elements
212 block> r> pprint-word block>
215 M: object pprint* pprint-object ;
216 M: vector pprint* pprint-object ;
217 M: hashtable pprint* pprint-object ;
220 dup quot>> callable? [ pprint-object ] [
221 "( invalid curry )" swap present-text
225 dup [ first>> callable? ] [ second>> callable? ] bi and
227 "( invalid compose )" swap present-text
231 dup wrapped>> word? [
232 <block \ \ pprint-word wrapped>> pprint-word block>
237 M: tuple-layout pprint*
238 "( tuple layout )" swap present-text ;