]> gitweb.factorcode.org Git - factor.git/blob - basis/prettyprint/backend/backend.factor
merge project-euler.factor
[factor.git] / basis / prettyprint / backend / backend.factor
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 ;
10 IN: prettyprint.backend
11
12 M: effect pprint* effect>string "(" ")" surround text ;
13
14 : ?effect-height ( word -- n )
15     stack-effect [ effect-height ] [ 0 ] if* ;
16
17 : ?start-group ( word -- )
18     ?effect-height 0 > [ start-group ] when ;
19
20 : ?end-group ( word -- )
21     ?effect-height 0 < [ end-group ] when ;
22
23 ! Atoms
24 : word-name* ( word -- str )
25     name>> "( no name )" or ;
26
27 : pprint-word ( word -- )
28     [ record-vocab ]
29     [ [ word-name* ] [ word-style ] bi styled-text ] bi ;
30
31 : pprint-prefix ( word quot -- )
32     <block swap pprint-word call block> ; inline
33
34 M: parsing-word pprint*
35     \ POSTPONE: [ pprint-word ] pprint-prefix ;
36
37 M: word pprint*
38     [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
39
40 M: method-body pprint*
41     [
42         [
43             [ "M\\ " % "method-class" word-prop word-name* % ]
44             [ " " % "method-generic" word-prop word-name* % ] bi
45         ] "" make
46     ] [ word-style ] bi styled-text ;
47
48 M: real pprint*
49     number-base get {
50         { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] }
51         {  8 [ \ OCT: [  8 >base text ] pprint-prefix ] }
52         {  2 [ \ BIN: [  2 >base text ] pprint-prefix ] }
53         [ drop number>string text ]
54     } case ;
55
56 M: float pprint*
57     dup fp-nan? [
58         \ NAN: [ fp-nan-payload >hex text ] pprint-prefix
59     ] [
60         number-base get {
61             { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] }
62             [ drop number>string text ]
63         } case
64     ] if ;
65
66 M: f pprint* drop \ f pprint-word ;
67
68 : pprint-effect ( effect -- )
69     [ effect>string ] [ effect-style ] bi styled-text ;
70
71 ! Strings
72 : ch>ascii-escape ( ch -- str )
73     H{
74         { CHAR: \a CHAR: a  }
75         { CHAR: \e CHAR: e  }
76         { CHAR: \n CHAR: n  }
77         { CHAR: \r CHAR: r  }
78         { CHAR: \t CHAR: t  }
79         { CHAR: \0 CHAR: 0  }
80         { CHAR: \\ CHAR: \\ }
81         { CHAR: \" CHAR: \" }
82     } at ;
83
84 : unparse-ch ( ch -- )
85     dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
86
87 : do-string-limit ( str -- trimmed )
88     string-limit? get [
89         dup length margin get > [
90             margin get 3 - head "..." append
91         ] when
92     ] when ;
93
94 : unparse-string ( str prefix suffix -- str )
95     [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
96
97 : pprint-string ( obj str prefix suffix -- )
98     unparse-string swap string-style styled-text ;
99
100 M: string pprint*
101     dup "\"" "\"" pprint-string ;
102
103 M: sbuf pprint*
104     dup "SBUF\" " "\"" pprint-string ;
105
106 M: pathname pprint*
107     dup string>> "P\" " "\"" pprint-string ;
108
109 ! Sequences
110 : nesting-limit? ( -- ? )
111     nesting-limit get dup [ pprinter-stack get length < ] when ;
112
113 : present-text ( str obj -- )
114     presented associate styled-text ;
115
116 : check-recursion ( obj quot -- )
117     nesting-limit? [
118         drop
119         "~" over class name>> "~" 3append
120         swap present-text
121     ] [
122         over recursion-check get memq? [
123             drop "~circularity~" swap present-text
124         ] [
125             over recursion-check get push
126             call
127             recursion-check get pop*
128         ] if
129     ] if ; inline
130
131 : filter-tuple-assoc ( slot,value -- name,value )
132     [ [ initial>> ] dip = not ] assoc-filter
133     [ [ name>> ] dip ] assoc-map ;
134
135 : tuple>assoc ( tuple -- assoc )
136     [ class all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
137
138 : pprint-slot-value ( name value -- )
139     <flow \ { pprint-word
140     [ text ] [ f <inset pprint* block> ] bi*
141     \ } pprint-word block> ;
142
143 : (pprint-tuple) ( opener class slots closer -- )
144     <flow {
145         [ pprint-word ]
146         [ pprint-word ]
147         [ t <inset [ pprint-slot-value ] assoc-each block> ]
148         [ pprint-word ]
149     } spread block> ;
150
151 : ?pprint-tuple ( tuple quot -- )
152     [ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
153
154 : pprint-tuple ( tuple -- )
155     [ [ \ T{ ] dip [ class ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
156
157 M: tuple pprint*
158     pprint-tuple ;
159
160 : recover-pprint ( try recovery -- )
161     pprinter-stack get clone
162     [ pprinter-stack set ] curry prepose recover ; inline
163
164 : pprint-c-object ( object content-quot pointer-quot -- )
165     [ c-object-pointers? get ] 2dip
166     [ nip ]
167     [ [ drop ] prepose [ recover-pprint ] 2curry ] 2bi if ; inline
168
169 : do-length-limit ( seq -- trimmed n/f )
170     length-limit get dup [
171         over length over [-]
172         dup zero? [ 2drop f ] [ [ head-slice ] dip ] if
173     ] when ;
174
175 : pprint-elements ( seq -- )
176     do-length-limit
177     [ [ pprint* ] each ] dip
178     [ "~" swap number>string " more~" 3append text ] when* ;
179
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
192 M: object >pprint-sequence ;
193 M: vector >pprint-sequence ;
194 M: byte-vector >pprint-sequence ;
195 M: callable >pprint-sequence ;
196 M: hashtable >pprint-sequence >alist ;
197 M: wrapper >pprint-sequence wrapped>> 1array ;
198 M: callstack >pprint-sequence callstack>array ;
199
200 : class-slot-sequence ( class slots -- sequence )
201     [ 1array ] [ [ f 2array ] dip append ] if-empty ;
202
203 M: tuple >pprint-sequence
204     [ class ] [ tuple-slots ] bi class-slot-sequence ;
205
206 M: object pprint-narrow? drop f ;
207 M: byte-vector pprint-narrow? drop f ;
208 M: array pprint-narrow? drop t ;
209 M: vector pprint-narrow? drop t ;
210 M: hashtable pprint-narrow? drop t ;
211 M: tuple pprint-narrow? drop t ;
212
213 M: object pprint-object ( obj -- )
214     [
215         <flow
216         dup pprint-delims [
217             pprint-word
218             dup pprint-narrow? <inset
219             >pprint-sequence pprint-elements
220             block>
221         ] dip pprint-word block>
222     ] check-recursion ;
223
224 M: object pprint* pprint-object ;
225 M: vector pprint* pprint-object ;
226 M: byte-vector pprint* pprint-object ;
227 M: hashtable pprint* pprint-object ;
228 M: curry pprint* pprint-object ;
229 M: compose pprint* pprint-object ;
230
231 M: wrapper pprint*
232     {
233         { [ dup wrapped>> method-body? ] [ wrapped>> pprint* ] }
234         { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
235         [ pprint-object ]
236     } cond ;