basis/prettyprint/prettyprint.factor

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