basis/prettyprint/prettyprint.factor

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