1 ! Copyright (C) 2005, 2008 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 sequences strings io.styles vectors words
5 quotations mirrors splitting math.parser classes vocabs refs
9 GENERIC: summary ( object -- string )
11 : object-summary ( object -- string )
12 class name>> " instance" append ;
14 M: object summary object-summary ;
19 input-string "\n" split1 swap %
23 M: word summary synopsis ;
41 ! Override sequence => integer instance
42 M: f summary object-summary ;
44 M: integer summary object-summary ;
46 : value-editor ( path -- )
48 [ pprint-short ] presented-printer set
49 dup presented-path set
51 [ get-ref pprint-short ] with-nesting ;
57 : write-slot-editor ( path -- )
66 : write-key ( mirror key -- )
68 [ 2drop ] [ <key-ref> write-slot-editor ] if ;
70 : write-value ( mirror key -- )
71 <value-ref> write-slot-editor ;
73 : describe-row ( obj key n -- )
75 +number-rows+ get [ pprint-cell ] [ drop ] if
76 2dup write-key write-value
79 : summary. ( obj -- ) [ summary ] keep write-object nl ;
81 : sorted-keys ( assoc -- alist )
82 dup mirror? [ keys ] [
84 [ [ unparse-short ] keep ] { } map>assoc
88 : describe* ( obj flags -- )
91 make-mirror dup sorted-keys dup empty? [
94 dup enum? [ +sequence+ on ] when
95 standard-table-style [
97 rot [ -rot describe-row ] curry 2each
102 : describe ( obj -- ) H{ } describe* ;
104 : namestack. ( seq -- )
105 [ [ global eq? not ] filter [ keys ] gather ] keep
106 [ dupd assoc-stack ] curry H{ } map>assoc describe ;
109 namestack namestack. ;
111 SYMBOL: inspector-hook
113 [ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
115 SYMBOL: inspector-stack
119 : reinspect ( obj -- )
121 dup make-mirror dup mirror set keys \ keys set
122 inspector-hook get call ;
124 : (inspect) ( obj -- )
125 dup inspector-stack get push reinspect ;
127 : key@ ( n -- key ) \ keys get nth ;
129 : &push ( -- obj ) me get ;
131 : &at ( n -- ) key@ mirror get at (inspect) ;
135 dup length 1 <= [ drop ] [ dup pop* peek reinspect ] if ;
137 : &add ( value key -- ) mirror get set-at &push reinspect ;
139 : &put ( value n -- ) key@ &add ;
141 : &delete ( n -- ) key@ mirror get delete-at &push reinspect ;
143 : &rename ( key n -- ) key@ mirror get rename-at &push reinspect ;
146 #! A tribute to Slate:
147 "You are in a twisty little maze of objects, all alike." print
149 "'n' is a slot number in the following:" print
151 "&back -- return to previous object" print
152 "&push ( -- obj ) push this object" print
153 "&at ( n -- ) inspect nth slot" print
154 "&put ( value n -- ) change nth slot" print
155 "&add ( value key -- ) add new slot" print
156 "&delete ( n -- ) remove a slot" print
157 "&rename ( key n -- ) change a slot's key" print
158 "&help -- display this message" print
161 : inspector ( obj -- )
163 V{ } clone inspector-stack set
167 inspector-stack get [ (inspect) ] [ inspector ] if ;