library/syntax/prettyprint.factor

   1 ! Copyright (C) 2003, 2005 Slava Pestov.
   2 ! See http://factor.sf.net/license.txt for BSD license.
   3 IN: prettyprint
   4 USING: alien generic hashtables io kernel lists math namespaces
   5 parser sequences strings styles vectors words ;
   6
   7 ! State
   8 SYMBOL: column
   9 SYMBOL: indent
  10 SYMBOL: last-newline
  11 SYMBOL: recursion-check
  12 SYMBOL: line-count
  13 SYMBOL: end-printing
  14
  15 ! Configuration
  16 SYMBOL: tab-size
  17 SYMBOL: margin
  18 SYMBOL: nesting-limit
  19 SYMBOL: length-limit
  20 SYMBOL: line-limit
  21 SYMBOL: string-limit
  22
  23 global [
  24     4 tab-size set
  25     64 margin set
  26     recursion-check off
  27     0 column set
  28     0 indent set
  29     0 last-newline set
  30     0 line-count set
  31     string-limit off
  32 ] bind
  33
  34 TUPLE: pprinter stack ;
  35
  36 GENERIC: pprint-section*
  37
  38 TUPLE: section start end nl-after? indent ;
  39
  40 C: section ( length -- section )
  41     >r column [ dup rot + dup ] change r>
  42     [ set-section-end ] keep
  43     [ set-section-start ] keep
  44     0 over set-section-indent ;
  45
  46 : section-fits? ( section -- ? )
  47     section-end last-newline get - indent get + margin get <= ;
  48
  49 : line-limit? ( -- ? )
  50     line-limit get dup [ line-count get <= ] when ;
  51
  52 : do-indent indent get CHAR: \s fill write ;
  53
  54 : fresh-line ( n -- )
  55     #! n is current column position.
  56     dup last-newline get = [
  57         drop
  58     ] [
  59         last-newline set
  60         line-count inc
  61         line-limit? [ "..." write end-printing get call ] when
  62         "\n" write do-indent
  63     ] ifte ;
  64
  65 TUPLE: text string style ;
  66
  67 C: text ( string style -- section )
  68     pick length 1 + <section> over set-delegate
  69     [ set-text-style ] keep
  70     [ set-text-string ] keep ;
  71
  72 M: text pprint-section*
  73     dup text-string swap text-style format ;
  74
  75 TUPLE: block sections ;
  76
  77 C: block ( -- block )
  78     0 <section> over set-delegate
  79     { } clone over set-block-sections
  80     t over set-section-nl-after?
  81     tab-size get over set-section-indent ;
  82
  83 : pprinter-block pprinter-stack peek ;
  84
  85 : block-empty? ( section -- ? )
  86     dup block? [ block-sections empty? ] [ drop f ] ifte ;
  87
  88 : add-section ( section stream -- )
  89     over block-empty? [
  90         2drop
  91     ] [
  92         pprinter-block block-sections push
  93     ] ifte ;
  94
  95 : text ( string style -- ) <text> pprinter get add-section ;
  96
  97 : <indent ( section -- ) section-indent indent [ + ] change ;
  98
  99 : indent> ( section -- ) section-indent indent [ swap - ] change ;
 100
 101 : inset-section ( section -- )
 102     dup <indent
 103     dup section-start fresh-line dup pprint-section*
 104     dup indent>
 105     dup section-nl-after?
 106     [ section-end fresh-line ] [ drop ] ifte ;
 107
 108 : pprint-section ( section -- )
 109     dup section-fits?
 110     [ pprint-section* ] [ inset-section ] ifte ;
 111
 112 TUPLE: newline ;
 113
 114 C: newline ( -- section )
 115     0 <section> over set-delegate ;
 116
 117 M: newline pprint-section* ( newline -- )
 118     section-start fresh-line ;
 119
 120 : advance ( section -- )
 121     dup newline? [
 122         drop
 123     ] [
 124         section-start last-newline get = [ " " write ] unless
 125     ] ifte ;
 126
 127 M: block pprint-section* ( block -- )
 128     f swap block-sections [
 129         over [ dup advance ] when pprint-section drop t
 130     ] each drop ;
 131
 132 : <block ( -- ) <block> pprinter get pprinter-stack push ;
 133
 134 : newline ( -- ) <newline> pprinter get add-section ;
 135
 136 : end-block ( block -- ) column get swap set-section-end ;
 137
 138 : pop-block ( pprinter -- ) pprinter-stack pop drop ;
 139
 140 : (block>) ( -- )
 141     pprinter get dup pprinter-block
 142     dup end-block swap dup pop-block add-section ;
 143
 144 : last-block? ( -- ? )
 145     pprinter get pprinter-stack length 1 = ;
 146
 147 : block> ( -- )
 148     #! Protect against malformed <block ... block> forms.
 149     last-block? [ (block>) ] unless ;
 150
 151 : block; ( -- )
 152     pprinter get pprinter-block f swap set-section-nl-after?
 153     block> ;
 154
 155 : end-blocks ( -- ) last-block? [ (block>) end-blocks ] unless ;
 156
 157 C: pprinter ( -- stream )
 158     <block> 1vector over set-pprinter-stack ;
 159
 160 : do-pprint ( pprinter -- )
 161     [
 162         end-printing set
 163         dup pprinter-block pprint-section
 164         end-blocks
 165     ] callcc0 drop ;
 166
 167 GENERIC: pprint* ( obj -- )
 168
 169 : vocab-style ( vocab -- style )
 170     {{
 171         [[ "syntax" [ [[ foreground [ 128 128 128 ] ]] ] ]]
 172         [[ "kernel" [ [[ foreground [ 0 0 128 ] ]] ] ]]
 173         [[ "sequences" [ [[ foreground [ 128 0 0 ] ]] ] ]]
 174         [[ "math" [ [[ foreground [ 0 128 0 ] ]] ] ]]
 175         [[ "math-internals" [ [[ foreground [ 192 0 0 ] ]] ] ]]
 176         [[ "kernel-internals" [ [[ foreground [ 192 0 0 ] ]] ] ]]
 177         [[ "io-internals" [ [[ foreground [ 192 0 0 ] ]] ] ]]
 178     }} hash ;
 179
 180 : word-style ( word -- style )
 181     dup word-vocabulary vocab-style swap presented swons add ;
 182
 183 : pprint-word ( obj -- )
 184     dup word-name [ "( unnamed )" ] unless*
 185     swap word-style text ;
 186
 187 M: object pprint* ( obj -- )
 188     "( unprintable object: " swap class word-name " )" append3
 189     f text ;
 190
 191 M: real pprint* ( obj -- ) number>string f text ;
 192
 193 : ch>ascii-escape ( ch -- esc )
 194     {{
 195         [[ CHAR: \e "\\e"  ]]
 196         [[ CHAR: \n "\\n"  ]]
 197         [[ CHAR: \r "\\r"  ]]
 198         [[ CHAR: \t "\\t"  ]]
 199         [[ CHAR: \0 "\\0"  ]]
 200         [[ CHAR: \\ "\\\\" ]]
 201         [[ CHAR: \" "\\\"" ]]
 202     }} hash ;
 203
 204 : ch>unicode-escape ( ch -- esc )
 205     >hex 4 CHAR: 0 pad-left "\\u" swap append ;
 206
 207 : unparse-ch ( ch -- ch/str )
 208     dup quotable? [
 209         ,
 210     ] [
 211         dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?ifte %
 212     ] ifte ;
 213
 214 : do-string-limit ( string -- string )
 215     string-limit get [
 216         dup length margin get > [
 217             margin get 3 - swap head "..." append
 218         ] when
 219     ] when ;
 220
 221 : pprint-string ( string prefix -- )
 222     [ % [ unparse-ch ] each CHAR: " , ] "" make
 223     do-string-limit f text ;
 224
 225 M: string pprint* ( str -- str ) "\"" pprint-string ;
 226
 227 M: sbuf pprint* ( str -- str ) "SBUF\" " pprint-string ;
 228
 229 M: word pprint* ( word -- )
 230     dup "pprint-before-hook" word-prop call
 231     dup pprint-word
 232     "pprint-after-hook" word-prop call ;
 233
 234 M: t pprint* drop "t" f text ;
 235
 236 M: f pprint* drop "f" f text ;
 237
 238 M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
 239
 240 : nesting-limit? ( -- ? )
 241     nesting-limit get dup
 242     [ pprinter get pprinter-stack length < ] when ;
 243
 244 : check-recursion ( obj quot -- indent )
 245     #! We detect circular structure.
 246     nesting-limit? [
 247         2drop "#" f text
 248     ] [
 249         over recursion-check get memq? [
 250             2drop "&" f text
 251         ] [
 252             over recursion-check [ cons ] change
 253             call
 254             recursion-check [ cdr ] change
 255         ] ifte
 256     ] ifte ; inline
 257
 258 : length-limit? ( seq -- seq ? )
 259     length-limit get dup
 260     [ swap 2dup length < [ head t ] [ nip f ] ifte ]
 261     [ drop f ] ifte ;
 262
 263 : pprint-element ( object -- )
 264     dup parsing? [ \ POSTPONE: pprint-word ] when pprint* ;
 265
 266 : pprint-elements ( seq -- )
 267     length-limit? >r
 268     [ pprint-element ] each
 269     r> [ "... " f text ] when ;
 270
 271 : pprint-sequence ( seq start end -- )
 272     swap pprint* swap pprint-elements pprint* ;
 273
 274 M: complex pprint* ( num -- )
 275     >rect 2vector \ #{ \ }# pprint-sequence ;
 276
 277 M: cons pprint* ( list -- )
 278    [
 279        dup list? [ \ [ \ ] ] [ uncons 2vector \ [[ \ ]] ] ifte
 280        pprint-sequence
 281    ] check-recursion ;
 282
 283 M: vector pprint* ( vector -- )
 284     [ \ { \ } pprint-sequence ] check-recursion ;
 285
 286 M: hashtable pprint* ( hashtable -- )
 287     [ hash>alist \ {{ \ }} pprint-sequence ] check-recursion ;
 288
 289 M: tuple pprint* ( tuple -- )
 290     [
 291         \ << pprint*
 292         <mirror> dup first pprint*
 293         <block 1 swap tail-slice pprint-elements block>
 294         \ >> pprint*
 295     ] check-recursion ;
 296
 297 M: alien pprint* ( alien -- )
 298     dup expired? [
 299         drop "( alien expired )"
 300     ] [
 301         \ ALIEN: pprint-word alien-address number>string
 302     ] ifte f text ;
 303
 304 M: wrapper pprint* ( wrapper -- )
 305     dup wrapped word? [
 306         \ \ pprint-word wrapped pprint-word
 307     ] [
 308         wrapped 1vector \ W[ \ ]W pprint-sequence
 309     ] ifte ;
 310
 311 : with-pprint ( quot -- )
 312     [
 313         <pprinter> pprinter set call end-blocks
 314         pprinter get do-pprint
 315     ] with-scope ; inline
 316
 317 : pprint ( object -- ) [ pprint* ] with-pprint ;
 318
 319 : unparse ( object -- str ) [ pprint ] string-out ;
 320
 321 : . ( obj -- ) pprint terpri ;
 322
 323 : pprint-short ( object -- string )
 324     [
 325         1 line-limit set
 326         20 length-limit set
 327         2 nesting-limit set
 328         string-limit on
 329         pprint
 330     ] with-scope ;
 331
 332 : unparse-short ( object -- str ) [ pprint-short ] string-out ;
 333
 334 : short. ( object -- )
 335     dup unparse-short swap write-object terpri ;
 336
 337 : sequence. ( sequence -- ) [ short. ] each ;
 338
 339 : stack. ( sequence -- ) reverse-slice sequence. ;
 340
 341 : .s datastack stack. ;
 342 : .r callstack stack. ;
 343
 344 ! For integers only
 345 : .b >bin print ;
 346 : .o >oct print ;
 347 : .h >hex print ;
 348
 349 : define-open
 350     #! The word will be pretty-printed as a block opener.
 351     #! Examples are [ { {{ [[ << and so on.
 352     [ <block ] "pprint-after-hook" set-word-prop ;
 353
 354 : define-close ( word -- )
 355     #! The word will be pretty-printed as a block closer.
 356     #! Examples are ] } }} ]] >> and so on.
 357     [ block> ] "pprint-before-hook" set-word-prop ;
 358
 359 {
 360     { POSTPONE: [ POSTPONE: ] }
 361     { POSTPONE: { POSTPONE: } }
 362     { POSTPONE: {{ POSTPONE: }} }
 363     { POSTPONE: [[ POSTPONE: ]] }
 364     { POSTPONE: [[ POSTPONE: ]] }
 365 } [ first2 define-close define-open ] each