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

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