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