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 ;
9 : with-use ( obj quot -- )
10 t make-pprint (pprint-manifest
11 [ pprint-manifest) ] [ [ drop nl ] unless-empty ] bi
14 : with-in ( obj quot -- )
15 t make-pprint current-vocab>> [ pprint-in bl ] when* do-pprint ; inline
17 : pprint ( obj -- ) [ pprint* ] with-pprint ;
19 : . ( obj -- ) pprint nl ;
21 : ... ( obj -- ) [ . ] without-limits ;
23 : pprint-use ( obj -- ) [ pprint* ] with-use ;
25 : unparse ( obj -- str ) [ pprint ] with-string-writer ;
27 : unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
29 : pprint-short ( obj -- )
30 [ pprint ] with-short-limits ;
32 : unparse-short ( obj -- str )
33 [ pprint-short ] with-string-writer ;
35 : short. ( obj -- ) pprint-short nl ;
37 : .b ( n -- ) 2 number-base [ . ] with-variable ;
38 : .o ( n -- ) 8 number-base [ . ] with-variable ;
39 : .h ( n -- ) 16 number-base [ . ] with-variable ;
41 : stack. ( seq -- ) [ short. ] each ;
43 : datastack. ( seq -- )
44 [ nl "--- Data stack:" print stack. ] unless-empty ;
46 : .s ( -- ) get-datastack stack. ;
47 : .r ( -- ) get-retainstack stack. ;
54 { { foreground COLOR: white } { background COLOR: black } }
55 "word-style" set-word-prop
57 : remove-step-into ( word -- )
58 building get [ nip pop wrapped>> ] unless-empty , ;
60 : (remove-breakpoints) ( quot -- newquot )
64 { [ dup word? not ] [ , ] }
65 { [ dup "break?" word-prop ] [ drop ] }
66 { [ dup "step-into?" word-prop ] [ remove-step-into ] }
72 : remove-breakpoints ( quot pos -- quot' )
73 1 + index-or-length cut [ (remove-breakpoints) ] bi@ [ => ] glue ;
75 : optimized-frame? ( triple -- ? ) second word? ;
77 : frame-word? ( triple -- ? )
80 : frame-word. ( triple -- )
83 : optimized-frame. ( triple -- )
85 [ "(O)" write ] with-cell
86 [ frame-word. ] with-cell
89 : unoptimized-frame. ( triple -- )
91 [ "(U)" write ] with-cell
93 dup [ second ] [ third ] bi remove-breakpoints
97 } clone [ pprint ] with-variables
103 [ frame-word. ] with-cell
107 : callframe. ( triple -- )
109 [ optimized-frame. ] [ unoptimized-frame. ] if ;
113 : callstack. ( callstack -- )
114 callstack>array 3 <groups> reverse
115 { { table-gap { 5 5 } } } [ [ callframe. ] each ] tabular-output nl ;
117 : .c ( -- ) get-callstack callstack. ;
119 : pprint-cell ( obj -- ) [ pprint-short ] with-cell ;
121 SYMBOL: pprint-string-cells?
123 : simple-table. ( values -- )
124 standard-table-style [
128 dup string? pprint-string-cells? get not and
129 [ [ write ] with-cell ]
135 ] tabular-output nl ;
137 : object-table. ( obj alist -- )
138 [ [ nip first ] [ second call( obj -- str ) ] 2bi 2array ] with map