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