basis/prettyprint/prettyprint.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   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 colors ;
  12
  13 IN: prettyprint
  14
  15 : make-pprint ( obj quot -- block in use )
  16     [
  17         0 position set
  18         H{ } clone pprinter-use set
  19         V{ } clone recursion-check set
  20         V{ } clone pprinter-stack set
  21         over <object
  22         call
  23         pprinter-block
  24         pprinter-in get
  25         pprinter-use get keys
  26     ] with-scope ; inline
  27
  28 : with-pprint ( obj quot -- )
  29     make-pprint 2drop do-pprint ; inline
  30
  31 : pprint-vocab ( vocab -- )
  32     dup vocab present-text ;
  33
  34 : write-in ( vocab -- )
  35     [ \ IN: pprint-word pprint-vocab ] with-pprint ;
  36
  37 : in. ( vocab -- )
  38     [ write-in nl ] when* ;
  39
  40 : use. ( seq -- )
  41     [
  42         natural-sort [
  43             \ USING: pprint-word
  44             [ pprint-vocab ] each
  45             \ ; pprint-word
  46         ] with-pprint nl
  47     ] unless-empty ;
  48
  49 : vocabs. ( in use -- )
  50     dupd remove [ { "syntax" "scratchpad" } member? not ] filter
  51     use. in. ;
  52
  53 : with-use ( obj quot -- )
  54     make-pprint vocabs. do-pprint ; inline
  55
  56 : with-in ( obj quot -- )
  57     make-pprint drop [ write-in bl ] when* do-pprint ; inline
  58
  59 : pprint ( obj -- ) [ pprint* ] with-pprint ;
  60
  61 : . ( obj -- ) pprint nl ;
  62
  63 : pprint-use ( obj -- ) [ pprint* ] with-use ;
  64
  65 : unparse ( obj -- str ) [ pprint ] with-string-writer ;
  66
  67 : unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
  68
  69 : pprint-short ( obj -- )
  70     H{
  71        { line-limit 1 }
  72        { length-limit 15 }
  73        { nesting-limit 2 }
  74        { string-limit? t }
  75        { boa-tuples? t }
  76     } clone [ pprint ] bind ;
  77
  78 : unparse-short ( obj -- str )
  79     [ pprint-short ] with-string-writer ;
  80
  81 : short. ( obj -- ) pprint-short nl ;
  82
  83 : .b ( n -- ) >bin print ;
  84 : .o ( n -- ) >oct print ;
  85 : .h ( n -- ) >hex print ;
  86
  87 : stack. ( seq -- ) [ short. ] each ;
  88
  89 : .s ( -- ) datastack stack. ;
  90 : .r ( -- ) retainstack stack. ;
  91
  92 <PRIVATE
  93
  94 SYMBOL: ->
  95
  96 \ ->
  97 { { foreground T{ rgba f 1 1 1 1 } } { background T{ rgba f 0 0 0 1 } } }
  98 "word-style" set-word-prop
  99
 100 : remove-step-into ( word -- )
 101     building get [ nip pop wrapped>> ] unless-empty , ;
 102
 103 : (remove-breakpoints) ( quot -- newquot )
 104     [
 105         [
 106             {
 107                 { [ dup word? not ] [ , ] }
 108                 { [ dup "break?" word-prop ] [ drop ] }
 109                 { [ dup "step-into?" word-prop ] [ remove-step-into ] }
 110                 [ , ]
 111             } cond
 112         ] each
 113     ] [ ] make ;
 114
 115 : remove-breakpoints ( quot pos -- quot' )
 116     over quotation? [
 117         1+ cut [ (remove-breakpoints) ] bi@
 118         [ -> ] swap 3append
 119     ] [
 120         drop
 121     ] if ;
 122
 123 PRIVATE>
 124
 125 : callstack. ( callstack -- )
 126     callstack>array 2 <groups> [
 127         remove-breakpoints
 128         3 nesting-limit [ . ] with-variable
 129     ] assoc-each ;
 130
 131 : .c ( -- ) callstack callstack. ;
 132
 133 : pprint-cell ( obj -- ) [ pprint ] with-cell ;
 134
 135 GENERIC: see ( defspec -- )
 136
 137 : comment. ( string -- )
 138     [ H{ { font-style italic } } styled-text ] when* ;
 139
 140 : seeing-word ( word -- )
 141     vocabulary>> pprinter-in set ;
 142
 143 : definer. ( defspec -- )
 144     definer drop pprint-word ;
 145
 146 : stack-effect. ( word -- )
 147     [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
 148     [ effect>string comment. ] when* ;
 149
 150 : word-synopsis ( word -- )
 151     {
 152         [ seeing-word ]
 153         [ definer. ]
 154         [ pprint-word ]
 155         [ stack-effect. ]
 156     } cleave ;
 157
 158 M: word synopsis* word-synopsis ;
 159
 160 M: simple-generic synopsis* word-synopsis ;
 161
 162 M: standard-generic synopsis*
 163     {
 164         [ definer. ]
 165         [ seeing-word ]
 166         [ pprint-word ]
 167         [ dispatch# pprint* ]
 168         [ stack-effect. ]
 169     } cleave ;
 170
 171 M: hook-generic synopsis*
 172     {
 173         [ definer. ]
 174         [ seeing-word ]
 175         [ pprint-word ]
 176         [ "combination" word-prop var>> pprint* ]
 177         [ stack-effect. ]
 178     } cleave ;
 179
 180 M: method-spec synopsis*
 181     first2 method synopsis* ;
 182
 183 M: method-body synopsis*
 184     [ definer. ]
 185     [ "method-class" word-prop pprint-word ]
 186     [ "method-generic" word-prop pprint-word ] tri ;
 187
 188 M: mixin-instance synopsis*
 189     [ definer. ]
 190     [ class>> pprint-word ]
 191     [ mixin>> pprint-word ] tri ;
 192
 193 M: pathname synopsis* pprint* ;
 194
 195 : synopsis ( defspec -- str )
 196     [
 197         0 margin set
 198         1 line-limit set
 199         [ synopsis* ] with-in
 200     ] with-string-writer ;
 201
 202 : synopsis-alist ( definitions -- alist )
 203     [ dup synopsis swap ] { } map>assoc ;
 204
 205 : definitions. ( alist -- )
 206     [ write-object nl ] assoc-each ;
 207
 208 : sorted-definitions. ( definitions -- )
 209     synopsis-alist sort-keys definitions. ;
 210
 211 GENERIC: declarations. ( obj -- )
 212
 213 M: object declarations. drop ;
 214
 215 : declaration. ( word prop -- )
 216     tuck name>> word-prop [ pprint-word ] [ drop ] if ;
 217
 218 M: word declarations.
 219     {
 220         POSTPONE: parsing
 221         POSTPONE: delimiter
 222         POSTPONE: inline
 223         POSTPONE: recursive
 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 GENERIC: pprint-slot-name ( object -- )
 272
 273 M: string pprint-slot-name text ;
 274
 275 M: array pprint-slot-name
 276     <flow \ { pprint-word
 277     f <inset unclip text pprint-elements block>
 278     \ } pprint-word block> ;
 279
 280 : unparse-slot ( slot-spec -- array )
 281     [
 282         dup name>> ,
 283         dup class>> object eq? [
 284             dup class>> ,
 285             initial: ,
 286             dup initial>> ,
 287         ] unless
 288         dup read-only>> [
 289             read-only ,
 290         ] when
 291         drop
 292     ] { } make ;
 293
 294 : pprint-slot ( slot-spec -- )
 295     unparse-slot
 296     dup length 1 = [ first ] when
 297     pprint-slot-name ;
 298
 299 M: tuple-class see-class*
 300     <colon \ TUPLE: pprint-word
 301     dup pprint-word
 302     dup superclass tuple eq? [
 303         "<" text dup superclass pprint-word
 304     ] unless
 305     <block "slots" word-prop [ pprint-slot ] each block>
 306     pprint-; block> ;
 307
 308 M: word see-class* drop ;
 309
 310 M: builtin-class see-class*
 311     drop "! Built-in class" comment. ;
 312
 313 : see-class ( class -- )
 314     dup class? [
 315         [
 316             dup seeing-word dup see-class*
 317         ] with-use nl
 318     ] when drop ;
 319
 320 M: word see
 321     dup see-class
 322     dup class? over symbol? not and [
 323         nl
 324     ] when
 325     dup class? over symbol? and not [
 326         [ dup (see) ] with-use nl
 327     ] when
 328     drop ;
 329
 330 : see-all ( seq -- )
 331     natural-sort [ nl ] [ see ] interleave ;
 332
 333 : (see-implementors) ( class -- seq )
 334     dup implementors [ method ] with map natural-sort ;
 335
 336 : (see-methods) ( generic -- seq )
 337     "methods" word-prop values natural-sort ;
 338
 339 : see-methods ( word -- )
 340     [
 341         dup class? [ dup (see-implementors) % ] when
 342         dup generic? [ dup (see-methods) % ] when
 343         drop
 344     ] { } make prune see-all ;