chiark - git - mdw - clg/blob - examples/ginspect.lisp

   1 (in-package :gtk)
   2
   3 (defvar *ginspect-unbound-object-marker*
   4   #+cmu (gensym "UNBOUND-OBJECT-")
   5   #+sbcl sb-impl::*inspect-unbound-object-marker*)
   6
   7
   8 (defgeneric insert-object (object store parent &optional prefix))
   9 (defgeneric insert-parts (object store parent))
  10 (defgeneric object-has-parts-p (object))
  11 (defgeneric decompose-describe-object (object))
  12
  13
  14 (defun ginspect (object)
  15   (let* ((store (make-instance 'tree-store
  16                  :column-types '(string string gobject boolean)
  17                  :column-names '(name pprinted object expanded)))
  18          (view (make-instance 'tree-view :model store :headers-visible nil)))
  19
  20     (let ((column (make-instance 'tree-view-column))
  21           (name (make-instance 'cell-renderer-text))
  22           (object (make-instance 'cell-renderer-text)))
  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)
  26       (cell-layout-pack column object :expand t)
  27       (cell-layout-add-attribute column object 'text 'pprinted store))
  28
  29     (insert-object object store nil)
  30
  31     (signal-connect view 'row-expanded
  32      #'(lambda (iter path)
  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)
  37                (tree-model-iter-children store iter)
  38              ;; Remove old children
  39              (when valid
  40                (loop while (tree-store-remove store child-iter))))
  41            (let ((gobject (tree-model-column-value store iter 'object)))
  42              (insert-parts (object-data gobject 'object) store iter))
  43            (tree-view-expand-row view path nil))))
  44
  45     (make-instance 'dialog
  46      :title "Object Inspector" :show-children t :visible t
  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
  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)
 106                                  *inspect-unbound-object-marker*)))
 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))
 124   (with-output-to-string (stream)
 125     (write object :stream stream :lines 1 :right-margin 80)))
 126
 127 (defmethod object-to-string ((object (eql *ginspect-unbound-object-marker*)))
 128   "<unbound>")
 129
 130 (defmethod insert-object ((object t) store parent &optional (name ""))
 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
 135                  (vector name (object-to-string object)
 136                          gobject (not has-parts)))))
 137       (when has-parts
 138         ;; Insert dummy child
 139         (tree-store-append store iter (vector "" "" gobject t))))))
 140
 141 (defmethod insert-parts :around ((object t) store parent)
 142   (when (object-has-parts-p object)
 143     (call-next-method)))
 144
 145 (defmethod insert-parts ((object t) store parent)
 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)))