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