mdw@git.distorted.org.uk Git - clg/blob - examples/ginspect.lisp

   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
  23 ;; $Id: ginspect.lisp,v 1.5 2005-04-23 16:48:49 espen Exp $
  24
  25 (in-package :gtk)
  26
  27 (defvar *ginspect-unbound-object-marker*
  28   #+cmu (gensym "UNBOUND-OBJECT-")
  29   #+sbcl sb-impl::*inspect-unbound-object-marker*)
  30
  31
  32 (defgeneric insert-object (object store parent &optional prefix))
  33 (defgeneric insert-parts (object store parent))
  34 (defgeneric object-has-parts-p (object))
  35 (defgeneric decompose-describe-object (object))
  36
  37
  38 (defun ginspect (object)
  39   (let* ((store (make-instance 'tree-store
  40                  :column-types '(string string gobject boolean)
  41                  :column-names '(name pprinted object expanded)))
  42          (view (make-instance 'tree-view :model store :headers-visible nil)))
  43
  44     (let ((column (make-instance 'tree-view-column))
  45           (name (make-instance 'cell-renderer-text))
  46           (object (make-instance 'cell-renderer-text)))
  47       (tree-view-append-column view column)
  48       (cell-layout-pack column name :expand nil)
  49       (cell-layout-add-attribute column name 'text (column-index store 'name))
  50       (cell-layout-pack column object :expand t)
  51       (cell-layout-add-attribute column object 'text (column-index store 'pprinted)))
  52
  53     (insert-object object store nil)
  54
  55     (signal-connect view 'row-expanded
  56      #'(lambda (iter path)
  57          (when (setf
  58                 (tree-model-value store iter 'expanded)
  59                 (not (tree-model-value store iter 'expanded)))
  60            (multiple-value-bind (valid child-iter)
  61                (tree-model-iter-children store iter)
  62              ;; Remove old children
  63              (when valid
  64                (loop while (tree-store-remove store child-iter))))
  65            (let ((gobject (tree-model-value store iter 'object)))
  66              (insert-parts (object-data gobject 'object) store iter))
  67            (tree-view-expand-row view path nil))))
  68
  69     (make-instance 'dialog
  70      :title "Object Inspector" :show-children t :visible t
  71      :default-width 600 :default-height 600
  72      :button (list "gtk-close" #'widget-destroy :object t)
  73      :child (make-instance 'scrolled-window
  74              :hscrollbar-policy :automatic :child view))))
  75
  76
  77 (defmethod decompose-describe-object ((object t))
  78   #+cmu
  79   (destructuring-bind (description named-p &rest parts)
  80       (inspect::describe-parts object)
  81     (if (equal parts (list object))
  82         (values description nil nil)
  83       (values description named-p parts)))
  84   (sb-impl::inspected-parts object))
  85
  86 (defmethod decompose-describe-object ((object (eql t)))
  87   (values (call-next-method) nil nil))
  88
  89 (defmethod decompose-describe-object ((object (eql nil)))
  90   (values (call-next-method) nil nil))
  91
  92 (defun propper-list-p (object)
  93   (and (listp object) (null (cdr (last object)))))
  94
  95 (defmethod decompose-describe-object ((object cons))
  96   (if (propper-list-p object)
  97       (values (call-next-method) nil object)
  98     (values "The object is a CONS." nil (list (car object) (cdr object)))))
  99
 100 (defmethod decompose-describe-object ((object #+cmu alien:system-area-pointer
 101                                               #+sbcl sb-alien:system-area-pointer))
 102   (values "The object is a SYSTEM-AREA-POINTER" nil nil))
 103
 104 (defmethod decompose-describe-object ((object (eql *ginspect-unbound-object-marker*)))
 105   (values "The slot is unbound" nil nil))
 106
 107 #+cmu
 108 (defmethod decompose-describe-object ((object symbol))
 109   (values
 110    (call-next-method) t
 111    (cons "Name" (symbol-name object))
 112    (cons "Package" (symbol-package objecy))
 113    (cons "Value" (if (boundp object)
 114                      (symbol-value object)
 115                    *ginspect-unbound-object-marker*))
 116    (cons "Function" (if (fboundp object)
 117                         (symbol-function  object)
 118                       *ginspect-unbound-object-marker*))
 119    (cons "Plist" (symbol-plist object))))
 120
 121 #+cmu
 122 (defmethod decompose-describe-object ((object standard-object))
 123   (values
 124    (call-next-method) t
 125    (loop
 126     for slotd in (class-slots (class-of object))
 127     collect (let* ((slot-name (pcl:slot-definition-name slotd))
 128                    (slot-value (if (slot-boundp object slot-name)
 129                                    (slot-value object slot-name)
 130                                  *ginspect-unbound-object-marker*)))
 131               (cons (string slot-name) slot-value)))))
 132
 133
 134 (defmethod object-has-parts-p ((object t))
 135   (nth-value 2 (decompose-describe-object object)))
 136
 137 (defmethod object-has-parts-p ((object cons))
 138   t)
 139
 140 (defmethod object-has-parts-p ((object standard-object))
 141   (class-slots (class-of object)))
 142
 143 (defmethod object-has-parts-p ((object vector))
 144   (not (zerop (length object))))
 145
 146
 147 (defmethod object-to-string ((object t))
 148   (with-output-to-string (stream)
 149     (write object :stream stream :lines 1 :right-margin 80)))
 150
 151 (defmethod object-to-string ((object (eql *ginspect-unbound-object-marker*)))
 152   "<unbound>")
 153
 154 (defmethod insert-object ((object t) store parent &optional (name ""))
 155   (let ((gobject (make-instance 'gobject)) ; to "hang" the lisp object on
 156         (has-parts (object-has-parts-p object)))
 157     (setf (object-data gobject 'object) object)
 158     (let ((iter (tree-store-append store parent
 159                  (vector name (object-to-string object)
 160                          gobject (not has-parts)))))
 161       (when has-parts
 162         ;; Insert dummy child
 163         (tree-store-append store iter (vector "" "" gobject t))))))
 164
 165 (defmethod insert-parts :around ((object t) store parent)
 166   (when (object-has-parts-p object)
 167     (call-next-method)))
 168
 169 (defmethod insert-parts ((object t) store parent)
 170   (multiple-value-bind (description named-p parts)
 171       (decompose-describe-object object)
 172     (declare (ignore description))
 173     (loop
 174      for part in parts
 175      do (if named-p
 176             (insert-object (cdr part) store parent (string (car part)))
 177           (insert-object part store parent)))))
 178
 179
 180 (defun ginspect-toplevels ()
 181   (ginspect (window-list-toplevels)))