[slime-cvs] CVS slime/contrib
heller
heller at common-lisp.net
Thu Aug 23 17:46:31 UTC 2007
Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv22479
Modified Files:
ChangeLog
Added Files:
slime-fancy-inspector.el swank-fancy-inspector.lisp
Log Message:
Moved Marco Baringer's inspector to contrib.
--- /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/23 12:58:52 1.2
+++ /project/slime/cvsroot/slime/contrib/ChangeLog 2007/08/23 17:46:31 1.3
@@ -1,3 +1,14 @@
+2007-08-23 Helmut Eller <heller at common-lisp.net>
+
+ Move Marco Baringer's inspector to contrib.
+
+ * swank-fancy-inspector.lisp: New file. The only difference to the
+ code is that inspect-for-emacs methods in this file are
+ specialized to the new class `fancy-inspector'.
+ (fancy-inspector): New class.
+
+ * slime-fancy-inspector.el: New file.
+
2007-08-19 Helmut Eller <heller at common-lisp.net>
Moved fuzzy completion code to contrib directory.
--- /project/slime/cvsroot/slime/contrib/slime-fancy-inspector.el 2007/08/23 17:46:31 NONE
+++ /project/slime/cvsroot/slime/contrib/slime-fancy-inspector.el 2007/08/23 17:46:31 1.1
;;; slime-fancy-inspector.el --- Fancy inspector for CLOS objects
;;
;; Author: Marco Baringer <mb at bese.it> and others
;; License: GNU GPL (same license as Emacs)
;;
;;; Installation
;;
;; Add this to your .emacs:
;;
;; (add-to-list 'load-path "<directory-of-this-file>")
;; (add-hook 'slime-load-hook (lambda () (require 'slime-fancy-inspector)))
;;
(add-hook 'slime-connected-hook 'slime-install-fancy-inspector)
(defun slime-install-fancy-inspector ()
(slime-eval-async '(swank:swank-require :swank-fancy-inspector)))
(provide 'slime-fancy-inspector)--- /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2007/08/23 17:46:31 NONE
+++ /project/slime/cvsroot/slime/contrib/swank-fancy-inspector.lisp 2007/08/23 17:46:31 1.1
;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects
;;
;; Author: Marco Baringer <mb at bese.it> and others
;; License: Public Domain
;;
(in-package :swank)
(defclass fancy-inspector (inspector) ())
(defmethod inspect-for-emacs ((symbol symbol) (inspector fancy-inspector))
(declare (ignore inspector))
(let ((package (symbol-package symbol)))
(multiple-value-bind (_symbol status)
(and package (find-symbol (string symbol) package))
(declare (ignore _symbol))
(values
"A symbol."
(append
(label-value-line "Its name is" (symbol-name symbol))
;;
;; Value
(cond ((boundp symbol)
(label-value-line (if (constantp symbol)
"It is a constant of value"
"It is a global variable bound to")
(symbol-value symbol)))
(t '("It is unbound." (:newline))))
(docstring-ispec "Documentation" symbol 'variable)
(multiple-value-bind (expansion definedp) (macroexpand symbol)
(if definedp
(label-value-line "It is a symbol macro with expansion"
expansion)))
;;
;; Function
(if (fboundp symbol)
(append (if (macro-function symbol)
`("It a macro with macro-function: "
(:value ,(macro-function symbol)))
`("It is a function: "
(:value ,(symbol-function symbol))))
`(" " (:action "[make funbound]"
,(lambda () (fmakunbound symbol))))
`((:newline)))
`("It has no function value." (:newline)))
(docstring-ispec "Function Documentation" symbol 'function)
(if (compiler-macro-function symbol)
(label-value-line "It also names the compiler macro"
(compiler-macro-function symbol)))
(docstring-ispec "Compiler Macro Documentation"
symbol 'compiler-macro)
;;
;; Package
(if package
`("It is " ,(string-downcase (string status))
" to the package: "
(:value ,package ,(package-name package))
,@(if (eq :internal status)
`(" "
(:action "[export it]"
,(lambda () (export symbol package)))))
" "
(:action "[unintern it]"
,(lambda () (unintern symbol package)))
(:newline))
'("It is a non-interned symbol." (:newline)))
;;
;; Plist
(label-value-line "Property list" (symbol-plist symbol))
;;
;; Class
(if (find-class symbol nil)
`("It names the class "
(:value ,(find-class symbol) ,(string symbol))
" "
(:action "[remove]"
,(lambda () (setf (find-class symbol) nil)))
(:newline)))
;;
;; More package
(if (find-package symbol)
(label-value-line "It names the package" (find-package symbol)))
)))))
(defun docstring-ispec (label object kind)
"Return a inspector spec if OBJECT has a docstring of of kind KIND."
(let ((docstring (documentation object kind)))
(cond ((not docstring) nil)
((< (+ (length label) (length docstring))
75)
(list label ": " docstring '(:newline)))
(t
(list label ": " '(:newline) " " docstring '(:newline))))))
(defmethod inspect-for-emacs ((f function) (inspector fancy-inspector))
(declare (ignore inspector))
(values "A function."
(append
(label-value-line "Name" (function-name f))
`("Its argument list is: "
,(inspector-princ (arglist f)) (:newline))
(docstring-ispec "Documentation" f t)
(if (function-lambda-expression f)
(label-value-line "Lambda Expression"
(function-lambda-expression f))))))
(defun method-specializers-for-inspect (method)
"Return a \"pretty\" list of the method's specializers. Normal
specializers are replaced by the name of the class, eql
specializers are replaced by `(eql ,object)."
(mapcar (lambda (spec)
(typecase spec
(swank-mop:eql-specializer
`(eql ,(swank-mop:eql-specializer-object spec)))
(t (swank-mop:class-name spec))))
(swank-mop:method-specializers method)))
(defun method-for-inspect-value (method)
"Returns a \"pretty\" list describing METHOD. The first element
of the list is the name of generic-function method is
specialiazed on, the second element is the method qualifiers,
the rest of the list is the method's specialiazers (as per
method-specializers-for-inspect)."
(append (list (swank-mop:generic-function-name
(swank-mop:method-generic-function method)))
(swank-mop:method-qualifiers method)
(method-specializers-for-inspect method)))
(defmethod inspect-for-emacs ((object standard-object)
(inspector fancy-inspector))
(let ((class (class-of object)))
(values "An object."
`("Class: " (:value ,class) (:newline)
,@(all-slots-for-inspector object inspector)))))
(defvar *gf-method-getter* 'methods-by-applicability
"This function is called to get the methods of a generic function.
The default returns the method sorted by applicability.
See `methods-by-applicability'.")
(defun specializer< (specializer1 specializer2)
"Return true if SPECIALIZER1 is more specific than SPECIALIZER2."
(let ((s1 specializer1) (s2 specializer2) )
(cond ((typep s1 'swank-mop:eql-specializer)
(not (typep s2 'swank-mop:eql-specializer)))
(t
(flet ((cpl (class)
(and (swank-mop:class-finalized-p class)
(swank-mop:class-precedence-list class))))
(member s2 (cpl s1)))))))
(defun methods-by-applicability (gf)
"Return methods ordered by most specific argument types.
`method-specializer<' is used for sorting."
;; FIXME: argument-precedence-order and qualifiers are ignored.
(labels ((method< (meth1 meth2)
(loop for s1 in (swank-mop:method-specializers meth1)
for s2 in (swank-mop:method-specializers meth2)
do (cond ((specializer< s2 s1) (return nil))
((specializer< s1 s2) (return t))))))
(stable-sort (copy-seq (swank-mop:generic-function-methods gf)) #'method<)))
(defun abbrev-doc (doc &optional (maxlen 80))
"Return the first sentence of DOC, but not more than MAXLAN characters."
(subseq doc 0 (min (1+ (or (position #\. doc) (1- maxlen)))
maxlen
(length doc))))
(defgeneric inspect-slot-for-emacs (class object slot)
(:method (class object slot)
(let ((slot-name (swank-mop:slot-definition-name slot))
(boundp (swank-mop:slot-boundp-using-class class object slot)))
`(,@(if boundp
`((:value ,(swank-mop:slot-value-using-class class object slot)))
`("#<unbound>"))
" "
(:action "[set value]"
,(lambda () (with-simple-restart
(abort "Abort setting slot ~S" slot-name)
(let ((value-string (eval-in-emacs
`(condition-case c
(slime-read-object
,(format nil "Set slot ~S to (evaluated) : " slot-name))
(quit nil)))))
(when (and value-string
(not (string= value-string "")))
(setf (swank-mop:slot-value-using-class class object slot)
(eval (read-from-string value-string))))))))
,@(when boundp
`(" " (:action "[make unbound]"
,(lambda () (swank-mop:slot-makunbound-using-class class object slot)))))))))
(defgeneric all-slots-for-inspector (object inspector)
(:method ((object standard-object) inspector)
(declare (ignore inspector))
(append '("--------------------" (:newline)
"All Slots:" (:newline))
(let* ((class (class-of object))
(direct-slots (swank-mop:class-direct-slots class))
(effective-slots (sort (copy-seq (swank-mop:class-slots class))
#'string< :key #'swank-mop:slot-definition-name))
(slot-presentations (loop for effective-slot :in effective-slots
collect (inspect-slot-for-emacs
class object effective-slot)))
(longest-slot-name-length
(loop for slot :in effective-slots
maximize (length (symbol-name
(swank-mop:slot-definition-name slot))))))
(loop
for effective-slot :in effective-slots
for slot-presentation :in slot-presentations
for direct-slot = (find (swank-mop:slot-definition-name effective-slot)
direct-slots :key #'swank-mop:slot-definition-name)
for slot-name = (inspector-princ
(swank-mop:slot-definition-name effective-slot))
for padding-length = (- longest-slot-name-length
(length (symbol-name
(swank-mop:slot-definition-name
effective-slot))))
collect `(:value ,(if direct-slot
(list direct-slot effective-slot)
effective-slot)
,slot-name)
collect (make-array padding-length
:element-type 'character
:initial-element #\Space)
collect " = "
append slot-presentation
collect '(:newline))))))
(defmethod inspect-for-emacs ((gf standard-generic-function)
(inspector fancy-inspector))
(flet ((lv (label value) (label-value-line label value)))
(values
"A generic function."
(append
(lv "Name" (swank-mop:generic-function-name gf))
(lv "Arguments" (swank-mop:generic-function-lambda-list gf))
(docstring-ispec "Documentation" gf t)
(lv "Method class" (swank-mop:generic-function-method-class gf))
(lv "Method combination"
(swank-mop:generic-function-method-combination gf))
`("Methods: " (:newline))
(loop for method in (funcall *gf-method-getter* gf) append
`((:value ,method ,(inspector-princ
;; drop the name of the GF
(cdr (method-for-inspect-value method))))
" "
(:action "[remove method]"
,(let ((m method)) ; LOOP reassigns method
(lambda ()
(remove-method gf m))))
(:newline)))
`((:newline))
(all-slots-for-inspector gf inspector)))))
(defmethod inspect-for-emacs ((method standard-method)
(inspector fancy-inspector))
(values "A method."
`("Method defined on the generic function "
(:value ,(swank-mop:method-generic-function method)
,(inspector-princ
(swank-mop:generic-function-name
(swank-mop:method-generic-function method))))
(:newline)
,@(docstring-ispec "Documentation" method t)
"Lambda List: " (:value ,(swank-mop:method-lambda-list method))
(:newline)
"Specializers: " (:value ,(swank-mop:method-specializers method)
,(inspector-princ (method-specializers-for-inspect method)))
(:newline)
"Qualifiers: " (:value ,(swank-mop:method-qualifiers method))
(:newline)
"Method function: " (:value ,(swank-mop:method-function method))
(:newline)
,@(all-slots-for-inspector method inspector))))
(defmethod inspect-for-emacs ((class standard-class)
(inspector fancy-inspector))
(values "A class."
`("Name: " (:value ,(class-name class))
(:newline)
"Super classes: "
,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
(:newline)
"Direct Slots: "
,@(common-seperated-spec
(swank-mop:class-direct-slots class)
(lambda (slot)
`(:value ,slot ,(inspector-princ (swank-mop:slot-definition-name slot)))))
(:newline)
"Effective Slots: "
,@(if (swank-mop:class-finalized-p class)
(common-seperated-spec
(swank-mop:class-slots class)
(lambda (slot)
`(:value ,slot ,(inspector-princ
(swank-mop:slot-definition-name slot)))))
'("#<N/A (class not finalized)>"))
(:newline)
,@(let ((doc (documentation class t)))
(when doc
`("Documentation:" (:newline) ,(inspector-princ doc) (:newline))))
"Sub classes: "
,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
(lambda (sub)
`(:value ,sub ,(inspector-princ (class-name sub)))))
(:newline)
"Precedence List: "
,@(if (swank-mop:class-finalized-p class)
(common-seperated-spec (swank-mop:class-precedence-list class)
(lambda (class)
`(:value ,class ,(inspector-princ (class-name class)))))
'("#<N/A (class not finalized)>"))
(:newline)
,@(when (swank-mop:specializer-direct-methods class)
`("It is used as a direct specializer in the following methods:" (:newline)
,@(loop
for method in (sort (copy-seq (swank-mop:specializer-direct-methods class))
#'string< :key (lambda (x)
(symbol-name
(let ((name (swank-mop::generic-function-name
(swank-mop::method-generic-function x))))
(if (symbolp name) name (second name))))))
collect " "
collect `(:value ,method ,(inspector-princ (method-for-inspect-value method)))
collect '(:newline)
if (documentation method t)
collect " Documentation: " and
collect (abbrev-doc (documentation method t)) and
collect '(:newline))))
"Prototype: " ,(if (swank-mop:class-finalized-p class)
`(:value ,(swank-mop:class-prototype class))
'"#<N/A (class not finalized)>")
(:newline)
,@(all-slots-for-inspector class inspector))))
(defmethod inspect-for-emacs ((slot swank-mop:standard-slot-definition)
(inspector fancy-inspector))
(values "A slot."
`("Name: " (:value ,(swank-mop:slot-definition-name slot))
(:newline)
,@(when (swank-mop:slot-definition-documentation slot)
`("Documentation:" (:newline)
(:value ,(swank-mop:slot-definition-documentation slot))
(:newline)))
"Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
"Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
`(:value ,(swank-mop:slot-definition-initform slot))
"#<unspecified>") (:newline)
"Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
(:newline)
,@(all-slots-for-inspector slot inspector))))
;; Wrapper structure over the list of symbols of a package that should
;; be displayed with their respective classification flags. This is
;; because we need a unique type to dispatch on in INSPECT-FOR-EMACS.
;; Used by the Inspector for packages.
(defstruct (%package-symbols-container (:conc-name %container.)
(:constructor %%make-package-symbols-container))
title ;; A string; the title of the inspector page in Emacs.
description ;; A list of renderable objects; used as description.
[360 lines skipped]
More information about the slime-cvs
mailing list