a9d159ba |
1 | (in-package :gtk) |
2 | |
ade112f8 |
3 | (defvar *ginspect-unbound-object-marker* |
4 | #+cmu (gensym "UNBOUND-OBJECT-") |
5 | #+sbcl sb-impl::*inspect-unbound-object-marker*) |
6 | |
7 | |
a9d159ba |
8 | (defgeneric insert-object (object store parent &optional prefix)) |
9 | (defgeneric insert-parts (object store parent)) |
ade112f8 |
10 | (defgeneric object-has-parts-p (object)) |
11 | (defgeneric decompose-describe-object (object)) |
a9d159ba |
12 | |
13 | |
14 | (defun ginspect (object) |
15 | (let* ((store (make-instance 'tree-store |
16 | :column-types '(string string gobject boolean) |
ade112f8 |
17 | :column-names '(name pprinted object expanded))) |
a9d159ba |
18 | (view (make-instance 'tree-view :model store :headers-visible nil))) |
19 | |
20 | (let ((column (make-instance 'tree-view-column)) |
ade112f8 |
21 | (name (make-instance 'cell-renderer-text)) |
a9d159ba |
22 | (object (make-instance 'cell-renderer-text))) |
ade112f8 |
23 | (tree-view-append-column view column) |
24 | (cell-layout-pack column name :expand nil) |
25 | (cell-layout-add-attribute column name 'text 'name store) |
a9d159ba |
26 | (cell-layout-pack column object :expand t) |
ade112f8 |
27 | (cell-layout-add-attribute column object 'text 'pprinted store)) |
a9d159ba |
28 | |
29 | (insert-object object store nil) |
30 | |
31 | (signal-connect view 'row-expanded |
32 | #'(lambda (iter path) |
ade112f8 |
33 | (when (setf |
34 | (tree-model-column-value store iter 'expanded) |
35 | (not (tree-model-column-value store iter 'expanded))) |
36 | (multiple-value-bind (valid child-iter) |
a9d159ba |
37 | (tree-model-iter-children store iter) |
ade112f8 |
38 | ;; Remove old children |
a9d159ba |
39 | (when valid |
ade112f8 |
40 | (loop while (tree-store-remove store child-iter)))) |
a9d159ba |
41 | (let ((gobject (tree-model-column-value store iter 'object))) |
42 | (insert-parts (object-data gobject 'object) store iter)) |
a9d159ba |
43 | (tree-view-expand-row view path nil)))) |
44 | |
45 | (make-instance 'dialog |
ade112f8 |
46 | :title "Object Inspector" :show-children t :visible t |
a9d159ba |
47 | :default-width 600 :default-height 600 |
48 | :button (list "gtk-close" #'widget-destroy :object t) |
49 | :child (make-instance 'scrolled-window |
50 | :hscrollbar-policy :automatic :child view)))) |
51 | |
52 | |
ade112f8 |
53 | (defmethod decompose-describe-object ((object t)) |
54 | #+cmu |
55 | (destructuring-bind (description named-p &rest parts) |
56 | (inspect::describe-parts object) |
57 | (if (equal parts (list object)) |
58 | (values description nil nil) |
59 | (values description named-p parts))) |
60 | (sb-impl::inspected-parts object)) |
61 | |
62 | (defmethod decompose-describe-object ((object (eql t))) |
63 | (values (call-next-method) nil nil)) |
64 | |
65 | (defmethod decompose-describe-object ((object (eql nil))) |
66 | (values (call-next-method) nil nil)) |
67 | |
68 | (defun propper-list-p (object) |
69 | (and (listp object) (null (cdr (last object))))) |
70 | |
71 | (defmethod decompose-describe-object ((object cons)) |
72 | (if (propper-list-p object) |
73 | (values (call-next-method) nil object) |
74 | (values "The object is a CONS." nil (list (car object) (cdr object))))) |
75 | |
76 | (defmethod decompose-describe-object ((object #+cmu alien:system-area-pointer |
77 | #+sbcl sb-alien:system-area-pointer)) |
78 | (values "The object is a SYSTEM-AREA-POINTER" nil nil)) |
79 | |
80 | (defmethod decompose-describe-object ((object (eql *ginspect-unbound-object-marker*))) |
81 | (values "The slot is unbound" nil nil)) |
82 | |
83 | #+cmu |
84 | (defmethod decompose-describe-object ((object symbol)) |
85 | (values |
86 | (call-next-method) t |
87 | (cons "Name" (symbol-name object)) |
88 | (cons "Package" (symbol-package objecy)) |
89 | (cons "Value" (if (boundp object) |
90 | (symbol-value object) |
91 | *ginspect-unbound-object-marker*)) |
92 | (cons "Function" (if (fboundp object) |
93 | (symbol-function object) |
94 | *ginspect-unbound-object-marker*)) |
95 | (cons "Plist" (symbol-plist object)))) |
96 | |
97 | #+cmu |
98 | (defmethod decompose-describe-object ((object standard-object)) |
99 | (values |
100 | (call-next-method) t |
101 | (loop |
102 | for slotd in (class-slots (class-of object)) |
103 | collect (let* ((slot-name (pcl:slot-definition-name slotd)) |
104 | (slot-value (if (slot-boundp object slot-name) |
105 | (slot-value object slot-name) |
b506b3db |
106 | *ginspect-unbound-object-marker*))) |
ade112f8 |
107 | (cons (string slot-name) slot-value))))) |
108 | |
109 | |
110 | (defmethod object-has-parts-p ((object t)) |
111 | (nth-value 2 (decompose-describe-object object))) |
112 | |
113 | (defmethod object-has-parts-p ((object cons)) |
114 | t) |
115 | |
116 | (defmethod object-has-parts-p ((object standard-object)) |
117 | (class-slots (class-of object))) |
118 | |
119 | (defmethod object-has-parts-p ((object vector)) |
120 | (not (zerop (length object)))) |
121 | |
122 | |
123 | (defmethod object-to-string ((object t)) |
a9d159ba |
124 | (with-output-to-string (stream) |
125 | (write object :stream stream :lines 1 :right-margin 80))) |
126 | |
ade112f8 |
127 | (defmethod object-to-string ((object (eql *ginspect-unbound-object-marker*))) |
128 | "<unbound>") |
129 | |
130 | (defmethod insert-object ((object t) store parent &optional (name "")) |
a9d159ba |
131 | (let ((gobject (make-instance 'gobject)) ; to "hang" the lisp object on |
132 | (has-parts (object-has-parts-p object))) |
133 | (setf (object-data gobject 'object) object) |
134 | (let ((iter (tree-store-append store parent |
ade112f8 |
135 | (vector name (object-to-string object) |
a9d159ba |
136 | gobject (not has-parts))))) |
137 | (when has-parts |
138 | ;; Insert dummy child |
139 | (tree-store-append store iter (vector "" "" gobject t)))))) |
140 | |
ade112f8 |
141 | (defmethod insert-parts :around ((object t) store parent) |
142 | (when (object-has-parts-p object) |
143 | (call-next-method))) |
a9d159ba |
144 | |
145 | (defmethod insert-parts ((object t) store parent) |
ade112f8 |
146 | (multiple-value-bind (description named-p parts) |
147 | (decompose-describe-object object) |
148 | (declare (ignore description)) |
149 | (loop |
150 | for part in parts |
151 | do (if named-p |
152 | (insert-object (cdr part) store parent (string (car part))) |
153 | (insert-object part store parent))))) |
154 | |
155 | |
156 | (defun ginspect-toplevels () |
157 | (ginspect (window-list-toplevels))) |