basis/prettyprint/prettyprint.factor

   1 ! Copyright (C) 2003, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays accessors assocs colors combinators grouping io
   4 io.streams.string io.styles kernel make math math.parser namespaces
   5 parser prettyprint.backend prettyprint.config prettyprint.custom
   6 prettyprint.sections quotations sequences sorting strings vocabs
   7 vocabs.prettyprint words sets generic ;
   8 FROM: namespaces => set ;
   9 IN: prettyprint
  10
  11 : with-use ( obj quot -- )
  12     make-pprint (pprint-manifest
  13     [ pprint-manifest) ] [ [ drop nl ] unless-empty ] bi
  14     do-pprint ; inline
  15
  16 : with-in ( obj quot -- )
  17     make-pprint current-vocab>> [ pprint-in bl ] when* do-pprint ; inline
  18
  19 : pprint ( obj -- ) [ pprint* ] with-pprint ;
  20
  21 : . ( obj -- ) pprint nl ;
  22
  23 : pprint-use ( obj -- ) [ pprint* ] with-use ;
  24
  25 : unparse ( obj -- str ) [ pprint ] with-string-writer ;
  26
  27 : unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
  28
  29 : pprint-short ( obj -- )
  30     [ pprint ] with-short-limits ;
  31
  32 : unparse-short ( obj -- str )
  33     [ pprint-short ] with-string-writer ;
  34
  35 : short. ( obj -- ) pprint-short nl ;
  36
  37 : .b ( n -- ) >bin print ;
  38 : .o ( n -- ) >oct print ;
  39 : .h ( n -- ) >hex print ;
  40
  41 : stack. ( seq -- ) [ short. ] each ;
  42
  43 : .s ( -- ) datastack stack. ;
  44 : .r ( -- ) retainstack stack. ;
  45
  46 <PRIVATE
  47
  48 SYMBOL: ->
  49
  50 \ ->
  51 { { foreground T{ rgba f 1 1 1 1 } } { background T{ rgba f 0 0 0 1 } } }
  52 "word-style" set-word-prop
  53
  54 : remove-step-into ( word -- )
  55     building get [ nip pop wrapped>> ] unless-empty , ;
  56
  57 : (remove-breakpoints) ( quot -- newquot )
  58     [
  59         [
  60             {
  61                 { [ dup word? not ] [ , ] }
  62                 { [ dup "break?" word-prop ] [ drop ] }
  63                 { [ dup "step-into?" word-prop ] [ remove-step-into ] }
  64                 [ , ]
  65             } cond
  66         ] each
  67     ] [ ] make ;
  68
  69 : remove-breakpoints ( quot pos -- quot' )
  70     1 + short cut [ (remove-breakpoints) ] bi@ [ -> ] glue ;
  71
  72 : optimized-frame? ( triple -- ? ) second word? ;
  73
  74 : frame-word? ( triple -- ? )
  75     first word? ;
  76
  77 : frame-word. ( triple -- )
  78     first {
  79         { [ dup method? ] [ "Method: " write pprint ] }
  80         { [ dup word? ] [ "Word: " write pprint ] }
  81         [ drop ]
  82     } cond ;
  83
  84 : optimized-frame. ( triple -- )
  85     [
  86         [ "(O)" write ] with-cell
  87         [ frame-word. ] with-cell
  88     ] with-row ;
  89
  90 : unoptimized-frame. ( triple -- )
  91     [
  92         [ "(U)" write ] with-cell
  93         [
  94             "Quotation: " write
  95             dup [ second ] [ third ] bi remove-breakpoints
  96             [
  97                 3 nesting-limit set
  98                 100 length-limit set
  99                 pprint
 100             ] with-scope
 101         ] with-cell
 102     ] with-row
 103     dup frame-word? [
 104         [
 105             [ ] with-cell
 106             [ frame-word. ] with-cell
 107         ] with-row
 108     ] [ drop ] if ;
 109
 110 : callframe. ( triple -- )
 111     dup optimized-frame?
 112     [ optimized-frame. ] [ unoptimized-frame. ] if ;
 113
 114 PRIVATE>
 115
 116 : callstack. ( callstack -- )
 117     callstack>array 3 <groups>
 118     { { table-gap { 5 5 } } } [ [ callframe. ] each ] tabular-output nl ;
 119
 120 : .c ( -- ) callstack callstack. ;
 121
 122 : pprint-cell ( obj -- ) [ pprint-short ] with-cell ;
 123
 124 SYMBOL: pprint-string-cells?
 125
 126 : simple-table. ( values -- )
 127     standard-table-style [
 128         [
 129             [
 130                 [
 131                     dup string? pprint-string-cells? get not and
 132                     [ [ write ] with-cell ]
 133                     [ pprint-cell ]
 134                     if
 135                 ] each
 136             ] with-row
 137         ] each
 138     ] tabular-output nl ;
 139
 140 : object-table. ( obj alist -- )
 141     [ [ nip first ] [ second call( obj -- str ) ] 2bi 2array ] with map
 142     simple-table. ;