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 IN: prettyprint
   9
  10 : with-use ( obj quot -- )
  11     make-pprint (pprint-manifest
  12     [ pprint-manifest) ] [ [ drop nl ] unless-empty ] bi
  13     do-pprint ; inline
  14
  15 : with-in ( obj quot -- )
  16     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 : pprint-use ( obj -- ) [ pprint* ] with-use ;
  23
  24 : unparse ( obj -- str ) [ pprint ] with-string-writer ;
  25
  26 : unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
  27
  28 : pprint-short ( obj -- )
  29     H{
  30        { line-limit 1 }
  31        { length-limit 15 }
  32        { nesting-limit 2 }
  33        { string-limit? t }
  34        { boa-tuples? t }
  35     } clone [ pprint ] bind ;
  36
  37 : unparse-short ( obj -- str )
  38     [ pprint-short ] with-string-writer ;
  39
  40 : short. ( obj -- ) pprint-short nl ;
  41
  42 : .b ( n -- ) >bin print ;
  43 : .o ( n -- ) >oct print ;
  44 : .h ( n -- ) >hex print ;
  45
  46 : stack. ( seq -- ) [ short. ] each ;
  47
  48 : .s ( -- ) datastack stack. ;
  49 : .r ( -- ) retainstack stack. ;
  50
  51 <PRIVATE
  52
  53 SYMBOL: ->
  54
  55 \ ->
  56 { { foreground T{ rgba f 1 1 1 1 } } { background T{ rgba f 0 0 0 1 } } }
  57 "word-style" set-word-prop
  58
  59 : remove-step-into ( word -- )
  60     building get [ nip pop wrapped>> ] unless-empty , ;
  61
  62 : (remove-breakpoints) ( quot -- newquot )
  63     [
  64         [
  65             {
  66                 { [ dup word? not ] [ , ] }
  67                 { [ dup "break?" word-prop ] [ drop ] }
  68                 { [ dup "step-into?" word-prop ] [ remove-step-into ] }
  69                 [ , ]
  70             } cond
  71         ] each
  72     ] [ ] make ;
  73
  74 : remove-breakpoints ( quot pos -- quot' )
  75     1 + short cut [ (remove-breakpoints) ] bi@ [ -> ] glue ;
  76
  77 : callframe. ( triple -- )
  78     first3
  79     [
  80         {
  81             { [ dup method? ] [ "Method: " write . ] }
  82             { [ dup word? ] [ "Word: " write . ] }
  83             [ drop ]
  84         } cond
  85     ] 2dip
  86     over quotation? [
  87         "Quotation: " write
  88         remove-breakpoints
  89         [
  90             3 nesting-limit set
  91             100 length-limit set
  92             .
  93         ] with-scope
  94     ] [ 2drop ] if ;
  95
  96 PRIVATE>
  97
  98 : callstack. ( callstack -- )
  99     callstack>array 3 <groups> [ nl ] [ callframe. ] interleave ;
 100
 101 : .c ( -- ) callstack callstack. ;
 102
 103 : pprint-cell ( obj -- ) [ pprint-short ] with-cell ;
 104
 105 SYMBOL: pprint-string-cells?
 106
 107 : simple-table. ( values -- )
 108     standard-table-style [
 109         [
 110             [
 111                 [
 112                     dup string? pprint-string-cells? get not and
 113                     [ [ write ] with-cell ]
 114                     [ pprint-cell ]
 115                     if
 116                 ] each
 117             ] with-row
 118         ] each
 119     ] tabular-output nl ;
 120
 121 : object-table. ( obj alist -- )
 122     [ [ nip first ] [ second call( obj -- str ) ] 2bi 2array ] with map
 123     simple-table. ;