Added dependency to the gtk system and a couple of bug fixes

[clg] / examples / ginspect.lisp

(in-package :gtk)

(defvar *ginspect-unbound-object-marker* 
  #+cmu (gensym "UNBOUND-OBJECT-")
  #+sbcl sb-impl::*inspect-unbound-object-marker*)


(defgeneric insert-object (object store parent &optional prefix))
(defgeneric insert-parts (object store parent))
(defgeneric object-has-parts-p (object))
(defgeneric decompose-describe-object (object))


(defun ginspect (object)
  (let* ((store (make-instance 'tree-store 
		 :column-types '(string string gobject boolean)
		 :column-names '(name pprinted object expanded)))
	 (view (make-instance 'tree-view :model store :headers-visible nil)))

    (let ((column (make-instance 'tree-view-column))
 	  (name (make-instance 'cell-renderer-text))
 	  (object (make-instance 'cell-renderer-text)))	  
      (tree-view-append-column view column)
      (cell-layout-pack column name :expand nil)
      (cell-layout-add-attribute column name 'text (column-index store 'name))
      (cell-layout-pack column object :expand t)
      (cell-layout-add-attribute column object 'text (column-index store 'pprinted)))

    (insert-object object store nil)

    (signal-connect view 'row-expanded 
     #'(lambda (iter path)
	 (when (setf 
		(tree-model-value store iter 'expanded)
		(not (tree-model-value store iter 'expanded)))
	   (multiple-value-bind (valid child-iter) 
	       (tree-model-iter-children store iter)
	     ;; Remove old children
	     (when valid
	       (loop while (tree-store-remove store child-iter))))
	   (let ((gobject (tree-model-value store iter 'object)))
	     (insert-parts (object-data gobject 'object) store iter))
	   (tree-view-expand-row view path nil))))

    (make-instance 'dialog
     :title "Object Inspector" :show-children t :visible t
     :default-width 600 :default-height 600
     :button (list "gtk-close" #'widget-destroy :object t)
     :child (make-instance 'scrolled-window 
	     :hscrollbar-policy :automatic :child view))))


(defmethod decompose-describe-object ((object t))
  #+cmu
  (destructuring-bind (description named-p &rest parts) 
      (inspect::describe-parts object)
    (if (equal parts (list object))
	(values description nil nil)
      (values description named-p parts)))
  (sb-impl::inspected-parts object))

(defmethod decompose-describe-object ((object (eql t)))
  (values (call-next-method) nil nil))

(defmethod decompose-describe-object ((object (eql nil)))
  (values (call-next-method) nil nil))

(defun propper-list-p (object)
  (and (listp object) (null (cdr (last object)))))

(defmethod decompose-describe-object ((object cons))
  (if (propper-list-p object)
      (values (call-next-method) nil object)
    (values "The object is a CONS." nil (list (car object) (cdr object)))))

(defmethod decompose-describe-object ((object #+cmu alien:system-area-pointer
					      #+sbcl sb-alien:system-area-pointer))
  (values "The object is a SYSTEM-AREA-POINTER" nil nil))

(defmethod decompose-describe-object ((object (eql *ginspect-unbound-object-marker*)))
  (values "The slot is unbound" nil nil))

#+cmu
(defmethod decompose-describe-object ((object symbol))
  (values 
   (call-next-method) t
   (cons "Name" (symbol-name object)) 
   (cons "Package" (symbol-package objecy))
   (cons "Value" (if (boundp object)
		     (symbol-value object)
		   *ginspect-unbound-object-marker*))
   (cons "Function" (if (fboundp object)
			(symbol-function  object)
		      *ginspect-unbound-object-marker*))
   (cons "Plist" (symbol-plist object))))

#+cmu
(defmethod decompose-describe-object ((object standard-object))
  (values 
   (call-next-method) t
   (loop
    for slotd in (class-slots (class-of object))
    collect (let* ((slot-name (pcl:slot-definition-name slotd))
		   (slot-value (if (slot-boundp object slot-name)
				   (slot-value object slot-name)
				 *ginspect-unbound-object-marker*)))
	      (cons (string slot-name) slot-value)))))


(defmethod object-has-parts-p ((object t))
  (nth-value 2 (decompose-describe-object object)))

(defmethod object-has-parts-p ((object cons))
  t)

(defmethod object-has-parts-p ((object standard-object))
  (class-slots (class-of object)))

(defmethod object-has-parts-p ((object vector))
  (not (zerop (length object))))


(defmethod object-to-string ((object t))
  (with-output-to-string (stream)
    (write object :stream stream :lines 1 :right-margin 80)))

(defmethod object-to-string ((object (eql *ginspect-unbound-object-marker*)))
  "<unbound>")

(defmethod insert-object ((object t) store parent &optional (name ""))
  (let ((gobject (make-instance 'gobject)) ; to "hang" the lisp object on
	(has-parts (object-has-parts-p object)))
    (setf (object-data gobject 'object) object)
    (let ((iter (tree-store-append store parent 
		 (vector name (object-to-string object) 
			 gobject (not has-parts)))))
      (when has-parts
	;; Insert dummy child
	(tree-store-append store iter (vector "" "" gobject t))))))

(defmethod insert-parts :around ((object t) store parent)
  (when (object-has-parts-p object)
    (call-next-method)))

(defmethod insert-parts ((object t) store parent)
  (multiple-value-bind (description named-p parts) 
      (decompose-describe-object object)
    (declare (ignore description))
    (loop
     for part in parts
     do (if named-p
	    (insert-object (cdr part) store parent (string (car part)))
	  (insert-object part store parent)))))


(defun ginspect-toplevels ()
  (ginspect (window-list-toplevels)))