1 ! Copyright (C) 2005, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays generic hashtables io kernel assocs math
4 namespaces prettyprint prettyprint.custom prettyprint.sections
5 sequences strings io.styles vectors words quotations mirrors
6 splitting math.parser classes vocabs sets sorting summary
7 debugger continuations fry combinators ;
12 : summary. ( obj -- ) [ summary ] keep write-object nl ;
16 : sort-unparsed-keys ( assoc -- alist )
19 zip sort-values keys ;
21 GENERIC: add-numbers ( alist -- table' )
27 dup length [ prefix ] 2map
30 TUPLE: slot-name name ;
32 M: slot-name pprint* name>> text ;
34 GENERIC: fix-slot-names ( assoc -- assoc )
36 M: assoc fix-slot-names >alist ;
38 M: mirror fix-slot-names
39 [ [ slot-name boa ] dip ] { } assoc-map-as ;
41 : (describe) ( obj assoc -- keys )
42 t pprint-string-cells? [
44 dup hashtable? [ sort-unparsed-keys ] when
45 [ fix-slot-names add-numbers simple-table. ] [ keys ] bi
51 : describe ( obj -- ) dup make-mirror (describe) drop ;
53 M: tuple error. describe ;
55 : vars-in-scope ( seq -- alist )
56 [ [ global eq? not ] filter [ keys ] gather ] keep
57 '[ dup _ assoc-stack ] H{ } map>assoc ;
60 namestack vars-in-scope describe ;
63 error-continuation get name>> vars-in-scope describe ;
69 SYMBOL: inspector-stack
73 : reinspect ( obj -- )
76 dup make-mirror dup mirror set
77 t +number-rows+ [ (describe) ] with-variable
81 : (inspect) ( obj -- )
82 [ inspector-stack get push ] [ reinspect ] bi ;
86 : key@ ( n -- key ) sorted-keys get nth ;
88 : &push ( -- obj ) me get ;
90 : &at ( n -- ) key@ mirror get at (inspect) ;
94 dup length 1 <= [ drop ] [ [ pop* ] [ peek reinspect ] bi ] if ;
96 : &add ( value key -- ) mirror get set-at &push reinspect ;
98 : &put ( value n -- ) key@ &add ;
100 : &delete ( n -- ) key@ mirror get delete-at &push reinspect ;
102 : &rename ( key n -- ) key@ mirror get rename-at &push reinspect ;
105 #! A tribute to Slate:
106 "You are in a twisty little maze of objects, all alike." print
108 "'n' is a slot number in the following:" print
110 "&back -- return to previous object" print
111 "&push ( -- obj ) push this object" print
112 "&at ( n -- ) inspect nth slot" print
113 "&put ( value n -- ) change nth slot" print
114 "&add ( value key -- ) add new slot" print
115 "&delete ( n -- ) remove a slot" print
116 "&rename ( key n -- ) change a slot's key" print
117 "&globals ( -- ) inspect global namespace" print
118 "&help -- display this message" print
121 : inspector ( obj -- )
123 V{ } clone inspector-stack set
127 inspector-stack get [ (inspect) ] [ inspector ] if ;
129 : &globals ( -- ) global inspect ;