1 ! Copyright (C) 2003, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: arrays generic generic.standard assocs io kernel
5 math namespaces sequences strings io.styles io.streams.string
6 vectors words prettyprint.backend prettyprint.sections
7 prettyprint.config sorting splitting math.parser vocabs
8 definitions effects classes.builtin classes.tuple io.files
9 classes continuations hashtables classes.mixin classes.union
10 classes.intersection classes.predicate classes.singleton
11 combinators quotations sets ;
13 : make-pprint ( obj quot -- block in use )
16 H{ } clone pprinter-use set
17 V{ } clone recursion-check set
18 V{ } clone pprinter-stack set
26 : with-pprint ( obj quot -- )
27 make-pprint 2drop do-pprint ; inline
29 : pprint-vocab ( vocab -- )
30 dup vocab present-text ;
32 : write-in ( vocab -- )
33 [ \ IN: pprint-word pprint-vocab ] with-pprint ;
36 [ write-in nl ] when* ;
47 : vocabs. ( in use -- )
48 dupd remove [ { "syntax" "scratchpad" } member? not ] filter
51 : with-use ( obj quot -- )
52 make-pprint vocabs. do-pprint ; inline
54 : with-in ( obj quot -- )
55 make-pprint drop [ write-in bl ] when* do-pprint ; inline
57 : pprint ( obj -- ) [ pprint* ] with-pprint ;
63 } clone [ pprint ] bind nl ;
65 : pprint-use ( obj -- ) [ pprint* ] with-use ;
67 : unparse ( obj -- str ) [ pprint ] with-string-writer ;
69 : unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
71 : pprint-short ( obj -- )
77 } clone [ pprint ] bind ;
79 : unparse-short ( obj -- str )
80 [ pprint-short ] with-string-writer ;
82 : short. ( obj -- ) pprint-short nl ;
84 : .b ( n -- ) >bin print ;
85 : .o ( n -- ) >oct print ;
86 : .h ( n -- ) >hex print ;
88 : stack. ( seq -- ) [ short. ] each ;
90 : .s ( -- ) datastack stack. ;
91 : .r ( -- ) retainstack stack. ;
98 { { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
99 "word-style" set-word-prop
101 : remove-step-into ( word -- )
102 building get dup empty? [ drop ] [ nip pop wrapped ] if , ;
104 : (remove-breakpoints) ( quot -- newquot )
108 { [ dup word? not ] [ , ] }
109 { [ dup "break?" word-prop ] [ drop ] }
110 { [ dup "step-into?" word-prop ] [ remove-step-into ] }
116 : remove-breakpoints ( quot pos -- quot' )
118 1+ cut [ (remove-breakpoints) ] bi@
126 : callstack. ( callstack -- )
127 callstack>array 2 <groups> [
129 2 nesting-limit [ . ] with-variable
132 : .c ( -- ) callstack callstack. ;
134 : pprint-cell ( obj -- ) [ pprint ] with-cell ;
136 GENERIC: see ( defspec -- )
138 : comment. ( string -- )
139 [ H{ { font-style italic } } styled-text ] when* ;
141 : seeing-word ( word -- )
142 word-vocabulary pprinter-in set ;
144 : definer. ( defspec -- )
145 definer drop pprint-word ;
147 : stack-effect. ( word -- )
148 dup parsing? over symbol? or not swap stack-effect and
149 [ effect>string comment. ] when* ;
151 : word-synopsis ( word -- )
157 M: word synopsis* word-synopsis ;
159 M: simple-generic synopsis* word-synopsis ;
161 M: standard-generic synopsis*
165 dup dispatch# pprint*
168 M: hook-generic synopsis*
172 dup "combination" word-prop hook-combination-var pprint*
175 M: method-spec synopsis*
176 first2 method synopsis* ;
178 M: method-body synopsis*
181 "method-class" word-prop pprint-word
182 "method-generic" word-prop pprint-word ;
184 M: mixin-instance synopsis*
186 dup mixin-instance-class pprint-word
187 mixin-instance-mixin pprint-word ;
189 M: pathname synopsis* pprint* ;
191 : synopsis ( defspec -- str )
195 [ synopsis* ] with-in
196 ] with-string-writer ;
198 : synopsis-alist ( definitions -- alist )
199 [ dup synopsis swap ] { } map>assoc ;
201 : definitions. ( alist -- )
202 [ write-object nl ] assoc-each ;
204 : sorted-definitions. ( definitions -- )
205 synopsis-alist sort-keys definitions. ;
207 GENERIC: declarations. ( obj -- )
209 M: object declarations. drop ;
211 : declaration. ( word prop -- )
212 tuck word-name word-prop [ pprint-word ] [ drop ] if ;
214 M: word declarations.
221 } [ declaration. ] with each ;
223 : pprint-; \ ; pprint-word ;
227 <block dup definition pprint-elements block>
228 dup definer nip [ pprint-word ] when* declarations.
232 [ (see) ] with-use nl ;
234 GENERIC: see-class* ( word -- )
236 M: union-class see-class*
237 <colon \ UNION: pprint-word
239 members pprint-elements pprint-; block> ;
241 M: intersection-class see-class*
242 <colon \ INTERSECTION: pprint-word
244 participants pprint-elements pprint-; block> ;
246 M: mixin-class see-class*
247 <block \ MIXIN: pprint-word
248 dup pprint-word <block
251 \ INSTANCE: pprint-word pprint-word pprint-word
252 ] with each block> block> ;
254 M: predicate-class see-class*
255 <colon \ PREDICATE: pprint-word
258 dup superclass pprint-word
260 "predicate-definition" word-prop pprint-elements
261 pprint-; block> block> ;
263 M: singleton-class see-class* ( class -- )
264 \ SINGLETON: pprint-word pprint-word ;
266 M: tuple-class see-class*
267 <colon \ TUPLE: pprint-word
269 dup superclass tuple eq? [
270 "<" text dup superclass pprint-word
272 slot-names [ text ] each
275 M: word see-class* drop ;
277 M: builtin-class see-class*
278 drop "! Built-in class" comment. ;
281 natural-sort [ nl see ] each ;
283 : see-implementors ( class -- seq )
288 : see-class ( class -- )
291 dup seeing-word dup see-class*
295 : see-methods ( generic -- seq )
296 "methods" word-prop values natural-sort ;
300 dup class? over symbol? not and [
303 dup class? over symbol? and not [
304 [ dup (see) ] with-use nl
307 dup class? [ dup see-implementors % ] when
308 dup generic? [ dup see-methods % ] when
310 ] { } make prune see-all ;