An object inspector

diff --git a/examples/ginspect.lisp b/examples/ginspect.lisp
new file mode 100644 (file)
index 0000000..d2a26d4
--- /dev/null
+++ b/examples/ginspect.lisp
@@ -0,0 +1,146 @@
+(in-package :gtk)
+
+(defgeneric insert-object (object store parent &optional prefix))
+(defgeneric insert-parts (object store parent))
+(defgeneric object-hash-parts-p (object))
+
+
+(defun ginspect (object)
+  (let* ((store (make-instance 'tree-store 
+                :column-types '(string string gobject boolean)
+                :column-names '(prefix pprint object expanded)))
+        (view (make-instance 'tree-view :model store :headers-visible nil)))
+
+    (let ((column (make-instance 'tree-view-column))
+         (prefix (make-instance 'cell-renderer-text))
+         (object (make-instance 'cell-renderer-text)))   
+      (cell-layout-pack column prefix :expand nil)
+      (cell-layout-add-attribute column prefix 'text 0)
+      (cell-layout-pack column object :expand t)
+      (cell-layout-add-attribute column object 'text 1)
+      (tree-view-append-column view column))
+
+    (insert-object object store nil)
+
+    (signal-connect view 'row-expanded 
+     #'(lambda (iter path)
+        (unless (tree-model-column-value store iter 'expanded)
+          (multiple-value-bind (valid dummy)
+              (tree-model-iter-children store iter)
+            ;; Remove dummy child
+            (when valid
+              (tree-store-remove store dummy)))
+          (let ((gobject (tree-model-column-value store iter 'object)))
+            (insert-parts (object-data gobject 'object) store iter))
+          (setf (tree-model-column-value store iter 'expanded) t)
+          (tree-view-expand-row view path nil))))
+
+    (make-instance 'dialog
+     :title "Object Inspector" :show-all t
+     :default-width 600 :default-height 600
+     :button (list "gtk-close" #'widget-destroy :object t)
+     :child (make-instance 'scrolled-window 
+            :hscrollbar-policy :automatic :child view))))
+
+
+(defun object-to-string (object)
+  (with-output-to-string (stream)
+    (write object :stream stream :lines 1 :right-margin 80)))
+
+(defmethod insert-object ((object t) store parent &optional (prefix ""))
+  (let ((gobject (make-instance 'gobject)) ; to "hang" the lisp object on
+       (has-parts (object-has-parts-p object)))
+    (setf (object-data gobject 'object) object)
+    (let ((iter (tree-store-append store parent 
+                (vector prefix (object-to-string object) 
+                        gobject (not has-parts)))))
+      (when has-parts
+       ;; Insert dummy child
+       (tree-store-append store iter (vector "" "" gobject t))))))
+
+(defmethod object-has-parts-p ((object t))
+  (declare (ignore object))
+  t)
+
+(defmethod insert-parts ((object t) store parent)
+  (let ((parts (nth-value 1 (swank-backend:inspected-parts object))))
+    (unless (and (endp (rest parts)) (eq object (cdar parts)))
+      (loop
+       for (prefix . part) in parts
+       do (insert-object part store parent prefix)))))
+
+(defun propper-list-p (object)
+  (and (listp object) (null (cdr (last object)))))
+
+(defmethod insert-parts ((object cons) store parent)
+  (if (propper-list-p object)
+      (loop
+       for element in object
+       do (insert-object element store parent))
+    (progn
+      (insert-object (car object) store parent)
+      (insert-object (cdr object) store parent))))
+
+(defmethod insert-parts ((object vector) store parent)
+  (loop
+   for element across object
+   do (insert-object element store parent)))
+
+(defmethod insert-parts ((object (eql t)) store parent)
+  (declare (ignore object store parent)))
+
+(defmethod object-has-parts-p ((object (eql t)))
+  (declare (ignore object))
+  nil)
+
+(defmethod insert-parts ((object (eql nil)) store parent)
+  (declare (ignore object store parent)))
+
+(defmethod object-has-parts-p ((object (eql nil)))
+  (declare (ignore object))
+  nil)
+
+(defvar *unbound-object-marker* (gensym "UNBOUND-OBJECT-"))
+
+(defmethod insert-parts ((object symbol) store parent)
+  (insert-object 
+   (if (boundp object)
+       (symbol-value object)
+     *unbound-object-marker*)
+   store parent "Value")
+  (insert-object 
+   (if (fboundp object)
+       (symbol-function object)
+     *unbound-object-marker*)
+   store parent "Function")
+  (insert-object (symbol-plist object) store parent "Plist")
+  (insert-object (symbol-package object) store parent "Package"))
+
+
+(defmethod insert-parts ((object standard-object) store parent)
+  (loop
+   for slotd in (class-slots (class-of object))
+   do (let* ((slot-name (slot-value slotd 'pcl::name))
+            (slot-value (if (slot-boundp object slot-name)
+                            (slot-value object slot-name)
+                          *unbound-object-marker*)))
+           (insert-object slot-value store parent (string slot-name)))))
+         
+(defmethod insert-object ((object (eql *unbound-object-marker*))
+                          store parent &optional prefix)
+  (tree-store-append store parent (vector prefix "<unbound>" (make-instance 'gobject) t nil)))
+
+(defmethod insert-parts ((object (eql *unbound-object-marker*)) store parent)
+  (declare (ignore object store parent)))
+
+(defmethod object-has-parts-p ((object character))
+  (declare (ignore object))
+  nil)
+
+(defmethod object-has-parts-p ((object number))
+  (declare (ignore object))
+  nil)
+
+(defmethod object-has-parts-p ((object alien:system-area-pointer))
+  (declare (ignore object))
+  nil)