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