summaryrefslogtreecommitdiff
path: root/vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp')
-rw-r--r--vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp1004
1 files changed, 1004 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp b/vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp
new file mode 100644
index 0000000..3e46df9
--- /dev/null
+++ b/vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp
@@ -0,0 +1,1004 @@
+;;; swank-fancy-inspector.lisp --- Fancy inspector for CLOS objects
+;;
+;; Author: Marco Baringer <mb@bese.it> and others
+;; License: Public Domain
+;;
+
+(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))
+ ;;
+ ;; Value
+ (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)
+ ;; unbinding constants might be not a good idea, but
+ ;; implementations usually provide a restart.
+ `(" " (: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)))
+ ;;
+ ;; 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 "[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)
+ ;;
+ ;; Package
+ (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)))
+ ;;
+ ;; 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)))
+ (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: "
+ ;; Could use ~:s, but inspector-princ does a bit more,
+ ;; and not all NILs in the arglist should be printed that way.
+ ,(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
+ ;; SBCL has extended specializers
+ (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."
+ ;; 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))))
+
+(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)
+ ;; Along this counter the buttons are created, so we have to
+ ;; initialize it to 0 everytime the inspector page is redisplayed.
+ (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
+ ;; We box the value so we can re-set it.
+ (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 ()
+ ;; We have to do this as the order of slots will
+ ;; be sorted differently.
+ (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
+ ;; 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))))
+
+(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)))
+
+
+;; 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 EMACS-INSPECT.
+;; 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 (see SYMBOL-CLASSIFICATION-STRING)"
+ (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)))
+ (values
+ (concatenate 'string
+ name
+ (make-string (+ padding distance)
+ :initial-element #\Space))
+ (symbol-classification-string symbol)))))
+ `("" ; 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 #\-)
+ " "
+ (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+))
+ ;; Convert an :FBOUNDP in CLASSIFICATIONS to
+ ;; :FUNCTION if possible.
+ ((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))
+ ;; SYMBOLS are supposed to be sorted alphabetically;
+ ;; this property is preserved here except for reversing.
+ do (push symbol (gethash classification table)))))
+ (let* ((classifications (loop for k being each hash-key in table
+ collect k))
+ (classifications (sort classifications
+ ;; Sort alphabetically, except
+ ;; +DEFAULT-CLASSIFICATION+ which
+ ;; sort to the end.
+ (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)))
+ ;; restore alphabetic order.
+ (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))
+ (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<))
+ ;;; SORT + STRING-LESSP conses on at least SBCL 0.9.18.
+ (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<))
+ `("" ;; dummy to preserve indentation.
+ "Name: " (:value ,package-name) (:newline)
+
+ "Nick names: " ,@(common-seperated-spec package-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"
+ ;; Taken from http://www.pvv.ntnu.no/~nsaa/ISO8601.html
+ ;; Thanks, Nikolai Sandved and Thomas Russ!
+ (flet ((format-iso8601-timezone (zone)
+ (if (zerop zone)
+ "Z"
+ (multiple-value-bind (h m) (truncate (abs zone) 1.0)
+ ;; Tricky. Sign of time zone is reversed in ISO 8601
+ ;; relative to Common Lisp convention!
+ (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
+ ((> f most-positive-long-float)
+ (list "Positive infinity."))
+ ((< f most-negative-long-float)
+ (list "Negative infinity."))
+ ((not (= f f))
+ (list "Not a Number."))
+ (t
+ (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)))))))
+
+(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)
+ ;; SBCL's socket stream are file-stream but are not associated to
+ ;; any pathname.
+ (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)
generated by cgit v1.2.3-54-g00ecf (git 2.44.0) at 2024-05-05 14:55:58 +0000