chiark - git - mdw - 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.7 2006-02-02 23:00:28 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   #+sbcl(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    (list
 112     (cons "Name" (symbol-name object))
 113     (cons "Package" (symbol-package object))
 114     (cons "Value" (if (boundp object)
 115                       (symbol-value object)
 116                     *ginspect-unbound-object-marker*))
 117     (cons "Function" (if (fboundp object)
 118                          (symbol-function  object)
 119                        *ginspect-unbound-object-marker*))
 120     (cons "Plist" (symbol-plist object)))))
 121
 122 #+cmu
 123 (defmethod decompose-describe-object ((object standard-object))
 124   (values
 125    (call-next-method) t
 126    (loop
 127     for slotd in (class-slots (class-of object))
 128     collect (let* ((slot-name (pcl:slot-definition-name slotd))
 129                    (slot-value (if (slot-boundp object slot-name)
 130                                    (slot-value object slot-name)
 131                                  *ginspect-unbound-object-marker*)))
 132               (cons (string slot-name) slot-value)))))
 133
 134
 135 (defmethod object-has-parts-p ((object t))
 136   (nth-value 2 (decompose-describe-object object)))
 137
 138 (defmethod object-has-parts-p ((object cons))
 139   t)
 140
 141 (defmethod object-has-parts-p ((object standard-object))
 142   (class-slots (class-of object)))
 143
 144 (defmethod object-has-parts-p ((object vector))
 145   (not (zerop (length object))))
 146
 147
 148 (defmethod object-to-string ((object t))
 149   (with-output-to-string (stream)
 150     (write object :stream stream :lines 1 :right-margin 80)))
 151
 152 (defmethod object-to-string ((object (eql *ginspect-unbound-object-marker*)))
 153   "<unbound>")
 154
 155 (defmethod insert-object ((object t) store parent &optional (name ""))
 156   (let ((gobject (make-instance 'gobject)) ; to "hang" the lisp object on
 157         (has-parts (object-has-parts-p object)))
 158     (setf (object-data gobject 'object) object)
 159     (let ((iter (tree-store-append store parent
 160                  (vector name (object-to-string object)
 161                          gobject (not has-parts)))))
 162       (when has-parts
 163         ;; Insert dummy child
 164         (tree-store-append store iter (vector "" "" gobject t))))))
 165
 166 (defmethod insert-parts :around ((object t) store parent)
 167   (when (object-has-parts-p object)
 168     (call-next-method)))
 169
 170 (defmethod insert-parts ((object t) store parent)
 171   (multiple-value-bind (description named-p parts)
 172       (decompose-describe-object object)
 173     (declare (ignore description))
 174     (loop
 175      for part in parts
 176      do (if named-p
 177             (insert-object (cdr part) store parent (string (car part)))
 178           (insert-object part store parent)))))
 179
 180
 181 (defun ginspect-toplevels ()
 182   (ginspect (window-list-toplevels)))