1 ! Copyright (C) 2005, 2010 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs continuations debugger fry hashtables io
4 io.styles kernel math mirrors namespaces prettyprint
5 prettyprint.custom prettyprint.sections sequences sets sorting
11 : print-summary ( obj -- )
12 [ safe-summary ] keep write-object ;
16 : sort-unparsed-keys ( assoc -- alist )
19 zip sort-values keys ;
21 GENERIC: add-numbers ( alist -- table' )
23 M: enumerated add-numbers ;
26 +number-rows+ get [ [ prefix ] map-index ] when ;
28 TUPLE: slot-name name ;
30 M: slot-name pprint* name>> text ;
32 GENERIC: fix-slot-names ( assoc -- assoc )
34 M: assoc fix-slot-names >alist ;
36 M: mirror fix-slot-names
37 [ [ slot-name boa ] dip ] { } assoc-map-as ;
39 : (describe) ( obj assoc -- keys )
40 t pprint-string-cells? [
41 [ print-summary nl ] [
42 dup hashtable? [ sort-unparsed-keys ] when
43 [ fix-slot-names add-numbers simple-table. ] [ keys ] bi
49 : describe ( obj -- ) dup make-mirror (describe) drop ;
51 M: tuple error. describe ;
53 : vars-in-scope ( seq -- alist )
54 [ [ global eq? ] reject [ keys ] gather ] keep
55 '[ dup _ assoc-stack ] H{ } map>assoc ;
58 get-namestack vars-in-scope describe ;
61 error-continuation get name>> vars-in-scope describe ;
67 SYMBOL: inspector-stack
71 : reinspect ( obj -- )
74 dup make-mirror dup mirror namespaces:set
75 t +number-rows+ [ (describe) ] with-variable
76 sorted-keys namespaces:set
79 : (inspect) ( obj -- )
80 [ inspector-stack get push ] [ reinspect ] bi ;
84 : key@ ( n -- key ) sorted-keys get nth ;
86 : &push ( -- obj ) me get ;
88 : &at ( n -- ) key@ mirror get at (inspect) ;
92 dup length 1 <= [ drop ] [ [ pop* ] [ last reinspect ] bi ] if ;
94 : &add ( value key -- ) mirror get set-at &push reinspect ;
96 : &put ( value n -- ) key@ &add ;
98 : &delete ( n -- ) key@ mirror get delete-at &push reinspect ;
100 : &rename ( key n -- ) key@ mirror get rename-at &push reinspect ;
103 ! A tribute to Slate:
104 "You are in a twisty little maze of objects, all alike." print
106 "'n' is a slot number in the following:" print
108 "&back -- return to previous object" print
109 "&push ( -- obj ) push this object" print
110 "&at ( n -- ) inspect nth slot" print
111 "&put ( value n -- ) change nth slot" print
112 "&add ( value key -- ) add new slot" print
113 "&delete ( n -- ) remove a slot" print
114 "&rename ( key n -- ) change a slot's key" print
115 "&globals ( -- ) inspect global namespace" print
116 "&help -- display this message" print
119 : inspector ( obj -- )
121 V{ } clone inspector-stack namespaces:set
125 inspector-stack get [ (inspect) ] [ inspector ] if ;
127 : &globals ( -- ) global inspect ;