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