[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
Peter Scott
pscott at common-lisp.net
Tue Feb 15 23:12:11 UTC 2005
Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector
In directory common-lisp.net:/tmp/cvs-serv15800
Modified Files:
inspector.lisp
Log Message:
Major changes: Added with-heading-style macro which currently bolds
its output, and changed a bunch of things to use this everywhere we
have headings. This makes the inspector look *much* nicer.
Minor change: turned a (loop for foo in bar do ...) into a DOLIST,
which uses less indentation and is arguably clearer.
Date: Wed Feb 16 00:12:08 2005
Author: pscott
Index: mcclim/Apps/Inspector/inspector.lisp
diff -u mcclim/Apps/Inspector/inspector.lisp:1.21 mcclim/Apps/Inspector/inspector.lisp:1.22
--- mcclim/Apps/Inspector/inspector.lisp:1.21 Fri Feb 11 22:41:25 2005
+++ mcclim/Apps/Inspector/inspector.lisp Wed Feb 16 00:12:07 2005
@@ -128,6 +128,12 @@
(declare (ignore acceptably for-context-type))
(format stream "~s" (cdr object)))
+(defmacro with-heading-style ((stream) &body body)
+ "Cause text output from BODY to be formatted in a heading font. This
+could be boldface, or a different style, or even another font."
+ `(with-text-face (,stream :bold)
+ , at body))
+
(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
@@ -140,7 +146,8 @@
(formatting-column (pane)
(formatting-cell (pane)
(surrounding-output-with-border (pane)
- ,header))
+ (with-heading-style (pane)
+ ,header)))
(formatting-cell (pane)
(formatting-table (pane)
, at body))))
@@ -151,7 +158,8 @@
environment created by INSPECTOR-TABLE."
`(formatting-row (pane)
(formatting-cell (pane :align-x :right)
- ,left)
+ (with-heading-style (pane)
+ ,left))
(formatting-cell (pane)
,right)))
@@ -159,7 +167,9 @@
"Print OBJECT's documentation, if any, to PANE"
(when (handler-bind ((warning #'muffle-warning))
(documentation object t))
- (format pane "~&Documentation: ~A" (documentation object t))))
+ (with-heading-style (pane)
+ (format pane "~&Documentation: "))
+ (princ (documentation object t) pane)))
(defun inspect-structure-or-object (object pane)
"Inspect a structure or an object. Since both can be inspected in
@@ -171,13 +181,13 @@
(print (class-name class) pane)
(when (clim-mop:class-direct-superclasses class)
(inspector-table-row
- (format pane "Superclasses")
+ (princ "Superclasses" pane)
(dolist (superclass (clim-mop:class-direct-superclasses class))
(inspect-object superclass pane)
(terpri pane))))
(when (clim-mop:class-direct-subclasses class)
(inspector-table-row
- (format pane "Subclasses")
+ (princ "Subclasses" pane)
(dolist (subclass (clim-mop:class-direct-subclasses class))
(inspect-object subclass pane)
(terpri pane))))
@@ -191,6 +201,8 @@
(inspect-object (slot-value object slot-name) pane)
(format pane "#<unbound slot>"))))))))
+;; Try to print the normal, textual representation of an object, but
+;; if that's too long, make an abbreviated "instance of ~S" version.
;; FIXME: should this be removed? It's really ugly.
(defparameter *object-representation-max-length* 300
"Maximum number of characters of an object's textual representation
@@ -208,9 +220,6 @@
(error ()
(format pane "#<unprintable ~S>" (class-name (class-of object)))))))
-;; Try to print the normal, textual representation of an object, but
-;; if that's too long, make an abbreviated "instance of ~S" version.
-
(defmethod inspect-object-briefly ((object standard-object) pane)
(inspect-structure-or-object-briefly object pane))
@@ -319,24 +328,24 @@
(inspector-table
(format pane "Generic Function: ~s"
(clim-mop:generic-function-name object))
- (loop for method in (clim-mop:generic-function-methods object)
- do (with-output-as-presentation
- (pane method (presentation-type-of method))
- (formatting-row (pane)
- (formatting-cell (pane)
- (print (method-qualifiers method)))
- (loop for specializer in (clim-mop:method-specializers method)
- do (formatting-cell (pane)
- (if (typep specializer 'clim-mop:eql-specializer)
- (progn
- (princ "(EQL " pane)
- (inspect-object
- (clim-mop:eql-specializer-object
- specializer)
- pane)
- (princ ")" pane))
- (inspect-object (class-name specializer)
- pane)))))))))
+ (dolist (method (clim-mop:generic-function-methods object))
+ (with-output-as-presentation
+ (pane method (presentation-type-of method))
+ (formatting-row (pane)
+ (formatting-cell (pane)
+ (print (method-qualifiers method)))
+ (loop for specializer in (clim-mop:method-specializers method)
+ do (formatting-cell (pane)
+ (if (typep specializer 'clim-mop:eql-specializer)
+ (progn
+ (princ "(EQL " pane)
+ (inspect-object
+ (clim-mop:eql-specializer-object
+ specializer)
+ pane)
+ (princ ")" pane))
+ (inspect-object (class-name specializer)
+ pane)))))))))
(defun pretty-print-function (fun)
"Print a function in a readable way, returning a string. On most
@@ -362,12 +371,15 @@
(defmethod inspect-object ((object function) pane)
(with-output-as-presentation
(pane object (presentation-type-of object))
- (format pane "Function: ~A"
- (pretty-print-function object))
+ (with-heading-style (pane)
+ (princ "Function: " pane))
+ (princ (pretty-print-function object) pane)
#+sbcl
(unless (typep object 'generic-function)
- (format pane "~&Type: ~A"
- (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object))))
+ (with-heading-style (pane)
+ (format pane "~&Type: "))
+ (princ (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object))
+ pane))
(print-documentation object pane)))
(defmethod inspect-object-briefly ((object package) pane)
@@ -386,8 +398,13 @@
(inspect-object nick pane)))
(inspector-table-row
(princ "Used by:")
+ ;; FIXME: This should use some sort of list formatting, so that
+ ;; it can obey conventions about *print-length* and reuse code
+ ;; for modifying it. To support this, list printing should
+ ;; support delimiterless, one-item-per-line display.
(dolist (used-by (package-used-by-list object))
- (inspect-object used-by pane)))
+ (fresh-line pane)
+ (inspect-object used-by pane)))
(inspector-table-row
(princ "Uses:")
(dolist (uses (package-use-list object))
@@ -580,19 +597,24 @@
(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))
- (format stream "~&Allocation: ~S~%"
- (clim-mop:slot-definition-allocation slot-object))
+ (with-heading-style (stream)
+ (format stream "~&Documentation: "))
+ (format stream "~A~%" documentation))
+ (with-heading-style (stream)
+ (format stream "~&Type: "))
+ (format stream "~S~%" (clim-mop:slot-definition-type slot-object))
+ (with-heading-style (stream)
+ (format stream "~&Allocation: "))
+ (format stream "~S~%" (clim-mop:slot-definition-allocation slot-object))
;; slot-definition-{readers,writers} only works for direct slot
;; definitions
(let ((readers (clim-mop:slot-definition-readers slot-object)))
(when readers
- (format stream "~&Readers: ")
+ (with-heading-style (stream)
+ (format stream "~&Readers: "))
(present readers (presentation-type-of readers) :stream stream)))
(let ((writers (clim-mop:slot-definition-writers slot-object)))
(when writers
- (format stream "~&Writers: ")
+ (with-heading-style (stream)
+ (format stream "~&Writers: "))
(present writers (presentation-type-of writers) :stream stream))))))
-
More information about the Mcclim-cvs
mailing list