3 (defgeneric insert-object (object store parent &optional prefix))
4 (defgeneric insert-parts (object store parent))
5 (defgeneric object-hash-parts-p (object))
8 (defun ginspect (object)
9 (let* ((store (make-instance 'tree-store
10 :column-types '(string string gobject boolean)
11 :column-names '(prefix pprint object expanded)))
12 (view (make-instance 'tree-view :model store :headers-visible nil)))
14 (let ((column (make-instance 'tree-view-column))
15 (prefix (make-instance 'cell-renderer-text))
16 (object (make-instance 'cell-renderer-text)))
17 (cell-layout-pack column prefix :expand nil)
18 (cell-layout-add-attribute column prefix 'text 0)
19 (cell-layout-pack column object :expand t)
20 (cell-layout-add-attribute column object 'text 1)
21 (tree-view-append-column view column))
23 (insert-object object store nil)
25 (signal-connect view 'row-expanded
27 (unless (tree-model-column-value store iter 'expanded)
28 (multiple-value-bind (valid dummy)
29 (tree-model-iter-children store iter)
32 (tree-store-remove store dummy)))
33 (let ((gobject (tree-model-column-value store iter 'object)))
34 (insert-parts (object-data gobject 'object) store iter))
35 (setf (tree-model-column-value store iter 'expanded) t)
36 (tree-view-expand-row view path nil))))
38 (make-instance 'dialog
39 :title "Object Inspector" :show-all t
40 :default-width 600 :default-height 600
41 :button (list "gtk-close" #'widget-destroy :object t)
42 :child (make-instance 'scrolled-window
43 :hscrollbar-policy :automatic :child view))))
46 (defun object-to-string (object)
47 (with-output-to-string (stream)
48 (write object :stream stream :lines 1 :right-margin 80)))
50 (defmethod insert-object ((object t) store parent &optional (prefix ""))
51 (let ((gobject (make-instance 'gobject)) ; to "hang" the lisp object on
52 (has-parts (object-has-parts-p object)))
53 (setf (object-data gobject 'object) object)
54 (let ((iter (tree-store-append store parent
55 (vector prefix (object-to-string object)
56 gobject (not has-parts)))))
59 (tree-store-append store iter (vector "" "" gobject t))))))
61 (defmethod object-has-parts-p ((object t))
62 (declare (ignore object))
65 (defmethod insert-parts ((object t) store parent)
66 (let ((parts (nth-value 1 (swank-backend:inspected-parts object))))
67 (unless (and (endp (rest parts)) (eq object (cdar parts)))
69 for (prefix . part) in parts
70 do (insert-object part store parent prefix)))))
72 (defun propper-list-p (object)
73 (and (listp object) (null (cdr (last object)))))
75 (defmethod insert-parts ((object cons) store parent)
76 (if (propper-list-p object)
79 do (insert-object element store parent))
81 (insert-object (car object) store parent)
82 (insert-object (cdr object) store parent))))
84 (defmethod insert-parts ((object vector) store parent)
86 for element across object
87 do (insert-object element store parent)))
89 (defmethod insert-parts ((object (eql t)) store parent)
90 (declare (ignore object store parent)))
92 (defmethod object-has-parts-p ((object (eql t)))
93 (declare (ignore object))
96 (defmethod insert-parts ((object (eql nil)) store parent)
97 (declare (ignore object store parent)))
99 (defmethod object-has-parts-p ((object (eql nil)))
100 (declare (ignore object))
103 (defvar *unbound-object-marker* (gensym "UNBOUND-OBJECT-"))
105 (defmethod insert-parts ((object symbol) store parent)
108 (symbol-value object)
109 *unbound-object-marker*)
110 store parent "Value")
113 (symbol-function object)
114 *unbound-object-marker*)
115 store parent "Function")
116 (insert-object (symbol-plist object) store parent "Plist")
117 (insert-object (symbol-package object) store parent "Package"))
120 (defmethod insert-parts ((object standard-object) store parent)
122 for slotd in (class-slots (class-of object))
123 do (let* ((slot-name (slot-value slotd 'pcl::name))
124 (slot-value (if (slot-boundp object slot-name)
125 (slot-value object slot-name)
126 *unbound-object-marker*)))
127 (insert-object slot-value store parent (string slot-name)))))
129 (defmethod insert-object ((object (eql *unbound-object-marker*))
130 store parent &optional prefix)
131 (tree-store-append store parent (vector prefix "<unbound>" (make-instance 'gobject) t nil)))
133 (defmethod insert-parts ((object (eql *unbound-object-marker*)) store parent)
134 (declare (ignore object store parent)))
136 (defmethod object-has-parts-p ((object character))
137 (declare (ignore object))
140 (defmethod object-has-parts-p ((object number))
141 (declare (ignore object))
144 (defmethod object-has-parts-p ((object alien:system-area-pointer))
145 (declare (ignore object))