chiark / gitweb /
Bug fix
[clg] / examples / ginspect.lisp
CommitLineData
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)))