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.intersection classes.mixin classes.predicate classes.singleton
5 classes.tuple classes.union combinators definitions effects generic
6 generic.single generic.standard generic.hook io io.pathnames
7 io.streams.string io.styles kernel make namespaces prettyprint
8 prettyprint.backend prettyprint.config prettyprint.custom
9 prettyprint.sections sequences sets slots sorting strings summary
10 words words.symbol words.constant words.alias vocabs ;
11 FROM: namespaces => set ;
12 FROM: classes => members ;
13 RENAME: members sets => set-members
16 GENERIC: synopsis* ( defspec -- )
18 GENERIC: see* ( defspec -- )
20 : see ( defspec -- ) see* nl ;
22 : synopsis ( defspec -- str )
28 ] with-string-writer ;
30 : definer. ( defspec -- )
31 definer drop pprint-word ;
33 : comment. ( text -- )
34 H{ { font-style italic } } styled-text ;
36 GENERIC: print-stack-effect? ( word -- ? )
38 M: parsing-word print-stack-effect? drop f ;
39 M: symbol print-stack-effect? drop f ;
40 M: constant print-stack-effect? drop f ;
41 M: alias print-stack-effect? drop f ;
42 M: word print-stack-effect? drop t ;
44 : stack-effect. ( word -- )
45 [ print-stack-effect? ] [ stack-effect ] bi and
46 [ pprint-effect ] when* ;
50 : seeing-word ( word -- )
51 vocabulary>> dup [ lookup-vocab ] when pprinter-in set ;
53 : word-synopsis ( word -- )
61 M: word synopsis* word-synopsis ;
63 M: simple-generic synopsis* word-synopsis ;
65 M: standard-generic synopsis*
74 M: hook-generic synopsis*
79 [ "combination" word-prop var>> pprint* ]
85 [ "method-class" word-prop pprint-class ]
86 [ "method-generic" word-prop pprint-word ] tri ;
88 M: mixin-instance synopsis*
90 [ class>> pprint-word ]
91 [ mixin>> pprint-word ] tri ;
93 M: pathname synopsis* pprint* ;
97 0 margin set 1 line-limit set
103 [ stack-effect pprint-effect ]
106 ] with-string-writer ;
108 M: word summary synopsis ;
110 GENERIC: declarations. ( obj -- )
112 M: object declarations. drop ;
114 : declaration. ( word prop -- )
115 [ nip ] [ name>> word-prop ] 2bi
116 [ pprint-word ] [ drop ] if ;
118 M: word declarations.
126 } [ declaration. ] with each ;
128 : pprint-; ( -- ) \ ; pprint-word ;
135 <block dup definition pprint-elements block>
136 dup definer nip [ pprint-word ] when* declarations.
140 GENERIC: see-class* ( word -- )
142 M: union-class see-class*
143 <colon \ UNION: pprint-word
145 members pprint-elements pprint-; block> ;
147 M: intersection-class see-class*
148 <colon \ INTERSECTION: pprint-word
150 participants pprint-elements pprint-; block> ;
152 M: mixin-class see-class*
153 <block \ MIXIN: pprint-word
154 dup pprint-word <block
157 \ INSTANCE: pprint-word pprint-word pprint-word
158 ] with each block> block> ;
160 M: predicate-class see-class*
161 <colon \ PREDICATE: pprint-word
164 dup superclass pprint-word
166 "predicate-definition" word-prop pprint-elements
167 pprint-; block> block> ;
169 M: singleton-class see-class* ( class -- )
170 \ SINGLETON: pprint-word pprint-word ;
172 GENERIC: pprint-slot-name ( object -- )
174 M: string pprint-slot-name text ;
176 M: array pprint-slot-name
177 <flow \ { pprint-word
178 f <inset unclip text pprint-elements block>
179 \ } pprint-word block> ;
181 : unparse-slot ( slot-spec -- array )
184 dup class>> object eq? [
190 dup [ class>> object eq? not ] [ initial>> ] bi or [
197 : pprint-slot ( slot-spec -- )
199 dup length 1 = [ first ] when
202 : tuple-declarations. ( class -- )
203 \ final declaration. ;
205 : superclass. ( class -- )
206 superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
208 M: tuple-class see-class*
209 <colon \ TUPLE: pprint-word
213 [ <block "slots" word-prop [ pprint-slot ] each block> pprint-; ]
214 [ tuple-declarations. ]
218 M: word see-class* drop ;
220 M: builtin-class see-class*
222 \ BUILTIN: pprint-word
224 [ <block "slots" word-prop [ pprint-slot ] each pprint-; block> ] bi
227 : see-class ( class -- )
230 [ seeing-word ] [ see-class* ] bi
236 [ [ class? ] [ symbol? not ] bi and [ nl nl ] when ]
238 dup [ class? ] [ symbol? ] bi and
239 [ drop ] [ call-next-method ] if
242 : seeing-implementors ( class -- seq )
244 [ [ reader? ] [ writer? ] bi or ] reject
245 [ lookup-method ] with map
248 : seeing-methods ( generic -- seq )
249 "methods" word-prop values natural-sort ;
254 natural-sort [ nl nl ] [ see* ] interleave ;
256 : methods ( word -- seq )
258 dup class? [ dup seeing-implementors % ] when
259 dup generic? [ dup seeing-methods % ] when
261 ] { } make set-members ;
263 : see-methods ( word -- )