From c012f55efda29f09179e921cf148d79deb57616e Mon Sep 17 00:00:00 2001 From: Nick Shipp Date: Sun, 7 May 2017 09:04:01 -0400 Subject: Much maturering of vim configs --- .../slimv/slime/contrib/swank-fancy-inspector.lisp | 1004 ++++++++++++++++++++ 1 file changed, 1004 insertions(+) create mode 100644 vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp (limited to 'vim/bundle/slimv/slime/contrib/swank-fancy-inspector.lisp') 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 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)) + "#")))) + +(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))))) + `("# " + (: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))))) + '("#")) + (: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)) + '"#") + (: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)) + "#") + (: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) -- cgit v1.2.3-54-g00ecf