core/prettyprint/prettyprint.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: prettyprint
   4 USING: arrays generic generic.standard assocs io kernel
   5 math namespaces sequences strings io.styles io.streams.string
   6 vectors words prettyprint.backend prettyprint.sections
   7 prettyprint.config sorting splitting grouping math.parser vocabs
   8 definitions effects classes.builtin classes.tuple io.files
   9 classes continuations hashtables classes.mixin classes.union
  10 classes.intersection classes.predicate classes.singleton
  11 combinators quotations sets accessors ;
  12
  13 : make-pprint ( obj quot -- block in use )
  14     [
  15         0 position set
  16         H{ } clone pprinter-use set
  17         V{ } clone recursion-check set
  18         V{ } clone pprinter-stack set
  19         over <object
  20         call
  21         pprinter-block
  22         pprinter-in get
  23         pprinter-use get keys
  24     ] with-scope ; inline
  25
  26 : with-pprint ( obj quot -- )
  27     make-pprint 2drop do-pprint ; inline
  28
  29 : pprint-vocab ( vocab -- )
  30     dup vocab present-text ;
  31
  32 : write-in ( vocab -- )
  33     [ \ IN: pprint-word pprint-vocab ] with-pprint ;
  34
  35 : in. ( vocab -- )
  36     [ write-in nl ] when* ;
  37
  38 : use. ( seq -- )
  39     dup empty? [ drop ] [
  40         natural-sort [
  41             \ USING: pprint-word
  42             [ pprint-vocab ] each
  43             \ ; pprint-word
  44         ] with-pprint nl
  45     ] if ;
  46
  47 : vocabs. ( in use -- )
  48     dupd remove [ { "syntax" "scratchpad" } member? not ] filter
  49     use. in. ;
  50
  51 : with-use ( obj quot -- )
  52     make-pprint vocabs. do-pprint ; inline
  53
  54 : with-in ( obj quot -- )
  55     make-pprint drop [ write-in bl ] when* do-pprint ; inline
  56
  57 : pprint ( obj -- ) [ pprint* ] with-pprint ;
  58
  59 : . ( obj -- )
  60     H{
  61        { length-limit 1000 }
  62        { nesting-limit 10 }
  63     } clone [ pprint ] bind nl ;
  64
  65 : pprint-use ( obj -- ) [ pprint* ] with-use ;
  66
  67 : unparse ( obj -- str ) [ pprint ] with-string-writer ;
  68
  69 : unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
  70
  71 : pprint-short ( obj -- )
  72     H{
  73        { line-limit 1 }
  74        { length-limit 15 }
  75        { nesting-limit 2 }
  76        { string-limit t }
  77     } clone [ pprint ] bind ;
  78
  79 : unparse-short ( obj -- str )
  80     [ pprint-short ] with-string-writer ;
  81
  82 : short. ( obj -- ) pprint-short nl ;
  83
  84 : .b ( n -- ) >bin print ;
  85 : .o ( n -- ) >oct print ;
  86 : .h ( n -- ) >hex print ;
  87
  88 : stack. ( seq -- ) [ short. ] each ;
  89
  90 : .s ( -- ) datastack stack. ;
  91 : .r ( -- ) retainstack stack. ;
  92
  93 <PRIVATE
  94
  95 SYMBOL: ->
  96
  97 \ ->
  98 { { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
  99 "word-style" set-word-prop
 100
 101 : remove-step-into ( word -- )
 102     building get dup empty? [ drop ] [ nip pop wrapped>> ] if , ;
 103
 104 : (remove-breakpoints) ( quot -- newquot )
 105     [
 106         [
 107             {
 108                 { [ dup word? not ] [ , ] }
 109                 { [ dup "break?" word-prop ] [ drop ] }
 110                 { [ dup "step-into?" word-prop ] [ remove-step-into ] }
 111                 [ , ]
 112             } cond
 113         ] each
 114     ] [ ] make ;
 115
 116 : remove-breakpoints ( quot pos -- quot' )
 117     over quotation? [
 118         1+ cut [ (remove-breakpoints) ] bi@
 119         [ -> ] swap 3append
 120     ] [
 121         drop
 122     ] if ;
 123
 124 PRIVATE>
 125
 126 : callstack. ( callstack -- )
 127     callstack>array 2 <groups> [
 128         remove-breakpoints
 129         2 nesting-limit [ . ] with-variable
 130     ] assoc-each ;
 131
 132 : .c ( -- ) callstack callstack. ;
 133
 134 : pprint-cell ( obj -- ) [ pprint ] with-cell ;
 135
 136 GENERIC: see ( defspec -- )
 137
 138 : comment. ( string -- )
 139     [ H{ { font-style italic } } styled-text ] when* ;
 140
 141 : seeing-word ( word -- )
 142     vocabulary>> pprinter-in set ;
 143
 144 : definer. ( defspec -- )
 145     definer drop pprint-word ;
 146
 147 : stack-effect. ( word -- )
 148     [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
 149     [ effect>string comment. ] when* ;
 150
 151 : word-synopsis ( word -- )
 152     {
 153         [ seeing-word ]
 154         [ definer. ]
 155         [ pprint-word ]
 156         [ stack-effect. ]
 157     } cleave ;
 158
 159 M: word synopsis* word-synopsis ;
 160
 161 M: simple-generic synopsis* word-synopsis ;
 162
 163 M: standard-generic synopsis*
 164     {
 165         [ definer. ]
 166         [ seeing-word ]
 167         [ pprint-word ]
 168         [ dispatch# pprint* ]
 169         [ stack-effect. ]
 170     } cleave ;
 171
 172 M: hook-generic synopsis*
 173     {
 174         [ definer. ]
 175         [ seeing-word ]
 176         [ pprint-word ]
 177         [ "combination" word-prop hook-combination-var pprint* ]
 178         [ stack-effect. ]
 179     } cleave ;
 180
 181 M: method-spec synopsis*
 182     first2 method synopsis* ;
 183
 184 M: method-body synopsis*
 185     [ definer. ]
 186     [ "method-class" word-prop pprint-word ]
 187     [ "method-generic" word-prop pprint-word ] tri ;
 188
 189 M: mixin-instance synopsis*
 190     [ definer. ]
 191     [ class>> pprint-word ]
 192     [ mixin>> pprint-word ] tri ;
 193
 194 M: pathname synopsis* pprint* ;
 195
 196 : synopsis ( defspec -- str )
 197     [
 198         0 margin set
 199         1 line-limit set
 200         [ synopsis* ] with-in
 201     ] with-string-writer ;
 202
 203 : synopsis-alist ( definitions -- alist )
 204     [ dup synopsis swap ] { } map>assoc ;
 205
 206 : definitions. ( alist -- )
 207     [ write-object nl ] assoc-each ;
 208
 209 : sorted-definitions. ( definitions -- )
 210     synopsis-alist sort-keys definitions. ;
 211
 212 GENERIC: declarations. ( obj -- )
 213
 214 M: object declarations. drop ;
 215
 216 : declaration. ( word prop -- )
 217     tuck name>> word-prop [ pprint-word ] [ drop ] if ;
 218
 219 M: word declarations.
 220     {
 221         POSTPONE: parsing
 222         POSTPONE: delimiter
 223         POSTPONE: inline
 224         POSTPONE: foldable
 225         POSTPONE: flushable
 226     } [ declaration. ] with each ;
 227
 228 : pprint-; ( -- ) \ ; pprint-word ;
 229
 230 : (see) ( spec -- )
 231     <colon dup synopsis*
 232     <block dup definition pprint-elements block>
 233     dup definer nip [ pprint-word ] when* declarations.
 234     block> ;
 235
 236 M: object see
 237     [ (see) ] with-use nl ;
 238
 239 GENERIC: see-class* ( word -- )
 240
 241 M: union-class see-class*
 242     <colon \ UNION: pprint-word
 243     dup pprint-word
 244     members pprint-elements pprint-; block> ;
 245
 246 M: intersection-class see-class*
 247     <colon \ INTERSECTION: pprint-word
 248     dup pprint-word
 249     participants pprint-elements pprint-; block> ;
 250
 251 M: mixin-class see-class*
 252     <block \ MIXIN: pprint-word
 253     dup pprint-word <block
 254     dup members [
 255         hard line-break
 256         \ INSTANCE: pprint-word pprint-word pprint-word
 257     ] with each block> block> ;
 258
 259 M: predicate-class see-class*
 260     <colon \ PREDICATE: pprint-word
 261     dup pprint-word
 262     "<" text
 263     dup superclass pprint-word
 264     <block
 265     "predicate-definition" word-prop pprint-elements
 266     pprint-; block> block> ;
 267
 268 M: singleton-class see-class* ( class -- )
 269     \ SINGLETON: pprint-word pprint-word ;
 270
 271 M: tuple-class see-class*
 272     <colon \ TUPLE: pprint-word
 273     dup pprint-word
 274     dup superclass tuple eq? [
 275         "<" text dup superclass pprint-word
 276     ] unless
 277     slot-names [ text ] each
 278     pprint-; block> ;
 279
 280 M: word see-class* drop ;
 281
 282 M: builtin-class see-class*
 283     drop "! Built-in class" comment. ;
 284
 285 : see-all ( seq -- )
 286     natural-sort [ nl see ] each ;
 287
 288 : see-implementors ( class -- seq )
 289     dup implementors
 290     [ method ] with map
 291     natural-sort ;
 292
 293 : see-class ( class -- )
 294     dup class? [
 295         [
 296             dup seeing-word dup see-class*
 297         ] with-use nl
 298     ] when drop ;
 299
 300 : see-methods ( generic -- seq )
 301     "methods" word-prop values natural-sort ;
 302
 303 M: word see
 304     dup see-class
 305     dup class? over symbol? not and [
 306         nl
 307     ] when
 308     dup class? over symbol? and not [
 309         [ dup (see) ] with-use nl
 310     ] when
 311     [
 312         dup class? [ dup see-implementors % ] when
 313         dup generic? [ dup see-methods % ] when
 314         drop
 315     ] { } make prune see-all ;