1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes classes.builtin
4 classes.error classes.intersection classes.mixin
5 classes.predicate classes.singleton classes.tuple classes.union
6 combinators definitions effects generic generic.hook
7 generic.single generic.standard io io.pathnames
8 io.streams.string io.styles kernel make namespaces prettyprint
9 prettyprint.backend prettyprint.config prettyprint.custom
10 prettyprint.sections sequences sets slots sorting strings
11 summary vocabs words words.alias words.constant words.symbol ;
14 GENERIC: synopsis* ( defspec -- )
16 GENERIC: see* ( defspec -- )
18 : see ( defspec -- ) see* nl ;
20 : synopsis ( defspec -- str )
23 0 margin namespaces:set
24 1 line-limit namespaces:set
26 ] with-string-writer ;
28 : definer. ( defspec -- )
29 definer drop pprint-word ;
31 : comment. ( text -- )
32 H{ { font-style italic } } styled-text ;
34 GENERIC: print-stack-effect? ( word -- ? )
36 M: parsing-word print-stack-effect? drop f ;
37 M: symbol print-stack-effect? drop f ;
38 M: constant print-stack-effect? drop f ;
39 M: alias print-stack-effect? drop f ;
40 M: word print-stack-effect? drop t ;
42 : stack-effect. ( word -- )
43 [ print-stack-effect? ] [ stack-effect ] bi and
44 [ pprint-effect ] when* ;
48 : seeing-word ( word -- )
49 vocabulary>> dup [ lookup-vocab ] when pprinter-in namespaces:set ;
51 : word-synopsis ( word -- )
59 M: word synopsis* word-synopsis ;
61 M: simple-generic synopsis* word-synopsis ;
63 M: standard-generic synopsis*
72 M: hook-generic synopsis*
77 [ "combination" word-prop var>> pprint* ]
83 [ "method-class" word-prop pprint-class ]
84 [ "method-generic" word-prop pprint-word ] tri ;
86 M: mixin-instance synopsis*
88 [ class>> pprint-word ]
89 [ mixin>> pprint-word ] tri ;
91 M: pathname synopsis* pprint* ;
95 0 margin namespaces:set
96 1 line-limit namespaces:set
102 [ stack-effect pprint-effect ]
105 ] with-string-writer ;
107 M: word summary synopsis ;
109 GENERIC: declarations. ( obj -- )
111 M: object declarations. drop ;
113 : declaration. ( word prop -- )
114 [ nip ] [ name>> word-prop ] 2bi
115 [ pprint-word ] [ drop ] if ;
117 M: word declarations.
125 } [ declaration. ] with each ;
127 : pprint-; ( -- ) \ ; pprint-word ;
131 12 nesting-limit namespaces:set
132 100 length-limit namespaces:set
134 <block dup definition pprint-elements block>
135 dup definer nip [ pprint-word ] when* declarations.
139 GENERIC: see-class* ( word -- )
141 M: union-class see-class*
142 <colon \ UNION: pprint-word
144 class-members pprint-elements pprint-; block> ;
146 M: intersection-class see-class*
147 <colon \ INTERSECTION: pprint-word
149 class-participants pprint-elements pprint-; block> ;
151 M: mixin-class see-class*
152 <block \ MIXIN: pprint-word
153 dup pprint-word <block
156 \ INSTANCE: pprint-word pprint-word pprint-word
157 ] with each block> block> ;
159 M: predicate-class see-class*
160 <colon \ PREDICATE: pprint-word
163 dup superclass-of pprint-word
165 "predicate-definition" word-prop pprint-elements
166 pprint-; block> block> ;
168 M: singleton-class see-class*
169 \ SINGLETON: pprint-word pprint-word ;
171 GENERIC: pprint-slot-name ( object -- )
173 M: string pprint-slot-name text ;
175 M: array pprint-slot-name
176 <flow \ { pprint-word
177 f <inset unclip text pprint-elements block>
178 \ } pprint-word block> ;
180 : unparse-slot ( slot-spec -- array )
183 dup class>> object eq? [
189 dup [ class>> object eq? not ] [ initial>> ] bi or [
196 : pprint-slot ( slot-spec -- )
198 dup length 1 = [ first ] when
201 : tuple-declarations. ( class -- )
202 \ final declaration. ;
204 : superclass. ( class -- )
205 superclass-of dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
207 M: tuple-class see-class*
208 <colon \ TUPLE: pprint-word
212 [ <block "slots" word-prop [ pprint-slot ] each block> pprint-; ]
213 [ tuple-declarations. ]
217 M: word see-class* drop ;
219 M: builtin-class see-class*
221 \ BUILTIN: pprint-word
223 [ <block "slots" word-prop [ pprint-slot ] each pprint-; block> ] bi
226 : see-class ( class -- )
229 [ seeing-word ] [ see-class* ] bi
235 [ [ class? ] [ symbol? not ] bi and [ nl nl ] when ]
237 dup [ class? ] [ symbol? ] bi and
238 [ drop ] [ call-next-method ] if
241 M: error-class see-class*
242 <colon \ ERROR: pprint-word
246 [ <block "slots" word-prop [ name>> pprint-slot-name ] each block> pprint-; ]
247 [ tuple-declarations. ]
251 M: error-class see* see-class ;
253 : seeing-implementors ( class -- seq )
255 [ [ reader? ] [ writer? ] bi or ] reject
256 [ lookup-method ] with map
259 : seeing-methods ( generic -- seq )
260 "methods" word-prop values natural-sort ;
265 natural-sort [ nl nl ] [ see* ] interleave ;
267 : methods ( word -- seq )
269 dup class? [ dup seeing-implementors % ] when
270 dup generic? [ dup seeing-methods % ] when
274 : see-methods ( word -- )