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 words.symbol prettyprint.backend prettyprint.custom
   6 prettyprint.sections prettyprint.config sorting splitting
   7 grouping math.parser vocabs definitions effects classes.builtin
   8 classes.tuple io.pathnames classes continuations hashtables
   9 classes.mixin classes.union classes.intersection
  10 classes.predicate classes.singleton combinators quotations sets
  11 accessors colors parser summary vocabs.parser ;
  12 IN: prettyprint
  13
  14 : make-pprint ( obj quot -- block in use )
  15     [
  16         0 position set
  17         H{ } clone pprinter-use set
  18         V{ } clone recursion-check set
  19         V{ } clone pprinter-stack set
  20         over <object
  21         call
  22         pprinter-block
  23         pprinter-in get
  24         pprinter-use get keys
  25     ] with-scope ; inline
  26
  27 : with-pprint ( obj quot -- )
  28     make-pprint 2drop do-pprint ; inline
  29
  30 : pprint-vocab ( vocab -- )
  31     dup vocab present-text ;
  32
  33 : write-in ( vocab -- )
  34     [ \ IN: pprint-word pprint-vocab ] with-pprint ;
  35
  36 : in. ( vocab -- )
  37     [ write-in nl ] when* ;
  38
  39 : use. ( seq -- )
  40     [
  41         natural-sort [
  42             \ USING: pprint-word
  43             [ pprint-vocab ] each
  44             \ ; pprint-word
  45         ] with-pprint nl
  46     ] unless-empty ;
  47
  48 : use/in. ( in use -- )
  49     dupd remove [ { "syntax" "scratchpad" } member? not ] filter
  50     use. in. ;
  51
  52 : vocab-names ( words -- vocabs )
  53     dictionary get
  54     [ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
  55
  56 : prelude. ( -- )
  57     in get use get vocab-names use/in. ;
  58
  59 [
  60     nl
  61     "Restarts were invoked adding vocabularies to the search path." print
  62     "To avoid doing this in the future, add the following USING:" print
  63     "and IN: forms at the top of the source file:" print nl
  64     prelude.
  65     nl
  66 ] print-use-hook set-global
  67
  68 : with-use ( obj quot -- )
  69     make-pprint use/in. do-pprint ; inline
  70
  71 : with-in ( obj quot -- )
  72     make-pprint drop [ write-in bl ] when* do-pprint ; inline
  73
  74 : pprint ( obj -- ) [ pprint* ] with-pprint ;
  75
  76 : . ( obj -- ) pprint nl ;
  77
  78 : pprint-use ( obj -- ) [ pprint* ] with-use ;
  79
  80 : unparse ( obj -- str ) [ pprint ] with-string-writer ;
  81
  82 : unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
  83
  84 : pprint-short ( obj -- )
  85     H{
  86        { line-limit 1 }
  87        { length-limit 15 }
  88        { nesting-limit 2 }
  89        { string-limit? t }
  90        { boa-tuples? t }
  91     } clone [ pprint ] bind ;
  92
  93 : unparse-short ( obj -- str )
  94     [ pprint-short ] with-string-writer ;
  95
  96 : short. ( obj -- ) pprint-short nl ;
  97
  98 : .b ( n -- ) >bin print ;
  99 : .o ( n -- ) >oct print ;
 100 : .h ( n -- ) >hex print ;
 101
 102 : stack. ( seq -- ) [ short. ] each ;
 103
 104 : .s ( -- ) datastack stack. ;
 105 : .r ( -- ) retainstack stack. ;
 106
 107 <PRIVATE
 108
 109 SYMBOL: ->
 110
 111 \ ->
 112 { { foreground T{ rgba f 1 1 1 1 } } { background T{ rgba f 0 0 0 1 } } }
 113 "word-style" set-word-prop
 114
 115 : remove-step-into ( word -- )
 116     building get [ nip pop wrapped>> ] unless-empty , ;
 117
 118 : (remove-breakpoints) ( quot -- newquot )
 119     [
 120         [
 121             {
 122                 { [ dup word? not ] [ , ] }
 123                 { [ dup "break?" word-prop ] [ drop ] }
 124                 { [ dup "step-into?" word-prop ] [ remove-step-into ] }
 125                 [ , ]
 126             } cond
 127         ] each
 128     ] [ ] make ;
 129
 130 : remove-breakpoints ( quot pos -- quot' )
 131     over quotation? [
 132         1+ cut [ (remove-breakpoints) ] bi@
 133         [ -> ] glue
 134     ] [
 135         drop
 136     ] if ;
 137
 138 PRIVATE>
 139
 140 : callstack. ( callstack -- )
 141     callstack>array 2 <groups> [
 142         remove-breakpoints
 143         [
 144             3 nesting-limit set
 145             100 length-limit set
 146             .
 147         ] with-scope
 148     ] assoc-each ;
 149
 150 : .c ( -- ) callstack callstack. ;
 151
 152 : pprint-cell ( obj -- ) [ pprint ] with-cell ;
 153
 154 : simple-table. ( values -- )
 155     standard-table-style [
 156         [
 157             [
 158                 [
 159                     dup string?
 160                     [ [ write ] with-cell ]
 161                     [ pprint-cell ]
 162                     if
 163                 ] each
 164             ] with-row
 165         ] each
 166     ] tabular-output ;
 167
 168 GENERIC: see ( defspec -- )
 169
 170 : comment. ( string -- )
 171     [ H{ { font-style italic } } styled-text ] when* ;
 172
 173 : seeing-word ( word -- )
 174     vocabulary>> pprinter-in set ;
 175
 176 : definer. ( defspec -- )
 177     definer drop pprint-word ;
 178
 179 : stack-effect. ( word -- )
 180     [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
 181     [ effect>string comment. ] when* ;
 182
 183 : word-synopsis ( word -- )
 184     {
 185         [ seeing-word ]
 186         [ definer. ]
 187         [ pprint-word ]
 188         [ stack-effect. ]
 189     } cleave ;
 190
 191 M: word synopsis* word-synopsis ;
 192
 193 M: simple-generic synopsis* word-synopsis ;
 194
 195 M: standard-generic synopsis*
 196     {
 197         [ definer. ]
 198         [ seeing-word ]
 199         [ pprint-word ]
 200         [ dispatch# pprint* ]
 201         [ stack-effect. ]
 202     } cleave ;
 203
 204 M: hook-generic synopsis*
 205     {
 206         [ definer. ]
 207         [ seeing-word ]
 208         [ pprint-word ]
 209         [ "combination" word-prop var>> pprint* ]
 210         [ stack-effect. ]
 211     } cleave ;
 212
 213 M: method-spec synopsis*
 214     first2 method synopsis* ;
 215
 216 M: method-body synopsis*
 217     [ definer. ]
 218     [ "method-class" word-prop pprint-word ]
 219     [ "method-generic" word-prop pprint-word ] tri ;
 220
 221 M: mixin-instance synopsis*
 222     [ definer. ]
 223     [ class>> pprint-word ]
 224     [ mixin>> pprint-word ] tri ;
 225
 226 M: pathname synopsis* pprint* ;
 227
 228 : synopsis ( defspec -- str )
 229     [
 230         0 margin set
 231         1 line-limit set
 232         [ synopsis* ] with-in
 233     ] with-string-writer ;
 234
 235 M: word summary synopsis ;
 236
 237 : synopsis-alist ( definitions -- alist )
 238     [ dup synopsis swap ] { } map>assoc ;
 239
 240 : definitions. ( alist -- )
 241     [ write-object nl ] assoc-each ;
 242
 243 : sorted-definitions. ( definitions -- )
 244     synopsis-alist sort-keys definitions. ;
 245
 246 GENERIC: declarations. ( obj -- )
 247
 248 M: object declarations. drop ;
 249
 250 : declaration. ( word prop -- )
 251     [ nip ] [ name>> word-prop ] 2bi
 252     [ pprint-word ] [ drop ] if ;
 253
 254 M: word declarations.
 255     {
 256         POSTPONE: parsing
 257         POSTPONE: delimiter
 258         POSTPONE: inline
 259         POSTPONE: recursive
 260         POSTPONE: foldable
 261         POSTPONE: flushable
 262     } [ declaration. ] with each ;
 263
 264 : pprint-; ( -- ) \ ; pprint-word ;
 265
 266 M: object see
 267     [
 268         12 nesting-limit set
 269         100 length-limit set
 270         <colon dup synopsis*
 271         <block dup definition pprint-elements block>
 272         dup definer nip [ pprint-word ] when* declarations.
 273         block>
 274     ] with-use nl ;
 275
 276 M: method-spec see
 277     first2 method see ;
 278
 279 GENERIC: see-class* ( word -- )
 280
 281 M: union-class see-class*
 282     <colon \ UNION: pprint-word
 283     dup pprint-word
 284     members pprint-elements pprint-; block> ;
 285
 286 M: intersection-class see-class*
 287     <colon \ INTERSECTION: pprint-word
 288     dup pprint-word
 289     participants pprint-elements pprint-; block> ;
 290
 291 M: mixin-class see-class*
 292     <block \ MIXIN: pprint-word
 293     dup pprint-word <block
 294     dup members [
 295         hard line-break
 296         \ INSTANCE: pprint-word pprint-word pprint-word
 297     ] with each block> block> ;
 298
 299 M: predicate-class see-class*
 300     <colon \ PREDICATE: pprint-word
 301     dup pprint-word
 302     "<" text
 303     dup superclass pprint-word
 304     <block
 305     "predicate-definition" word-prop pprint-elements
 306     pprint-; block> block> ;
 307
 308 M: singleton-class see-class* ( class -- )
 309     \ SINGLETON: pprint-word pprint-word ;
 310
 311 GENERIC: pprint-slot-name ( object -- )
 312
 313 M: string pprint-slot-name text ;
 314
 315 M: array pprint-slot-name
 316     <flow \ { pprint-word
 317     f <inset unclip text pprint-elements block>
 318     \ } pprint-word block> ;
 319
 320 : unparse-slot ( slot-spec -- array )
 321     [
 322         dup name>> ,
 323         dup class>> object eq? [
 324             dup class>> ,
 325             initial: ,
 326             dup initial>> ,
 327         ] unless
 328         dup read-only>> [
 329             read-only ,
 330         ] when
 331         drop
 332     ] { } make ;
 333
 334 : pprint-slot ( slot-spec -- )
 335     unparse-slot
 336     dup length 1 = [ first ] when
 337     pprint-slot-name ;
 338
 339 M: tuple-class see-class*
 340     <colon \ TUPLE: pprint-word
 341     dup pprint-word
 342     dup superclass tuple eq? [
 343         "<" text dup superclass pprint-word
 344     ] unless
 345     <block "slots" word-prop [ pprint-slot ] each block>
 346     pprint-; block> ;
 347
 348 M: word see-class* drop ;
 349
 350 M: builtin-class see-class*
 351     drop "! Built-in class" comment. ;
 352
 353 : see-class ( class -- )
 354     dup class? [
 355         [
 356             dup seeing-word dup see-class*
 357         ] with-use nl
 358     ] when drop ;
 359
 360 M: word see
 361     [ see-class ]
 362     [ [ class? ] [ symbol? not ] bi and [ nl ] when ]
 363     [
 364         dup [ class? ] [ symbol? ] bi and
 365         [ drop ] [ call-next-method ] if
 366     ] tri ;
 367
 368 : see-all ( seq -- )
 369     natural-sort [ nl ] [ see ] interleave ;
 370
 371 : (see-implementors) ( class -- seq )
 372     dup implementors [ method ] with map natural-sort ;
 373
 374 : (see-methods) ( generic -- seq )
 375     "methods" word-prop values natural-sort ;
 376
 377 : methods ( word -- seq )
 378     [
 379         dup class? [ dup (see-implementors) % ] when
 380         dup generic? [ dup (see-methods) % ] when
 381         drop
 382     ] { } make prune ;
 383
 384 : see-methods ( word -- )
 385     methods see-all ;