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 sorting strings summary words
  10 words.symbol words.constant words.alias vocabs slots ;
  11 FROM: namespaces => set ;
  12 FROM: classes => members ;
  13 IN: see
  14
  15 GENERIC: synopsis* ( defspec -- )
  16
  17 GENERIC: see* ( defspec -- )
  18
  19 : see ( defspec -- ) see* nl ;
  20
  21 : synopsis ( defspec -- str )
  22     [
  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 [ 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-word ]
  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: word summary synopsis ;
  94
  95 GENERIC: declarations. ( obj -- )
  96
  97 M: object declarations. drop ;
  98
  99 : declaration. ( word prop -- )
 100     [ nip ] [ name>> word-prop ] 2bi
 101     [ pprint-word ] [ drop ] if ;
 102
 103 M: word declarations.
 104     {
 105         POSTPONE: delimiter
 106         POSTPONE: deprecated
 107         POSTPONE: inline
 108         POSTPONE: recursive
 109         POSTPONE: foldable
 110         POSTPONE: flushable
 111     } [ declaration. ] with each ;
 112
 113 : pprint-; ( -- ) \ ; pprint-word ;
 114
 115 M: object see*
 116     [
 117         12 nesting-limit set
 118         100 length-limit set
 119         <colon dup synopsis*
 120         <block dup definition pprint-elements block>
 121         dup definer nip [ pprint-word ] when* declarations.
 122         block>
 123     ] with-use ;
 124
 125 GENERIC: see-class* ( word -- )
 126
 127 M: union-class see-class*
 128     <colon \ UNION: pprint-word
 129     dup pprint-word
 130     members pprint-elements pprint-; block> ;
 131
 132 M: intersection-class see-class*
 133     <colon \ INTERSECTION: pprint-word
 134     dup pprint-word
 135     participants pprint-elements pprint-; block> ;
 136
 137 M: mixin-class see-class*
 138     <block \ MIXIN: pprint-word
 139     dup pprint-word <block
 140     dup members [
 141         hard line-break
 142         \ INSTANCE: pprint-word pprint-word pprint-word
 143     ] with each block> block> ;
 144
 145 M: predicate-class see-class*
 146     <colon \ PREDICATE: pprint-word
 147     dup pprint-word
 148     "<" text
 149     dup superclass pprint-word
 150     <block
 151     "predicate-definition" word-prop pprint-elements
 152     pprint-; block> block> ;
 153
 154 M: singleton-class see-class* ( class -- )
 155     \ SINGLETON: pprint-word pprint-word ;
 156
 157 GENERIC: pprint-slot-name ( object -- )
 158
 159 M: string pprint-slot-name text ;
 160
 161 M: array pprint-slot-name
 162     <flow \ { pprint-word
 163     f <inset unclip text pprint-elements block>
 164     \ } pprint-word block> ;
 165
 166 : unparse-slot ( slot-spec -- array )
 167     [
 168         dup name>> ,
 169         dup class>> object eq? [
 170             dup class>> ,
 171         ] unless
 172         dup read-only>> [
 173             read-only ,
 174         ] when
 175         dup [ class>> object eq? not ] [ initial>> ] bi or [
 176             initial: ,
 177             dup initial>> ,
 178         ] when
 179         drop
 180     ] { } make ;
 181
 182 : pprint-slot ( slot-spec -- )
 183     unparse-slot
 184     dup length 1 = [ first ] when
 185     pprint-slot-name ;
 186
 187 : tuple-declarations. ( class -- )
 188     \ final declaration. ;
 189
 190 : superclass. ( class -- )
 191     superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
 192
 193 M: tuple-class see-class*
 194     <colon \ TUPLE: pprint-word
 195     {
 196         [ pprint-word ]
 197         [ superclass. ]
 198         [ <block "slots" word-prop [ pprint-slot ] each block> pprint-; ]
 199         [ tuple-declarations. ]
 200     } cleave
 201     block> ;
 202
 203 M: word see-class* drop ;
 204
 205 M: builtin-class see-class*
 206     drop "! Built-in class" comment. ;
 207
 208 : see-class ( class -- )
 209     dup class? [
 210         [
 211             [ seeing-word ] [ see-class* ] bi
 212         ] with-use
 213     ] [ drop ] if ;
 214
 215 M: word see*
 216     [ see-class ]
 217     [ [ class? ] [ symbol? not ] bi and [ nl nl ] when ]
 218     [
 219         dup [ class? ] [ symbol? ] bi and
 220         [ drop ] [ call-next-method ] if
 221     ] tri ;
 222
 223 : seeing-implementors ( class -- seq )
 224     dup implementors
 225     [ [ reader? ] [ writer? ] bi or not ] filter
 226     [ method ] with map
 227     natural-sort ;
 228
 229 : seeing-methods ( generic -- seq )
 230     "methods" word-prop values natural-sort ;
 231
 232 PRIVATE>
 233
 234 : see-all ( seq -- )
 235     natural-sort [ nl nl ] [ see* ] interleave ;
 236
 237 : methods ( word -- seq )
 238     [
 239         dup class? [ dup seeing-implementors % ] when
 240         dup generic? [ dup seeing-methods % ] when
 241         drop
 242     ] { } make prune ;
 243
 244 : see-methods ( word -- )
 245     methods see-all nl ;