112ac1d3 |
1 | ;; Common Lisp bindings for GTK+ 2.x |
2 | ;; Copyright 2005 Espen S. Johnsen <espen@users.sf.net> |
3 | ;; |
4 | ;; Permission is hereby granted, free of charge, to any person obtaining |
5 | ;; a copy of this software and associated documentation files (the |
6 | ;; "Software"), to deal in the Software without restriction, including |
7 | ;; without limitation the rights to use, copy, modify, merge, publish, |
8 | ;; distribute, sublicense, and/or sell copies of the Software, and to |
9 | ;; permit persons to whom the Software is furnished to do so, subject to |
10 | ;; the following conditions: |
11 | ;; |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
14 | ;; |
15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. |
18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY |
19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, |
20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE |
21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
22 | |
281c17ec |
23 | ;; $Id: ginspect.lisp,v 1.14 2006-09-15 12:46:30 espen Exp $ |
112ac1d3 |
24 | |
d427b0a5 |
25 | #+sbcl(require :gtk) |
9f2d34f2 |
26 | #+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk) |
d427b0a5 |
27 | |
28 | (defpackage "GINSPECT" |
0868655d |
29 | (:use "COMMON-LISP" "GFFI" "GLIB" "GTK" #+cmu"PCL" #+sbcl"SB-PCL" #+clisp"MOP") |
30 | #+clisp(:shadowing-import-from "MOP" "SLOT-DEFINITION-TYPE") |
f1eee195 |
31 | (:export "GINSPECT" "GINSPECT-TOPLEVELS")) |
d427b0a5 |
32 | |
33 | (in-package "GINSPECT") |
a9d159ba |
34 | |
ade112f8 |
35 | (defvar *ginspect-unbound-object-marker* |
0868655d |
36 | #+(or cmu clisp)(gensym "UNBOUND-OBJECT-") |
ade112f8 |
37 | #+sbcl sb-impl::*inspect-unbound-object-marker*) |
38 | |
39 | |
a9d159ba |
40 | (defgeneric insert-object (object store parent &optional prefix)) |
41 | (defgeneric insert-parts (object store parent)) |
ade112f8 |
42 | (defgeneric object-has-parts-p (object)) |
43 | (defgeneric decompose-describe-object (object)) |
a9d159ba |
44 | |
45 | |
d427b0a5 |
46 | ;; A container to hold lisp objects "inside" the tree store |
47 | (defclass object-container (gobject) |
48 | ((object :initarg :object)) |
49 | (:metaclass gobject-class)) |
50 | |
51 | |
a9d159ba |
52 | (defun ginspect (object) |
53 | (let* ((store (make-instance 'tree-store |
54 | :column-types '(string string gobject boolean) |
ade112f8 |
55 | :column-names '(name pprinted object expanded))) |
a9d159ba |
56 | (view (make-instance 'tree-view :model store :headers-visible nil))) |
57 | |
58 | (let ((column (make-instance 'tree-view-column)) |
ade112f8 |
59 | (name (make-instance 'cell-renderer-text)) |
a9d159ba |
60 | (object (make-instance 'cell-renderer-text))) |
ade112f8 |
61 | (tree-view-append-column view column) |
62 | (cell-layout-pack column name :expand nil) |
281c17ec |
63 | (cell-layout-add-attribute column name :text (tree-model-column-index store 'name)) |
a9d159ba |
64 | (cell-layout-pack column object :expand t) |
281c17ec |
65 | (cell-layout-add-attribute column object :text (tree-model-column-index store 'pprinted))) |
a9d159ba |
66 | |
67 | (insert-object object store nil) |
68 | |
69 | (signal-connect view 'row-expanded |
70 | #'(lambda (iter path) |
ade112f8 |
71 | (when (setf |
234b4f80 |
72 | (tree-model-value store iter 'expanded) |
73 | (not (tree-model-value store iter 'expanded))) |
ade112f8 |
74 | (multiple-value-bind (valid child-iter) |
a9d159ba |
75 | (tree-model-iter-children store iter) |
ade112f8 |
76 | ;; Remove old children |
a9d159ba |
77 | (when valid |
ade112f8 |
78 | (loop while (tree-store-remove store child-iter)))) |
d427b0a5 |
79 | (let ((container (tree-model-value store iter 'object))) |
80 | (insert-parts (slot-value container 'object) store iter)) |
a9d159ba |
81 | (tree-view-expand-row view path nil)))) |
82 | |
83 | (make-instance 'dialog |
ade112f8 |
84 | :title "Object Inspector" :show-children t :visible t |
a9d159ba |
85 | :default-width 600 :default-height 600 |
86 | :button (list "gtk-close" #'widget-destroy :object t) |
87 | :child (make-instance 'scrolled-window |
88 | :hscrollbar-policy :automatic :child view)))) |
89 | |
90 | |
ade112f8 |
91 | (defmethod decompose-describe-object ((object t)) |
92 | #+cmu |
93 | (destructuring-bind (description named-p &rest parts) |
94 | (inspect::describe-parts object) |
95 | (if (equal parts (list object)) |
96 | (values description nil nil) |
97 | (values description named-p parts))) |
0868655d |
98 | #+sbcl(sb-impl::inspected-parts object) |
99 | #+clisp(values (format nil "The object is an ATOM of type ~A" (type-of object) nil nil))) |
ade112f8 |
100 | |
101 | (defmethod decompose-describe-object ((object (eql t))) |
102 | (values (call-next-method) nil nil)) |
103 | |
104 | (defmethod decompose-describe-object ((object (eql nil))) |
105 | (values (call-next-method) nil nil)) |
106 | |
107 | (defun propper-list-p (object) |
108 | (and (listp object) (null (cdr (last object))))) |
109 | |
110 | (defmethod decompose-describe-object ((object cons)) |
111 | (if (propper-list-p object) |
112 | (values (call-next-method) nil object) |
113 | (values "The object is a CONS." nil (list (car object) (cdr object))))) |
114 | |
0868655d |
115 | #+(or cmu sbcl) |
ade112f8 |
116 | (defmethod decompose-describe-object ((object #+cmu alien:system-area-pointer |
117 | #+sbcl sb-alien:system-area-pointer)) |
118 | (values "The object is a SYSTEM-AREA-POINTER" nil nil)) |
119 | |
120 | (defmethod decompose-describe-object ((object (eql *ginspect-unbound-object-marker*))) |
121 | (values "The slot is unbound" nil nil)) |
122 | |
0868655d |
123 | #+(or cmu clisp) |
ade112f8 |
124 | (defmethod decompose-describe-object ((object symbol)) |
125 | (values |
126 | (call-next-method) t |
c85a2bb2 |
127 | (list |
128 | (cons "Name" (symbol-name object)) |
129 | (cons "Package" (symbol-package object)) |
130 | (cons "Value" (if (boundp object) |
131 | (symbol-value object) |
132 | *ginspect-unbound-object-marker*)) |
133 | (cons "Function" (if (fboundp object) |
134 | (symbol-function object) |
135 | *ginspect-unbound-object-marker*)) |
136 | (cons "Plist" (symbol-plist object))))) |
ade112f8 |
137 | |
ade112f8 |
138 | (defmethod decompose-describe-object ((object standard-object)) |
139 | (values |
0868655d |
140 | (format nil "The instance is an object of type ~A" |
bc21ee32 |
141 | (class-name (class-of object))) |
142 | t |
ade112f8 |
143 | (loop |
144 | for slotd in (class-slots (class-of object)) |
bc21ee32 |
145 | when (slot-readable-p slotd) |
146 | collect (let* ((slot-name (slot-definition-name slotd)) |
ade112f8 |
147 | (slot-value (if (slot-boundp object slot-name) |
148 | (slot-value object slot-name) |
b506b3db |
149 | *ginspect-unbound-object-marker*))) |
ade112f8 |
150 | (cons (string slot-name) slot-value))))) |
151 | |
0868655d |
152 | #+clisp |
153 | (defmethod decompose-describe-object ((object vector)) |
154 | (values |
155 | (format nil "The object is a ~A of length ~A" (type-of object) (length object)) |
156 | nil |
157 | (coerce object 'list))) |
158 | |
ade112f8 |
159 | |
160 | (defmethod object-has-parts-p ((object t)) |
161 | (nth-value 2 (decompose-describe-object object))) |
162 | |
163 | (defmethod object-has-parts-p ((object cons)) |
164 | t) |
165 | |
166 | (defmethod object-has-parts-p ((object standard-object)) |
167 | (class-slots (class-of object))) |
168 | |
169 | (defmethod object-has-parts-p ((object vector)) |
170 | (not (zerop (length object)))) |
171 | |
172 | |
173 | (defmethod object-to-string ((object t)) |
a9d159ba |
174 | (with-output-to-string (stream) |
175 | (write object :stream stream :lines 1 :right-margin 80))) |
176 | |
ade112f8 |
177 | (defmethod object-to-string ((object (eql *ginspect-unbound-object-marker*))) |
178 | "<unbound>") |
179 | |
180 | (defmethod insert-object ((object t) store parent &optional (name "")) |
d427b0a5 |
181 | (let ((container (make-instance 'object-container :object object)) |
a9d159ba |
182 | (has-parts (object-has-parts-p object))) |
a9d159ba |
183 | (let ((iter (tree-store-append store parent |
ade112f8 |
184 | (vector name (object-to-string object) |
d427b0a5 |
185 | container (not has-parts))))) |
a9d159ba |
186 | (when has-parts |
187 | ;; Insert dummy child |
d427b0a5 |
188 | (tree-store-append store iter (vector "" "" container t)))))) |
a9d159ba |
189 | |
ade112f8 |
190 | (defmethod insert-parts :around ((object t) store parent) |
191 | (when (object-has-parts-p object) |
192 | (call-next-method))) |
a9d159ba |
193 | |
194 | (defmethod insert-parts ((object t) store parent) |
ade112f8 |
195 | (multiple-value-bind (description named-p parts) |
196 | (decompose-describe-object object) |
197 | (declare (ignore description)) |
198 | (loop |
199 | for part in parts |
200 | do (if named-p |
201 | (insert-object (cdr part) store parent (string (car part))) |
202 | (insert-object part store parent))))) |
203 | |
204 | |
205 | (defun ginspect-toplevels () |
206 | (ginspect (window-list-toplevels))) |