[slime-cvs] CVS slime
heller
heller at common-lisp.net
Thu Aug 23 17:45:44 UTC 2007
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv22138
Modified Files:
ChangeLog swank.lisp
Log Message:
Moved Marco Baringer's inspector to contrib.
--- /project/slime/cvsroot/slime/ChangeLog 2007/08/23 16:21:23 1.1149
+++ /project/slime/cvsroot/slime/ChangeLog 2007/08/23 17:45:43 1.1150
@@ -1,3 +1,11 @@
+2007-08-23 Helmut Eller <heller at common-lisp.net>
+
+ Move Marco Baringer's inspector to contrib.
+
+ * swank.lisp (*default-inspector*): New variable. Set this
+ variable dispatch to different inspectors.
+ (inspect-object): Use it.
+
2007-08-23 Tobias C. Rittweiler <tcr at freebits.de>
Added arglist display for declaration specifiers and type
--- /project/slime/cvsroot/slime/swank.lisp 2007/08/23 16:19:56 1.494
+++ /project/slime/cvsroot/slime/swank.lisp 2007/08/23 17:45:44 1.495
@@ -4312,701 +4312,6 @@
(:value ,*readtable*) ") it is a macro character: "
(:value ,(get-macro-character char)))))))
-(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 ((symbol symbol) 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)))
- )))))
-
-(defmethod inspect-for-emacs ((f function) 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)
- (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)
- (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)
- (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)
- (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)
- (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.
- symbols ;; A list of symbols. Supposed to be sorted alphabetically.
- grouping-kind ;; Either :SYMBOL or :CLASSIFICATION. Cf. MAKE-SYMBOLS-LISTING.
- )
-
-(defun %make-package-symbols-container (&key title description symbols)
- (%%make-package-symbols-container :title title :description description
- :symbols symbols :grouping-kind :symbol))
-
-(defgeneric make-symbols-listing (grouping-kind symbols))
-
-(defmethod make-symbols-listing ((grouping-kind (eql :symbol)) symbols)
- "Returns an object renderable by Emacs' inspector side that
-alphabetically lists all the symbols in SYMBOLS together with a
-concise string representation of what each symbol
-represents (cf. CLASSIFY-SYMBOL & Fuzzy Completion.)"
- (let ((max-length (loop for s in symbols maximizing (length (symbol-name s))))
- (distance 10)) ; empty distance between name and classification
- (flet ((string-representations (symbol)
- (let* ((name (symbol-name symbol))
- (length (length name))
- (padding (- max-length length))
- (classification (classify-symbol symbol)))
- (values
- (concatenate 'string
- name
- (make-string (+ padding distance) :initial-element #\Space))
- (symbol-classification->string classification)))))
- `("" ; 8 is (length "Symbols:")
- "Symbols:" ,(make-string (+ -8 max-length distance) :initial-element #\Space) "Flags:"
- (:newline)
- ,(concatenate 'string ; underlining dashes
- (make-string (+ max-length distance -1) :initial-element #\-)
- " "
- (let* ((dummy (classify-symbol (gensym)))
- (dummy (symbol-classification->string dummy))
- (classification-length (length dummy)))
- (make-string classification-length :initial-element #\-)))
- (:newline)
- ,@(loop for symbol in symbols appending
- (multiple-value-bind (symbol-string classification-string)
- (string-representations symbol)
- `((:value ,symbol ,symbol-string) ,classification-string
- (:newline)
- )))))))
-
[321 lines skipped]
More information about the slime-cvs
mailing list