1 ! Copyright (C) 2003, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays byte-arrays generic hashtables io assocs
4 kernel math namespaces make sequences strings sbufs vectors
5 words prettyprint.config prettyprint.custom prettyprint.sections
6 quotations io io.pathnames io.styles math.parser effects
7 classes.tuple math.order classes.tuple.private classes
9 IN: prettyprint.backend
11 M: effect pprint* effect>string "(" ")" surround text ;
13 : ?effect-height ( word -- n )
14 stack-effect [ effect-height ] [ 0 ] if* ;
16 : ?start-group ( word -- )
17 ?effect-height 0 > [ start-group ] when ;
19 : ?end-group ( word -- )
20 ?effect-height 0 < [ end-group ] when ;
23 : word-style ( word -- style )
24 dup "word-style" word-prop >hashtable [
28 [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
29 [ bold font-style set ] when
34 : word-name* ( word -- str )
35 name>> "( no name )" or ;
37 : pprint-word ( word -- )
39 [ [ word-name* ] [ word-style ] bi styled-text ] bi ;
41 : pprint-prefix ( word quot -- )
42 <block swap pprint-word call block> ; inline
44 M: parsing-word pprint*
45 \ POSTPONE: [ pprint-word ] pprint-prefix ;
48 [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
50 M: method-body pprint*
53 [ "M\\ " % "method-class" word-prop word-name* % ]
54 [ " " % "method-generic" word-prop word-name* % ] bi
56 ] [ word-style ] bi styled-text ;
58 M: real pprint* number>string text ;
60 M: f pprint* drop \ f pprint-word ;
63 : ch>ascii-escape ( ch -- str )
75 : unparse-ch ( ch -- )
76 dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
78 : do-string-limit ( str -- trimmed )
80 dup length margin get > [
81 margin get 3 - head "..." append
85 : string-style ( obj -- hash )
88 T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
91 : unparse-string ( str prefix suffix -- str )
92 [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
94 : pprint-string ( obj str prefix suffix -- )
95 unparse-string swap string-style styled-text ;
98 dup "\"" "\"" pprint-string ;
101 dup "SBUF\" " "\"" pprint-string ;
104 dup string>> "P\" " "\"" pprint-string ;
107 : nesting-limit? ( -- ? )
108 nesting-limit get dup [ pprinter-stack get length < ] when ;
110 : present-text ( str obj -- )
111 presented associate styled-text ;
113 : check-recursion ( obj quot -- )
116 "~" over class name>> "~" 3append
119 over recursion-check get memq? [
120 drop "~circularity~" swap present-text
122 over recursion-check get push
124 recursion-check get pop*
128 : tuple>assoc ( tuple -- assoc )
129 [ class all-slots ] [ tuple-slots ] bi zip
130 [ [ initial>> ] dip = not ] assoc-filter
131 [ [ name>> ] dip ] assoc-map ;
133 : pprint-slot-value ( name value -- )
134 <flow \ { pprint-word
135 [ text ] [ f <inset pprint* block> ] bi*
136 \ } pprint-word block> ;
139 boa-tuples? get [ call-next-method ] [
143 dup class pprint-word
145 tuple>assoc [ pprint-slot-value ] assoc-each
152 : do-length-limit ( seq -- trimmed n/f )
153 length-limit get dup [
155 dup zero? [ 2drop f ] [ [ head ] dip ] if
158 : pprint-elements ( seq -- )
160 [ [ pprint* ] each ] dip
161 [ "~" swap number>string " more~" 3append text ] when* ;
163 M: quotation pprint-delims drop \ [ \ ] ;
164 M: curry pprint-delims drop \ [ \ ] ;
165 M: compose pprint-delims drop \ [ \ ] ;
166 M: array pprint-delims drop \ { \ } ;
167 M: byte-array pprint-delims drop \ B{ \ } ;
168 M: vector pprint-delims drop \ V{ \ } ;
169 M: hashtable pprint-delims drop \ H{ \ } ;
170 M: tuple pprint-delims drop \ T{ \ } ;
171 M: wrapper pprint-delims drop \ W{ \ } ;
172 M: callstack pprint-delims drop \ CS{ \ } ;
174 M: object >pprint-sequence ;
175 M: vector >pprint-sequence ;
176 M: curry >pprint-sequence ;
177 M: compose >pprint-sequence ;
178 M: hashtable >pprint-sequence >alist ;
179 M: wrapper >pprint-sequence wrapped>> 1array ;
180 M: callstack >pprint-sequence callstack>array ;
182 M: tuple >pprint-sequence
183 [ class ] [ tuple-slots ] bi
184 [ 1array ] [ [ f 2array ] dip append ] if-empty ;
186 M: object pprint-narrow? drop f ;
187 M: array pprint-narrow? drop t ;
188 M: vector pprint-narrow? drop t ;
189 M: hashtable pprint-narrow? drop t ;
190 M: tuple pprint-narrow? drop t ;
192 M: object pprint-object ( obj -- )
197 dup pprint-narrow? <inset
198 >pprint-sequence pprint-elements
200 ] dip pprint-word block>
203 M: object pprint* pprint-object ;
204 M: vector pprint* pprint-object ;
205 M: hashtable pprint* pprint-object ;
206 M: curry pprint* pprint-object ;
207 M: compose pprint* pprint-object ;
211 { [ dup wrapped>> method-body? ] [ wrapped>> pprint* ] }
212 { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }