basis/see/see.factor

   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
  14 IN: see
  15
  16 GENERIC: synopsis* ( defspec -- )
  17
  18 GENERIC: see* ( defspec -- )
  19
  20 : see ( defspec -- ) see* nl ;
  21
  22 : synopsis ( defspec -- str )
  23     [
  24         0 margin set
  25         1 line-limit set
  26         [ synopsis* ] with-in
  27     ] with-string-writer ;
  28
  29 : definer. ( defspec -- )
  30     definer drop pprint-word ;
  31
  32 : comment. ( text -- )
  33     H{ { font-style italic } } styled-text ;
  34
  35 GENERIC: print-stack-effect? ( word -- ? )
  36
  37 M: parsing-word print-stack-effect? drop f ;
  38 M: symbol print-stack-effect? drop f ;
  39 M: constant print-stack-effect? drop f ;
  40 M: alias print-stack-effect? drop f ;
  41 M: word print-stack-effect? drop t ;
  42
  43 : stack-effect. ( word -- )
  44     [ print-stack-effect? ] [ stack-effect ] bi and
  45     [ pprint-effect ] when* ;
  46
  47 <PRIVATE
  48
  49 : seeing-word ( word -- )
  50     vocabulary>> dup [ lookup-vocab ] when pprinter-in set ;
  51
  52 : word-synopsis ( word -- )
  53     {
  54         [ seeing-word ]
  55         [ definer. ]
  56         [ pprint-word ]
  57         [ stack-effect. ]
  58     } cleave ;
  59
  60 M: word synopsis* word-synopsis ;
  61
  62 M: simple-generic synopsis* word-synopsis ;
  63
  64 M: standard-generic synopsis*
  65     {
  66         [ definer. ]
  67         [ seeing-word ]
  68         [ pprint-word ]
  69         [ dispatch# pprint* ]
  70         [ stack-effect. ]
  71     } cleave ;
  72
  73 M: hook-generic synopsis*
  74     {
  75         [ definer. ]
  76         [ seeing-word ]
  77         [ pprint-word ]
  78         [ "combination" word-prop var>> pprint* ]
  79         [ stack-effect. ]
  80     } cleave ;
  81
  82 M: method synopsis*
  83     [ definer. ]
  84     [ "method-class" word-prop pprint-class ]
  85     [ "method-generic" word-prop pprint-word ] tri ;
  86
  87 M: mixin-instance synopsis*
  88     [ definer. ]
  89     [ class>> pprint-word ]
  90     [ mixin>> pprint-word ] tri ;
  91
  92 M: pathname synopsis* pprint* ;
  93
  94 M: word summary synopsis ;
  95
  96 GENERIC: declarations. ( obj -- )
  97
  98 M: object declarations. drop ;
  99
 100 : declaration. ( word prop -- )
 101     [ nip ] [ name>> word-prop ] 2bi
 102     [ pprint-word ] [ drop ] if ;
 103
 104 M: word declarations.
 105     {
 106         POSTPONE: delimiter
 107         POSTPONE: deprecated
 108         POSTPONE: inline
 109         POSTPONE: recursive
 110         POSTPONE: foldable
 111         POSTPONE: flushable
 112     } [ declaration. ] with each ;
 113
 114 : pprint-; ( -- ) \ ; pprint-word ;
 115
 116 M: object see*
 117     [
 118         12 nesting-limit set
 119         100 length-limit set
 120         <colon dup synopsis*
 121         <block dup definition pprint-elements block>
 122         dup definer nip [ pprint-word ] when* declarations.
 123         block>
 124     ] with-use ;
 125
 126 GENERIC: see-class* ( word -- )
 127
 128 M: union-class see-class*
 129     <colon \ UNION: pprint-word
 130     dup pprint-word
 131     members pprint-elements pprint-; block> ;
 132
 133 M: intersection-class see-class*
 134     <colon \ INTERSECTION: pprint-word
 135     dup pprint-word
 136     participants pprint-elements pprint-; block> ;
 137
 138 M: mixin-class see-class*
 139     <block \ MIXIN: pprint-word
 140     dup pprint-word <block
 141     dup members [
 142         hard add-line-break
 143         \ INSTANCE: pprint-word pprint-word pprint-word
 144     ] with each block> block> ;
 145
 146 M: predicate-class see-class*
 147     <colon \ PREDICATE: pprint-word
 148     dup pprint-word
 149     "<" text
 150     dup superclass pprint-word
 151     <block
 152     "predicate-definition" word-prop pprint-elements
 153     pprint-; block> block> ;
 154
 155 M: singleton-class see-class* ( class -- )
 156     \ SINGLETON: pprint-word pprint-word ;
 157
 158 GENERIC: pprint-slot-name ( object -- )
 159
 160 M: string pprint-slot-name text ;
 161
 162 M: array pprint-slot-name
 163     <flow \ { pprint-word
 164     f <inset unclip text pprint-elements block>
 165     \ } pprint-word block> ;
 166
 167 : unparse-slot ( slot-spec -- array )
 168     [
 169         dup name>> ,
 170         dup class>> object eq? [
 171             dup class>> ,
 172         ] unless
 173         dup read-only>> [
 174             read-only ,
 175         ] when
 176         dup [ class>> object eq? not ] [ initial>> ] bi or [
 177             initial: ,
 178             dup initial>> ,
 179         ] when
 180         drop
 181     ] { } make ;
 182
 183 : pprint-slot ( slot-spec -- )
 184     unparse-slot
 185     dup length 1 = [ first ] when
 186     pprint-slot-name ;
 187
 188 : tuple-declarations. ( class -- )
 189     \ final declaration. ;
 190
 191 : superclass. ( class -- )
 192     superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
 193
 194 M: tuple-class see-class*
 195     <colon \ TUPLE: pprint-word
 196     {
 197         [ pprint-word ]
 198         [ superclass. ]
 199         [ <block "slots" word-prop [ pprint-slot ] each block> pprint-; ]
 200         [ tuple-declarations. ]
 201     } cleave
 202     block> ;
 203
 204 M: word see-class* drop ;
 205
 206 M: builtin-class see-class*
 207     "! Built-in class" comment.
 208     <block
 209     \ PRIMITIVE: pprint-word
 210     [ pprint-word ]
 211     [ <block "slots" word-prop [ pprint-slot ] each pprint-; block> ] bi
 212     block> ;
 213
 214 : see-class ( class -- )
 215     dup class? [
 216         [
 217             [ seeing-word ] [ see-class* ] bi
 218         ] with-use
 219     ] [ drop ] if ;
 220
 221 M: word see*
 222     [ see-class ]
 223     [ [ class? ] [ symbol? not ] bi and [ nl nl ] when ]
 224     [
 225         dup [ class? ] [ symbol? ] bi and
 226         [ drop ] [ call-next-method ] if
 227     ] tri ;
 228
 229 : seeing-implementors ( class -- seq )
 230     dup implementors
 231     [ [ reader? ] [ writer? ] bi or not ] filter
 232     [ lookup-method ] with map
 233     natural-sort ;
 234
 235 : seeing-methods ( generic -- seq )
 236     "methods" word-prop values natural-sort ;
 237
 238 PRIVATE>
 239
 240 : see-all ( seq -- )
 241     natural-sort [ nl nl ] [ see* ] interleave ;
 242
 243 : methods ( word -- seq )
 244     [
 245         dup class? [ dup seeing-implementors % ] when
 246         dup generic? [ dup seeing-methods % ] when
 247         drop
 248     ] { } make set-members ;
 249
 250 : see-methods ( word -- )
 251     methods see-all nl ;