1 ! Copyright (C) 2009 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 sorting strings summary words
10 words.symbol words.constant words.alias vocabs ;
13 GENERIC: synopsis* ( defspec -- )
15 GENERIC: see* ( defspec -- )
17 : see ( defspec -- ) see* nl ;
19 : synopsis ( defspec -- str )
24 ] with-string-writer ;
26 : definer. ( defspec -- )
27 definer drop pprint-word ;
29 : comment. ( text -- )
30 H{ { font-style italic } } styled-text ;
32 GENERIC: print-stack-effect? ( word -- ? )
34 M: parsing-word print-stack-effect? drop f ;
35 M: symbol print-stack-effect? drop f ;
36 M: constant print-stack-effect? drop f ;
37 M: alias print-stack-effect? drop f ;
38 M: word print-stack-effect? drop t ;
40 : stack-effect. ( word -- )
41 [ print-stack-effect? ] [ stack-effect ] bi and
42 [ pprint-effect ] when* ;
46 : seeing-word ( word -- )
47 vocabulary>> dup [ vocab ] when pprinter-in set ;
49 : word-synopsis ( word -- )
57 M: word synopsis* word-synopsis ;
59 M: simple-generic synopsis* word-synopsis ;
61 M: standard-generic synopsis*
70 M: hook-generic synopsis*
75 [ "combination" word-prop var>> pprint* ]
79 M: method-body synopsis*
81 [ "method-class" word-prop pprint-word ]
82 [ "method-generic" word-prop pprint-word ] tri ;
84 M: mixin-instance synopsis*
86 [ class>> pprint-word ]
87 [ mixin>> pprint-word ] tri ;
89 M: pathname synopsis* pprint* ;
91 M: word summary synopsis ;
93 GENERIC: declarations. ( obj -- )
95 M: object declarations. drop ;
97 : declaration. ( word prop -- )
98 [ nip ] [ name>> word-prop ] 2bi
99 [ pprint-word ] [ drop ] if ;
101 M: word declarations.
109 } [ declaration. ] with each ;
111 : pprint-; ( -- ) \ ; pprint-word ;
118 <block dup definition pprint-elements block>
119 dup definer nip [ pprint-word ] when* declarations.
123 GENERIC: see-class* ( word -- )
125 M: union-class see-class*
126 <colon \ UNION: pprint-word
128 members pprint-elements pprint-; block> ;
130 M: intersection-class see-class*
131 <colon \ INTERSECTION: pprint-word
133 participants pprint-elements pprint-; block> ;
135 M: mixin-class see-class*
136 <block \ MIXIN: pprint-word
137 dup pprint-word <block
140 \ INSTANCE: pprint-word pprint-word pprint-word
141 ] with each block> block> ;
143 M: predicate-class see-class*
144 <colon \ PREDICATE: pprint-word
147 dup superclass pprint-word
149 "predicate-definition" word-prop pprint-elements
150 pprint-; block> block> ;
152 M: singleton-class see-class* ( class -- )
153 \ SINGLETON: pprint-word pprint-word ;
155 GENERIC: pprint-slot-name ( object -- )
157 M: string pprint-slot-name text ;
159 M: array pprint-slot-name
160 <flow \ { pprint-word
161 f <inset unclip text pprint-elements block>
162 \ } pprint-word block> ;
164 : unparse-slot ( slot-spec -- array )
167 dup class>> object eq? [
173 dup [ class>> object eq? not ] [ initial>> ] bi or [
180 : pprint-slot ( slot-spec -- )
182 dup length 1 = [ first ] when
185 M: tuple-class see-class*
186 <colon \ TUPLE: pprint-word
188 dup superclass tuple eq? [
189 "<" text dup superclass pprint-word
191 <block "slots" word-prop [ pprint-slot ] each block>
194 M: word see-class* drop ;
196 M: builtin-class see-class*
197 drop "! Built-in class" comment. ;
199 : see-class ( class -- )
202 [ seeing-word ] [ see-class* ] bi
208 [ [ class? ] [ symbol? not ] bi and [ nl nl ] when ]
210 dup [ class? ] [ symbol? ] bi and
211 [ drop ] [ call-next-method ] if
214 : seeing-implementors ( class -- seq )
215 dup implementors [ method ] with map natural-sort ;
217 : seeing-methods ( generic -- seq )
218 "methods" word-prop values natural-sort ;
223 natural-sort [ nl nl ] [ see* ] interleave ;
225 : methods ( word -- seq )
227 dup class? [ dup seeing-implementors % ] when
228 dup generic? [ dup seeing-methods % ] when
232 : see-methods ( word -- )