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