(in-package :swank)
(eval-when (:compile-toplevel :load-toplevel :execute)
(swank-require :swank-util))
(defmethod emacs-inspect ((symbol symbol))
(let ((package (symbol-package symbol)))
(multiple-value-bind (_symbol status)
(and package (find-symbol (string symbol) package))
(declare (ignore _symbol))
(append
(label-value-line "Its name is" (symbol-name symbol))
(cond ((boundp symbol)
(append
(label-value-line (if (constantp symbol)
"It is a constant of value"
"It is a global variable bound to")
(symbol-value symbol) :newline nil)
`(" " (:action "[unbind]"
,(lambda () (makunbound symbol))))
'((:newline))))
(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)))
(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 "[unbind]"
,(lambda () (fmakunbound symbol))))
`((:newline)))
`("It has no function value." (:newline)))
(docstring-ispec "Function documentation" symbol 'function)
(when (compiler-macro-function symbol)
(append
(label-value-line "It also names the compiler macro"
(compiler-macro-function symbol) :newline nil)
`(" " (:action "[remove]"
,(lambda ()
(setf (compiler-macro-function symbol) nil)))
(:newline))))
(docstring-ispec "Compiler macro documentation"
symbol 'compiler-macro)
(if package
`("It is " ,(string-downcase (string status))
" to the package: "
(:value ,package ,(package-name package))
,@(if (eq :internal status)
`(" "
(:action "[export]"
,(lambda () (export symbol package)))))
" "
(:action "[unintern]"
,(lambda () (unintern symbol package)))
(:newline))
'("It is a non-interned symbol." (:newline)))
(label-value-line "Property list" (symbol-plist symbol))
(if (find-class symbol nil)
`("It names the class "
(:value ,(find-class symbol) ,(string symbol))
" "
(:action "[remove]"
,(lambda () (setf (find-class symbol) nil)))
(:newline)))
(if (find-package symbol)
(label-value-line "It names the package" (find-package symbol)))
(inspect-type-specifier symbol)))))
#-sbcl
(defun inspect-type-specifier (symbol)
(declare (ignore symbol)))
#+sbcl
(defun inspect-type-specifier (symbol)
(let* ((kind (sb-int:info :type :kind symbol))
(fun (case kind
(:defined
(or (sb-int:info :type :expander symbol) t))
(:primitive
(or #.(if (swank/sbcl::sbcl-version>= 1 3 1)
'(let ((x (sb-int:info :type :expander symbol)))
(if (consp x)
(car x)
x))
'(sb-int:info :type :translator symbol))
t)))))
(when fun
(append
(list
(format nil "It names a ~@[primitive~* ~]type-specifier."
(eq kind :primitive))
'(:newline))
(docstring-ispec "Type-specifier documentation" symbol 'type)
(unless (eq t fun)
(let ((arglist (arglist fun)))
(append
`("Type-specifier lambda-list: "
,(if arglist
(inspector-princ arglist)
"()")
(:newline))
(multiple-value-bind (expansion ok)
(handler-case (sb-ext:typexpand-1 symbol)
(error () (values nil nil)))
(when ok
(list "Type-specifier expansion: "
(princ-to-string expansion)))))))))))
(defun docstring-ispec (label object kind)
"Return a inspector spec if OBJECT has a docstring 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))))))
(unless (find-method #'emacs-inspect '() (list (find-class 'function)) nil)
(defmethod emacs-inspect ((f function))
(inspect-function f)))
(defun inspect-function (f)
(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)))
#-sbcl
(t
(swank-mop:class-name spec))
#+sbcl
(t
(let ((gf (sb-mop:method-generic-function method)))
(cond (gf
(sb-pcl:unparse-specializer-using-class gf spec))
((typep spec 'class)
(class-name spec))
(t
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 emacs-inspect ((object standard-object))
(let ((class (class-of object)))
`("Class: " (:value ,class) (:newline)
,@(all-slots-for-inspector object))))
(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)))
((typep s1 'class)
(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."
(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))))
(defstruct (inspector-checklist (:conc-name checklist.)
(:constructor %make-checklist (buttons)))
(buttons nil :type (or null simple-vector))
(count 0))
(defun make-checklist (n)
(%make-checklist (make-array n :initial-element nil)))
(defun reinitialize-checklist (checklist)
(setf (checklist.count checklist) 0)
checklist)
(defun make-checklist-button (checklist)
(let ((buttons (checklist.buttons checklist))
(i (checklist.count checklist)))
(incf (checklist.count checklist))
`(:action ,(if (svref buttons i)
"[X]"
"[ ]")
,#'(lambda ()
(setf (svref buttons i) (not (svref buttons i))))
:refreshp t)))
(defmacro do-checklist ((idx checklist) &body body)
"Iterate over all set buttons in CHECKLIST."
(let ((buttons (gensym "buttons")))
`(let ((,buttons (checklist.buttons ,checklist)))
(dotimes (,idx (length ,buttons))
(when (svref ,buttons ,idx)
,@body)))))
(defun box (thing) (cons :box thing))
(defun ref (box)
(assert (eq (car box) :box))
(cdr box))
(defun (setf ref) (value box)
(assert (eq (car box) :box))
(setf (cdr box) value))
(defvar *inspector-slots-default-order* :alphabetically
"Accepted values: :alphabetically and :unsorted")
(defvar *inspector-slots-default-grouping* :all
"Accepted values: :inheritance and :all")
(defgeneric all-slots-for-inspector (object))
(defmethod all-slots-for-inspector ((object standard-object))
(let* ((class (class-of object))
(direct-slots (swank-mop:class-direct-slots class))
(effective-slots (swank-mop:class-slots class))
(longest-slot-name-length
(loop for slot :in effective-slots
maximize (length (symbol-name
(swank-mop:slot-definition-name slot)))))
(checklist
(reinitialize-checklist
(ensure-istate-metadata object :checklist
(make-checklist (length effective-slots)))))
(grouping-kind
(ensure-istate-metadata object :grouping-kind
(box *inspector-slots-default-grouping*)))
(sort-order
(ensure-istate-metadata object :sort-order
(box *inspector-slots-default-order*)))
(sort-predicate (ecase (ref sort-order)
(:alphabetically #'string<)
(:unsorted (constantly nil))))
(sorted-slots (sort (copy-seq effective-slots)
sort-predicate
:key #'swank-mop:slot-definition-name))
(effective-slots
(ecase (ref grouping-kind)
(:all sorted-slots)
(:inheritance (stable-sort-by-inheritance sorted-slots
class sort-predicate)))))
`("--------------------"
(:newline)
" Group slots by inheritance "
(:action ,(ecase (ref grouping-kind)
(:all "[ ]")
(:inheritance "[X]"))
,(lambda ()
(fill (checklist.buttons checklist) nil)
(setf (ref grouping-kind)
(ecase (ref grouping-kind)
(:all :inheritance)
(:inheritance :all))))
:refreshp t)
(:newline)
" Sort slots alphabetically "
(:action ,(ecase (ref sort-order)
(:unsorted "[ ]")
(:alphabetically "[X]"))
,(lambda ()
(fill (checklist.buttons checklist) nil)
(setf (ref sort-order)
(ecase (ref sort-order)
(:unsorted :alphabetically)
(:alphabetically :unsorted))))
:refreshp t)
(:newline)
,@ (case (ref grouping-kind)
(:all
`((:newline)
"All Slots:"
(:newline)
,@(make-slot-listing checklist object class
effective-slots direct-slots
longest-slot-name-length)))
(:inheritance
(list-all-slots-by-inheritance checklist object class
effective-slots direct-slots
longest-slot-name-length)))
(:newline)
(:action "[set value]"
,(lambda ()
(do-checklist (idx checklist)
(query-and-set-slot class object
(nth idx effective-slots))))
:refreshp t)
" "
(:action "[make unbound]"
,(lambda ()
(do-checklist (idx checklist)
(swank-mop:slot-makunbound-using-class
class object (nth idx effective-slots))))
:refreshp t)
(:newline))))
(defun list-all-slots-by-inheritance (checklist object class effective-slots
direct-slots longest-slot-name-length)
(flet ((slot-home-class (slot)
(slot-home-class-using-class slot class)))
(let ((current-slots '()))
(append
(loop for slot in effective-slots
for previous-home-class = (slot-home-class slot) then home-class
for home-class = previous-home-class then (slot-home-class slot)
if (eq home-class previous-home-class)
do (push slot current-slots)
else
collect '(:newline)
and collect (format nil "~A:" (class-name previous-home-class))
and collect '(:newline)
and append (make-slot-listing checklist object class
(nreverse current-slots)
direct-slots
longest-slot-name-length)
and do (setf current-slots (list slot)))
(and current-slots
`((:newline)
,(format nil "~A:"
(class-name (slot-home-class-using-class
(car current-slots) class)))
(:newline)
,@(make-slot-listing checklist object class
(nreverse current-slots) direct-slots
longest-slot-name-length)))))))
(defun make-slot-listing (checklist object class effective-slots direct-slots
longest-slot-name-length)
(flet ((padding-for (slot-name)
(make-string (- longest-slot-name-length (length slot-name))
:initial-element #\Space)))
(loop
for effective-slot :in effective-slots
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))
collect (make-checklist-button checklist)
collect " "
collect `(:value ,(if direct-slot
(list direct-slot effective-slot)
effective-slot)
,slot-name)
collect (padding-for slot-name)
collect " = "
collect (slot-value-for-inspector class object effective-slot)
collect '(:newline))))
(defgeneric slot-value-for-inspector (class object slot)
(:method (class object slot)
(let ((boundp (swank-mop:slot-boundp-using-class class object slot)))
(if boundp
`(:value ,(swank-mop:slot-value-using-class class object slot))
"#<unbound>"))))
(defun slot-home-class-using-class (slot class)
(let ((slot-name (swank-mop:slot-definition-name slot)))
(loop for class in (reverse (swank-mop:class-precedence-list class))
thereis (and (member slot-name (swank-mop:class-direct-slots class)
:key #'swank-mop:slot-definition-name
:test #'eq)
class))))
(defun stable-sort-by-inheritance (slots class predicate)
(stable-sort slots predicate
:key #'(lambda (s)
(class-name (slot-home-class-using-class s class)))))
(defun query-and-set-slot (class object slot)
(let* ((slot-name (swank-mop:slot-definition-name slot))
(value-string (read-from-minibuffer-in-emacs
(format nil "Set slot ~S to (evaluated) : "
slot-name))))
(when (and value-string (not (string= value-string "")))
(with-simple-restart (abort "Abort setting slot ~S" slot-name)
(setf (swank-mop:slot-value-using-class class object slot)
(eval (read-from-string value-string)))))))
(defmethod emacs-inspect ((gf standard-generic-function))
(flet ((lv (label value) (label-value-line label value)))
(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
(cdr (method-for-inspect-value method))))
" "
(:action "[remove method]"
,(let ((m method)) (lambda ()
(remove-method gf m))))
(:newline)))
`((:newline))
(all-slots-for-inspector gf))))
(defmethod emacs-inspect ((method standard-method))
`(,@(if (swank-mop:method-generic-function 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)))))
'("Method without a generic function"))
(: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)))
(defun specializer-direct-methods (class)
(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)))))))
(defmethod emacs-inspect ((class standard-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)> "
(:action "[finalize]"
,(lambda () (swank-mop:finalize-inheritance class)))))
(: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 (specializer-direct-methods class)
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)))
(defmethod emacs-inspect ((slot swank-mop:standard-slot-definition))
`("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)))
(defstruct (%package-symbols-container
(:conc-name %container.)
(:constructor %%make-package-symbols-container))
title description symbols grouping-kind)
(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 (see SYMBOL-CLASSIFICATION-STRING)"
(let ((max-length (loop for s in symbols
maximizing (length (symbol-name s))))
(distance 10)) (flet ((string-representations (symbol)
(let* ((name (symbol-name symbol))
(length (length name))
(padding (- max-length length)))
(values
(concatenate 'string
name
(make-string (+ padding distance)
:initial-element #\Space))
(symbol-classification-string symbol)))))
`("" "Symbols:" ,(make-string (+ -8 max-length distance)
:initial-element #\Space)
"Flags:"
(:newline)
,(concatenate 'string (make-string (+ max-length distance -1)
:initial-element #\-)
" "
(symbol-classification-string '#:foo))
(:newline)
,@(loop for symbol in symbols appending
(multiple-value-bind (symbol-string classification-string)
(string-representations symbol)
`((:value ,symbol ,symbol-string) ,classification-string
(:newline)
)))))))
(defmethod make-symbols-listing ((grouping-kind (eql :classification)) symbols)
"For each possible classification (cf. CLASSIFY-SYMBOL), group
all the symbols in SYMBOLS to all of their respective
classifications. (If a symbol is, for instance, boundp and a
generic-function, it'll appear both below the BOUNDP group and
the GENERIC-FUNCTION group.) As macros and special-operators are
specified to be FBOUNDP, there is no general FBOUNDP group,
instead there are the three explicit FUNCTION, MACRO and
SPECIAL-OPERATOR groups."
(let ((table (make-hash-table :test #'eq))
(+default-classification+ :misc))
(flet ((normalize-classifications (classifications)
(cond ((null classifications) `(,+default-classification+))
((and (member :fboundp classifications)
(not (member :macro classifications))
(not (member :special-operator classifications)))
(substitute :function :fboundp classifications))
(t (remove :fboundp classifications)))))
(loop for symbol in symbols do
(loop for classification in
(normalize-classifications (classify-symbol symbol))
do (push symbol (gethash classification table)))))
(let* ((classifications (loop for k being each hash-key in table
collect k))
(classifications (sort classifications
(lambda (a b)
(cond ((eql a +default-classification+)
nil)
((eql b +default-classification+)
t)
(t (string< a b)))))))
(loop for classification in classifications
for symbols = (gethash classification table)
appending`(,(symbol-name classification)
(:newline)
,(make-string 64 :initial-element #\-)
(:newline)
,@(mapcan (lambda (symbol)
`((:value ,symbol ,(symbol-name symbol))
(:newline)))
(nreverse symbols))
(:newline))))))
(defmethod emacs-inspect ((%container %package-symbols-container))
(with-struct (%container. title description symbols grouping-kind) %container
`(,title (:newline) (:newline)
,@description
(:newline)
" " ,(ecase grouping-kind
(:symbol
`(:action "[Group by classification]"
,(lambda ()
(setf grouping-kind :classification))
:refreshp t))
(:classification
`(:action "[Group by symbol]"
,(lambda () (setf grouping-kind :symbol))
:refreshp t)))
(:newline) (:newline)
,@(make-symbols-listing grouping-kind symbols))))
(defun display-link (type symbols length &key title description)
(if (null symbols)
(format nil "0 ~A symbols." type)
`(:value ,(%make-package-symbols-container :title title
:description description
:symbols symbols)
,(format nil "~D ~A symbol~P." length type length))))
(defmethod emacs-inspect ((package package))
(let ((package-name (package-name package))
(package-nicknames (package-nicknames package))
(local-nicknames (package-local-nicknames package))
(package-use-list (package-use-list package))
(package-used-by-list (package-used-by-list package))
(shadowed-symbols (package-shadowing-symbols package))
(present-symbols '()) (present-symbols-length 0)
(internal-symbols '()) (internal-symbols-length 0)
(inherited-symbols '()) (inherited-symbols-length 0)
(external-symbols '()) (external-symbols-length 0))
(do-symbols* (sym package)
(let ((status (symbol-status sym package)))
(when (eq status :inherited)
(push sym inherited-symbols) (incf inherited-symbols-length)
(go :continue))
(push sym present-symbols) (incf present-symbols-length)
(cond ((eq status :internal)
(push sym internal-symbols) (incf internal-symbols-length))
(t
(push sym external-symbols) (incf external-symbols-length))))
:continue)
(setf package-nicknames (sort (copy-list package-nicknames)
#'string<)
package-use-list (sort (copy-list package-use-list)
#'string< :key #'package-name)
package-used-by-list (sort (copy-list package-used-by-list)
#'string< :key #'package-name)
shadowed-symbols (sort (copy-list shadowed-symbols)
#'string<))
(setf present-symbols (sort present-symbols #'string<)
internal-symbols (sort internal-symbols #'string<)
external-symbols (sort external-symbols #'string<)
inherited-symbols (sort inherited-symbols #'string<))
`("" "Name: " (:value ,package-name) (:newline)
"Nicknames: " ,@(common-seperated-spec package-nicknames) (:newline)
,@(when local-nicknames
`("Package-local nicknames: " (:value ,local-nicknames) (:newline)))
,@(when (documentation package t)
`("Documentation:" (:newline)
,(documentation package t) (:newline)))
"Use list: " ,@(common-seperated-spec
package-use-list
(lambda (package)
`(:value ,package ,(package-name package))))
(:newline)
"Used by list: " ,@(common-seperated-spec
package-used-by-list
(lambda (package)
`(:value ,package ,(package-name package))))
(:newline)
,(display-link "present" present-symbols present-symbols-length
:title
(format nil "All present symbols of package \"~A\""
package-name)
:description
'("A symbol is considered present in a package if it's"
(:newline)
"\"accessible in that package directly, rather than"
(:newline)
"being inherited from another package.\""
(:newline)
"(CLHS glossary entry for `present')"
(:newline)))
(:newline)
,(display-link "external" external-symbols external-symbols-length
:title
(format nil "All external symbols of package \"~A\""
package-name)
:description
'("A symbol is considered external of a package if it's"
(:newline)
"\"part of the `external interface' to the package and"
(:newline)
"[is] inherited by any other package that uses the"
(:newline)
"package.\" (CLHS glossary entry of `external')"
(:newline)))
(:newline)
,(display-link "internal" internal-symbols internal-symbols-length
:title
(format nil "All internal symbols of package \"~A\""
package-name)
:description
'("A symbol is considered internal of a package if it's"
(:newline)
"present and not external---that is if the package is"
(:newline)
"the home package of the symbol, or if the symbol has"
(:newline)
"been explicitly imported into the package."
(:newline)
(:newline)
"Notice that inherited symbols will thus not be listed,"
(:newline)
"which deliberately deviates from the CLHS glossary"
(:newline)
"entry of `internal' because it's assumed to be more"
(:newline)
"useful this way."
(:newline)))
(:newline)
,(display-link "inherited" inherited-symbols inherited-symbols-length
:title
(format nil "All inherited symbols of package \"~A\""
package-name)
:description
'("A symbol is considered inherited in a package if it"
(:newline)
"was made accessible via USE-PACKAGE."
(:newline)))
(:newline)
,(display-link "shadowed" shadowed-symbols (length shadowed-symbols)
:title
(format nil "All shadowed symbols of package \"~A\""
package-name)
:description nil))))
(defmethod emacs-inspect ((pathname pathname))
`(,(if (wild-pathname-p pathname)
"A wild pathname."
"A pathname.")
(:newline)
,@(label-value-line*
("Namestring" (namestring pathname))
("Host" (pathname-host pathname))
("Device" (pathname-device pathname))
("Directory" (pathname-directory pathname))
("Name" (pathname-name pathname))
("Type" (pathname-type pathname))
("Version" (pathname-version pathname)))
,@ (unless (or (wild-pathname-p pathname)
(not (probe-file pathname)))
(label-value-line "Truename" (truename pathname)))))
(defmethod emacs-inspect ((pathname logical-pathname))
(append
(label-value-line*
("Namestring" (namestring pathname))
("Physical pathname: " (translate-logical-pathname pathname)))
`("Host: "
(:value ,(pathname-host pathname))
" ("
(:value ,(logical-pathname-translations
(pathname-host pathname)))
" other translations)"
(:newline))
(label-value-line*
("Directory" (pathname-directory pathname))
("Name" (pathname-name pathname))
("Type" (pathname-type pathname))
("Version" (pathname-version pathname))
("Truename" (if (not (wild-pathname-p pathname))
(probe-file pathname))))))
(defmethod emacs-inspect ((n number))
`("Value: " ,(princ-to-string n)))
(defun format-iso8601-time (time-value &optional include-timezone-p)
"Formats a universal time TIME-VALUE in ISO 8601 format, with
the time zone included if INCLUDE-TIMEZONE-P is non-NIL"
(flet ((format-iso8601-timezone (zone)
(if (zerop zone)
"Z"
(multiple-value-bind (h m) (truncate (abs zone) 1.0)
(format nil "~:[+~;-~]~2,'0D:~2,'0D"
(> zone 0) h (round (* 60 m)))))))
(multiple-value-bind (second minute hour day month year dow dst zone)
(decode-universal-time time-value)
(declare (ignore dow))
(format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]"
year month day hour minute second
include-timezone-p (format-iso8601-timezone (if dst
(+ zone 1)
zone))))))
(defmethod emacs-inspect ((i integer))
(append
`(,(format nil "Value: ~D = #x~8,'0X = #o~O = #b~,,' ,8:B~@[ = ~E~]"
i i i i (ignore-errors (coerce i 'float)))
(:newline))
(when (< -1 i char-code-limit)
(label-value-line "Code-char" (code-char i)))
(label-value-line "Integer-length" (integer-length i))
(ignore-errors
(label-value-line "Universal-time" (format-iso8601-time i t)))))
(defmethod emacs-inspect ((c complex))
(label-value-line*
("Real part" (realpart c))
("Imaginary part" (imagpart c))))
(defmethod emacs-inspect ((r ratio))
(label-value-line*
("Numerator" (numerator r))
("Denominator" (denominator r))
("As float" (float r))))
(defmethod emacs-inspect ((f float))
(cond
((float-nan-p f)
(list "Not a Number."))
((not (float-infinity-p f))
(multiple-value-bind (significand exponent sign) (decode-float f)
(append
`("Scientific: " ,(format nil "~E" f) (:newline)
"Decoded: "
(:value ,sign) " * "
(:value ,significand) " * "
(:value ,(float-radix f)) "^"
(:value ,exponent) (:newline))
(label-value-line "Digits" (float-digits f))
(label-value-line "Precision" (float-precision f)))))
((> f 0)
(list "Positive infinity."))
((< f 0)
(list "Negative infinity."))))
(defun make-pathname-ispec (pathname position)
`("Pathname: "
(:value ,pathname)
(:newline) " "
,@(when position
`((:action "[visit file and show current position]"
,(lambda ()
(ed-in-emacs `(,pathname :position ,position :bytep t)))
:refreshp nil)
(:newline)))))
(defun make-file-stream-ispec (stream)
(let ((pathname (ignore-errors (pathname stream))))
(when pathname
(make-pathname-ispec pathname (and (open-stream-p stream)
(file-position stream))))))
(defmethod emacs-inspect ((stream file-stream))
(multiple-value-bind (content)
(call-next-method)
(append (make-file-stream-ispec stream) content)))
(defmethod emacs-inspect ((condition stream-error))
(multiple-value-bind (content)
(call-next-method)
(let ((stream (stream-error-stream condition)))
(append (when (typep stream 'file-stream)
(make-file-stream-ispec stream))
content))))
(defun common-seperated-spec (list &optional (callback (lambda (v)
`(:value ,v))))
(butlast
(loop
for i in list
collect (funcall callback i)
collect ", ")))
(defun inspector-princ (list)
"Like princ-to-string, but don't rewrite (function foo) as #'foo.
Do NOT pass circular lists to this function."
(let ((*print-pprint-dispatch* (copy-pprint-dispatch)))
(set-pprint-dispatch '(cons (member function)) nil)
(princ-to-string list)))
(provide :swank-fancy-inspector)