[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
Peter Scott
pscott at common-lisp.net
Thu Feb 3 20:14:58 UTC 2005
Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector
In directory common-lisp.net:/tmp/cvs-serv5675
Modified Files:
inspector.lisp
Log Message:
Added class-like inspection of structures, characters are inspected
non-annoyingly, documentation strings are displayed where possible,
the source code has been commented and documented more, and some
other features and bug fixes have been added.
Date: Thu Feb 3 21:14:57 2005
Author: pscott
Index: mcclim/Apps/Inspector/inspector.lisp
diff -u mcclim/Apps/Inspector/inspector.lisp:1.9 mcclim/Apps/Inspector/inspector.lisp:1.10
--- mcclim/Apps/Inspector/inspector.lisp:1.9 Wed Feb 2 11:16:59 2005
+++ mcclim/Apps/Inspector/inspector.lisp Thu Feb 3 21:14:57 2005
@@ -24,8 +24,11 @@
(in-package :clouseau)
+(define-modify-macro togglef () not)
+
(define-application-frame inspector ()
((dico :initform (make-hash-table) :reader dico)
+ (cons-cell-dico :initform (make-hash-table) :reader cons-cell-dico)
(obj :initarg :obj :reader obj))
(:pointer-documentation t)
(:panes
@@ -55,16 +58,23 @@
(run-frame-top-level
(make-application-frame 'inspector :obj obj))))
-(defparameter *inspected-objects* '())
+(defparameter *inspected-objects* '()
+ "A list of objects which are currently being inspected with
+INSPECT-OBJECT")
+
+(defgeneric inspect-object-briefly (object pane)
+ (:documentation "Inspect an object in a short form, displaying this
+on PANE. For example, rather than displaying all the slots of a class,
+only the class name would be shown."))
-(defgeneric inspect-object-briefly (object pane))
-(defgeneric inspect-object (object pane))
+(defgeneric inspect-object (object pane)
+ (:documentation "Inspect an object, displaying it on PANE"))
(defmethod inspect-object :around (object pane)
(cond ((member object *inspected-objects*)
(with-output-as-presentation
(pane object (presentation-type-of object))
- (princ "===")))
+ (princ "==="))) ; Prevent infinite loops
((not (gethash object (dico *application-frame*)))
(inspect-object-briefly object pane))
(t
@@ -84,6 +94,8 @@
(define-presentation-type settable-slot ()
:inherit-from t)
+(define-presentation-type cons ()
+ :inherit-from t)
(define-presentation-method present (object (type settable-slot)
stream
@@ -93,6 +105,11 @@
(format stream "~s" (cdr object)))
(defmacro inspector-table (header &body body)
+ "Present OBJECT (captured from environment) in tabular form, with
+HEADER printed in a box at the top. BODY should output the rows of the
+table using INSPECTOR-TABLE-ROW. Also capured from the macro's
+environment is PANE, which is the pane on which the table will be
+drawn."
`(with-output-as-presentation
(pane object (presentation-type-of object))
(formatting-table (pane)
@@ -102,32 +119,54 @@
,header))
(formatting-cell (pane)
(formatting-table (pane)
- , at body))))))
+ , at body))))
+ (print-documentation object pane)))
(defmacro inspector-table-row (left right)
+ "Output a table row with two items, LEFT and RIGHT, in the
+environment created by INSPECTOR-TABLE."
`(formatting-row (pane)
(formatting-cell (pane :align-x :right)
,left)
(formatting-cell (pane)
,right)))
+(defun print-documentation (object pane)
+ "Print OBJECT's documentation, if any, to PANE"
+ (when (handler-bind ((warning #'muffle-warning))
+ (documentation object t))
+ (format pane "~&Documentation: ~A" (documentation object t))))
+
+(defun inspect-structure-or-object (object pane)
+ "Inspect a structure or an object. Since both can be inspected in
+roughly the same way, the common code is in this function, which is
+called by the INSPECT-OBJECT methods for both standard objects and
+structure objects."
+ (let ((class (class-of object)))
+ (inspector-table
+ (print (class-name class) pane)
+ (loop for slot in (reverse (clim-mop:class-slots class))
+ do (let ((slot-name (clim-mop:slot-definition-name slot)))
+ (inspector-table-row
+ (with-output-as-presentation
+ (pane (cons object slot-name) 'settable-slot)
+ (format pane "~a:" slot-name))
+ (inspect-object (slot-value object slot-name) pane)))))))
+
(defmethod inspect-object-briefly ((object standard-object) pane)
(with-output-as-presentation
(pane object (presentation-type-of object))
(format pane "instance of ~S" (class-name (class-of object)))))
(defmethod inspect-object ((object standard-object) pane)
- (let ((class (class-of object)))
- (inspector-table
- (print (class-name class) pane)
- (loop for slot in (reverse (clim-mop:class-slots class))
- do (let ((slot-name (clim-mop:slot-definition-name slot)))
- (inspector-table-row
- (with-output-as-presentation
- (pane (cons object slot-name) 'settable-slot)
- (format pane "~a:" slot-name))
- (inspect-object (slot-value object slot-name) pane)))))))
+ (inspect-structure-or-object object pane))
-(defmethod inspect-object ((object cons) pane)
+(defmethod inspect-object ((object structure-object) pane)
+ (inspect-structure-or-object object pane))
+
+(defun inspect-cons-as-cells (object pane)
+ "Inspect a cons cell in a fancy graphical way. The inconvenient part
+is that this necessarily involves quite a bit of clicking to show a
+moderately-sized list."
(if (null (cdr object))
(formatting-table (pane)
(formatting-column (pane)
@@ -157,6 +196,44 @@
(formatting-cell (pane)
(inspect-object (cdr object) pane))))))
+(defun inspect-cons-as-list (object pane)
+ "Inspect a cons cell in a traditional, plain-text format. The only
+difference between this and simply using the Lisp printer is that this
+code takes advantage of CLIM's tables and presentations to make the
+list as interactive as you would expect."
+ (with-output-as-presentation
+ (pane object 'cons)
+ (formatting-table (pane)
+ (formatting-row (pane)
+ (formatting-cell (pane)
+ (princ "(" pane))
+ (do
+ ((length 0 (1+ length))
+ (cdr (cdr object) (cdr cdr))
+ (car (car object) (car cdr)))
+ ((cond ((eq nil cdr)
+ (formatting-cell (pane) (inspect-object car pane))
+ (formatting-cell (pane) (princ ")" pane))
+ t)
+ ((not (consp cdr))
+ (formatting-cell (pane) (inspect-object car pane))
+ (formatting-cell (pane) (princ "." pane))
+ (formatting-cell (pane) (inspect-object cdr pane))
+ (formatting-cell (pane) (princ ")" pane))
+ t)
+ ((>= length *print-length*)
+ (formatting-cell (pane) (inspect-object car pane))
+ (formatting-cell (pane) (princ "..." pane))
+ t)
+ (t nil)))
+ (formatting-cell (pane) (inspect-object car pane)))))))
+
+(defmethod inspect-object ((object cons) pane)
+ (if (gethash object (cons-cell-dico *application-frame*))
+ (inspect-cons-as-cells object pane)
+ (inspect-cons-as-list object pane)))
+
+
(defmethod inspect-object-briefly ((object hash-table) pane)
(with-output-as-presentation
(pane object (presentation-type-of object))
@@ -185,6 +262,33 @@
do (formatting-cell (pane)
(format pane "~s " (class-name specializer)))))))))
+(defun pretty-print-function (fun)
+ "Print a function in a readable way, returning a string. On most
+implementations this just uses the standard Lisp printer, but it can
+use implementation-specific functions to be more informative."
+ (flet ((generic-print (fun)
+ (with-output-to-string (string)
+ (prin1 fun string))))
+ ;; If we have SBCL, try to do fancy formatting. If anything goes
+ ;; wrong with that, fall back on ugly standard PRIN1.
+ #+sbcl (handler-case (format nil "~A ~S"
+ (sb-impl::%simple-fun-name fun)
+ (sb-impl::%simple-fun-arglist fun))
+ (error () (generic-print fun)))
+ ;; FIXME: Other Lisp implementations have ways of getting this
+ ;; information. If you want a better inspector on a non-SBCL Lisp,
+ ;; please add code for it and send patches.
+ #-sbcl (generic-print fun)))
+
+(defmethod inspect-object ((object function) pane)
+ (with-output-as-presentation
+ (pane object (presentation-type-of object))
+ (format pane "Function: ~A"
+ (pretty-print-function object))
+ #+sbcl (format pane "~&Type: ~A"
+ (sb-impl::%simple-fun-type object))
+ (print-documentation object pane)))
+
(defmethod inspect-object-briefly ((object package) pane)
(with-output-as-presentation
(pane object (presentation-type-of object))
@@ -231,7 +335,10 @@
(pane object (presentation-type-of object))
(print object)))
-(defmethod inspect-object ((object complex) pane)
+(defun inspect-complex (object pane)
+ "Inspect a complex number. Since complex numbers should be inspected
+the same way briefly and fully, this function can be called by both of
+them."
(with-output-as-presentation
(pane object (presentation-type-of object))
(formatting-table (pane)
@@ -245,6 +352,12 @@
(formatting-cell (pane)
(princ ")" pane))))))
+(defmethod inspect-object-briefly ((object complex) pane)
+ (inspect-complex object pane))
+
+(defmethod inspect-object ((object complex) pane)
+ (inspect-complex object pane))
+
(defmethod inspect-object ((object float) pane)
(inspector-table
(format pane "float ~S" object)
@@ -267,6 +380,7 @@
(with-output-as-presentation
(pane object (presentation-type-of object))
(print object)))
+
(defmethod inspect-object ((object symbol) pane)
(inspector-table
(format pane "Symbol ~S" (symbol-name object))
@@ -287,8 +401,17 @@
(princ "propery list:")
(dolist (property (symbol-plist object))
(inspect-object property pane)))))
+(make-instance 'packrat)
+;; Characters are so short that displaying them as "..." takes almost
+;; as much space as just showing them, and this way is more
+;; informative.
+(defmethod inspect-object-briefly ((object character) pane)
+ (with-output-as-presentation
+ (pane object (presentation-type-of object))
+ (print object pane)))
(defun display-app (frame pane)
+ "Display the APP frame of the inspector"
(inspect-object (obj frame) pane))
(define-inspector-command (com-quit :name t) ()
@@ -297,13 +420,16 @@
(define-inspector-command (com-inspect :name t) ()
(let ((obj (accept t :prompt "Select an object")))
(clim-sys:make-process #'(lambda () (inspector obj))
- :name "inspector")))
+ :name "Inspector Clouseau")))
+
+(define-inspector-command (com-toggle-show-list-cells :name t)
+ ((obj 'cons :gesture :select :prompt "Select a cons or list"))
+ (togglef (gethash obj (cons-cell-dico *application-frame*))))
(define-inspector-command (com-toggle-inspect :name t)
((obj t :gesture :select :prompt "Select an object"))
(unless (eq obj (obj *application-frame*))
- (setf (gethash obj (dico *application-frame*))
- (not (gethash obj (dico *application-frame*))))))
+ (togglef (gethash obj (dico *application-frame*)))))
(define-inspector-command (com-remove-method :name t)
((obj 'method :gesture :delete :prompt "Remove method"))
@@ -313,3 +439,33 @@
((slot 'settable-slot :gesture :select :prompt "Set slot"))
(setf (slot-value (car slot) (cdr slot))
(accept t :prompt "New slot value")))
+
+(defun slot-documentation (class slot)
+ "Returns the documentation of a slot of a class, or nil. There is,
+unfortunately, no portable way to do this, but the MOP is
+semi-portable and we can use it. To complicate things even more, some
+implementations have unpleasant oddities in the way they store slot
+documentation. For example, in SBCL slot documentation is only
+available in direct slots."
+ (let ((slot-object (find slot (clim-mop:class-direct-slots class)
+ :key #'clim-mop:slot-definition-name)))
+ (if slot-object
+ (documentation slot-object t)
+ (when (clim-mop:class-direct-superclasses class)
+ (find-if #'identity
+ (mapcar #'(lambda (class)
+ (slot-documentation class slot))
+ (clim-mop:class-direct-superclasses class)))))))
+
+(define-inspector-command (com-describe-slot :name t)
+ ((slot 'settable-slot :gesture :describe :prompt "Describe slot"))
+ (destructuring-bind (object . slot-name) slot
+ (let* ((stream (get-frame-pane *application-frame* 'int))
+ (class (class-of object))
+ (documentation (slot-documentation class slot-name))
+ (slot-object (find slot-name (clim-mop:class-slots class)
+ :key #'clim-mop:slot-definition-name)))
+ (when documentation
+ (format stream "~&Documentation: ~A~%" documentation))
+ (format stream "~&Type: ~S~%"
+ (clim-mop:slot-definition-type slot-object)))))
\ No newline at end of file
More information about the Mcclim-cvs
mailing list