1 ! Copyright (C) 2003, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays generic generic.standard assocs io kernel math
4 namespaces make sequences strings io.styles io.streams.string
5 vectors words words.symbol prettyprint.backend prettyprint.custom
6 prettyprint.sections prettyprint.config sorting splitting
7 grouping math.parser vocabs definitions effects classes.builtin
8 classes.tuple io.pathnames classes continuations hashtables
9 classes.mixin classes.union classes.intersection
10 classes.predicate classes.singleton combinators quotations sets
11 accessors colors parser summary vocabs.parser ;
14 : make-pprint ( obj quot -- block in use )
17 H{ } clone pprinter-use set
18 V{ } clone recursion-check set
19 V{ } clone pprinter-stack set
27 : with-pprint ( obj quot -- )
28 make-pprint 2drop do-pprint ; inline
30 : pprint-vocab ( vocab -- )
31 dup vocab present-text ;
33 : write-in ( vocab -- )
34 [ \ IN: pprint-word pprint-vocab ] with-pprint ;
37 [ write-in nl ] when* ;
48 : use/in. ( in use -- )
49 dupd remove [ { "syntax" "scratchpad" } member? not ] filter
52 : vocab-names ( words -- vocabs )
54 [ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
57 in get use get vocab-names use/in. ;
61 "Restarts were invoked adding vocabularies to the search path." print
62 "To avoid doing this in the future, add the following USING:" print
63 "and IN: forms at the top of the source file:" print nl
66 ] print-use-hook set-global
68 : with-use ( obj quot -- )
69 make-pprint use/in. do-pprint ; inline
71 : with-in ( obj quot -- )
72 make-pprint drop [ write-in bl ] when* do-pprint ; inline
74 : pprint ( obj -- ) [ pprint* ] with-pprint ;
76 : . ( obj -- ) pprint nl ;
78 : pprint-use ( obj -- ) [ pprint* ] with-use ;
80 : unparse ( obj -- str ) [ pprint ] with-string-writer ;
82 : unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
84 : pprint-short ( obj -- )
91 } clone [ pprint ] bind ;
93 : unparse-short ( obj -- str )
94 [ pprint-short ] with-string-writer ;
96 : short. ( obj -- ) pprint-short nl ;
98 : .b ( n -- ) >bin print ;
99 : .o ( n -- ) >oct print ;
100 : .h ( n -- ) >hex print ;
102 : stack. ( seq -- ) [ short. ] each ;
104 : .s ( -- ) datastack stack. ;
105 : .r ( -- ) retainstack stack. ;
112 { { foreground T{ rgba f 1 1 1 1 } } { background T{ rgba f 0 0 0 1 } } }
113 "word-style" set-word-prop
115 : remove-step-into ( word -- )
116 building get [ nip pop wrapped>> ] unless-empty , ;
118 : (remove-breakpoints) ( quot -- newquot )
122 { [ dup word? not ] [ , ] }
123 { [ dup "break?" word-prop ] [ drop ] }
124 { [ dup "step-into?" word-prop ] [ remove-step-into ] }
130 : remove-breakpoints ( quot pos -- quot' )
132 1+ cut [ (remove-breakpoints) ] bi@
140 : callstack. ( callstack -- )
141 callstack>array 2 <groups> [
150 : .c ( -- ) callstack callstack. ;
152 : pprint-cell ( obj -- ) [ pprint-short ] with-cell ;
154 SYMBOL: pprint-string-cells?
156 : simple-table. ( values -- )
157 standard-table-style [
161 dup string? pprint-string-cells? get not and
162 [ [ write ] with-cell ]
170 GENERIC: see ( defspec -- )
172 : comment. ( string -- )
173 [ H{ { font-style italic } } styled-text ] when* ;
175 : seeing-word ( word -- )
176 vocabulary>> pprinter-in set ;
178 : definer. ( defspec -- )
179 definer drop pprint-word ;
181 : stack-effect. ( word -- )
182 [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
183 [ effect>string comment. ] when* ;
185 : word-synopsis ( word -- )
193 M: word synopsis* word-synopsis ;
195 M: simple-generic synopsis* word-synopsis ;
197 M: standard-generic synopsis*
202 [ dispatch# pprint* ]
206 M: hook-generic synopsis*
211 [ "combination" word-prop var>> pprint* ]
215 M: method-spec synopsis*
216 first2 method synopsis* ;
218 M: method-body synopsis*
220 [ "method-class" word-prop pprint-word ]
221 [ "method-generic" word-prop pprint-word ] tri ;
223 M: mixin-instance synopsis*
225 [ class>> pprint-word ]
226 [ mixin>> pprint-word ] tri ;
228 M: pathname synopsis* pprint* ;
230 : synopsis ( defspec -- str )
234 [ synopsis* ] with-in
235 ] with-string-writer ;
237 M: word summary synopsis ;
239 GENERIC: declarations. ( obj -- )
241 M: object declarations. drop ;
243 : declaration. ( word prop -- )
244 [ nip ] [ name>> word-prop ] 2bi
245 [ pprint-word ] [ drop ] if ;
247 M: word declarations.
255 } [ declaration. ] with each ;
257 : pprint-; ( -- ) \ ; pprint-word ;
264 <block dup definition pprint-elements block>
265 dup definer nip [ pprint-word ] when* declarations.
272 GENERIC: see-class* ( word -- )
274 M: union-class see-class*
275 <colon \ UNION: pprint-word
277 members pprint-elements pprint-; block> ;
279 M: intersection-class see-class*
280 <colon \ INTERSECTION: pprint-word
282 participants pprint-elements pprint-; block> ;
284 M: mixin-class see-class*
285 <block \ MIXIN: pprint-word
286 dup pprint-word <block
289 \ INSTANCE: pprint-word pprint-word pprint-word
290 ] with each block> block> ;
292 M: predicate-class see-class*
293 <colon \ PREDICATE: pprint-word
296 dup superclass pprint-word
298 "predicate-definition" word-prop pprint-elements
299 pprint-; block> block> ;
301 M: singleton-class see-class* ( class -- )
302 \ SINGLETON: pprint-word pprint-word ;
304 GENERIC: pprint-slot-name ( object -- )
306 M: string pprint-slot-name text ;
308 M: array pprint-slot-name
309 <flow \ { pprint-word
310 f <inset unclip text pprint-elements block>
311 \ } pprint-word block> ;
313 : unparse-slot ( slot-spec -- array )
316 dup class>> object eq? [
327 : pprint-slot ( slot-spec -- )
329 dup length 1 = [ first ] when
332 M: tuple-class see-class*
333 <colon \ TUPLE: pprint-word
335 dup superclass tuple eq? [
336 "<" text dup superclass pprint-word
338 <block "slots" word-prop [ pprint-slot ] each block>
341 M: word see-class* drop ;
343 M: builtin-class see-class*
344 drop "! Built-in class" comment. ;
346 : see-class ( class -- )
349 dup seeing-word dup see-class*
355 [ [ class? ] [ symbol? not ] bi and [ nl ] when ]
357 dup [ class? ] [ symbol? ] bi and
358 [ drop ] [ call-next-method ] if
362 natural-sort [ nl ] [ see ] interleave ;
364 : (see-implementors) ( class -- seq )
365 dup implementors [ method ] with map natural-sort ;
367 : (see-methods) ( generic -- seq )
368 "methods" word-prop values natural-sort ;
370 : methods ( word -- seq )
372 dup class? [ dup (see-implementors) % ] when
373 dup generic? [ dup (see-methods) % ] when
377 : see-methods ( word -- )