1 ! Copyright (C) 2003, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays classes colors.constants 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 ;
10 : with-use ( obj quot -- )
11 t make-pprint (pprint-manifest
12 [ pprint-manifest) ] [ [ drop nl ] unless-empty ] bi
15 : with-in ( obj quot -- )
16 t make-pprint current-vocab>> [ pprint-in bl ] when* do-pprint ; inline
18 : pprint ( obj -- ) [ pprint* ] with-pprint ;
20 : . ( obj -- ) pprint nl ;
22 : ... ( obj -- ) [ . ] without-limits ;
24 : pprint-use ( obj -- ) [ pprint* ] with-use ;
26 : unparse ( obj -- str ) [ pprint ] with-string-writer ;
28 : unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
30 : pprint-short ( obj -- )
31 [ pprint ] with-short-limits ;
33 : unparse-short ( obj -- str )
34 [ pprint-short ] with-string-writer ;
36 : short. ( obj -- ) pprint-short nl ;
38 : error-in-pprint ( obj -- str )
39 class-of name>> "~pprint error: " "~" surround ;
41 : .b ( n -- ) 2 number-base [ . ] with-variable ;
42 : .o ( n -- ) 8 number-base [ . ] with-variable ;
43 : .h ( n -- ) 16 number-base [ . ] with-variable ;
48 drop [ error-in-pprint ] keep write-object nl
52 : .s ( -- ) get-datastack stack. ;
53 : .r ( -- ) get-retainstack stack. ;
60 { { foreground COLOR: white } { background COLOR: black } }
61 "word-style" set-word-prop
63 : remove-step-into ( word -- )
64 building get [ nip pop wrapped>> ] unless-empty , ;
66 : (remove-breakpoints) ( quot -- newquot )
70 { [ dup word? not ] [ , ] }
71 { [ dup "break?" word-prop ] [ drop ] }
72 { [ dup "step-into?" word-prop ] [ remove-step-into ] }
78 : remove-breakpoints ( quot pos -- quot' )
79 1 + short cut [ (remove-breakpoints) ] bi@ [ => ] glue ;
81 : optimized-frame? ( triple -- ? ) second word? ;
83 : frame-word? ( triple -- ? )
86 : frame-word. ( triple -- )
89 : optimized-frame. ( triple -- )
91 [ "(O)" write ] with-cell
92 [ frame-word. ] with-cell
95 : unoptimized-frame. ( triple -- )
97 [ "(U)" write ] with-cell
99 dup [ second ] [ third ] bi remove-breakpoints
103 } clone [ pprint ] with-variables
109 [ frame-word. ] with-cell
113 : callframe. ( triple -- )
115 [ optimized-frame. ] [ unoptimized-frame. ] if ;
119 : callstack. ( callstack -- )
120 callstack>array 3 <groups> reverse
121 { { table-gap { 5 5 } } } [ [ callframe. ] each ] tabular-output nl ;
123 : .c ( -- ) get-callstack callstack. ;
125 : pprint-cell ( obj -- ) [ pprint-short ] with-cell ;
127 SYMBOL: pprint-string-cells?
129 : simple-table. ( values -- )
130 standard-table-style [
134 dup string? pprint-string-cells? get not and
135 [ [ write ] with-cell ]
141 ] tabular-output nl ;
143 : object-table. ( obj alist -- )
144 [ [ nip first ] [ second call( obj -- str ) ] 2bi 2array ] with map