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