[slime-devel] some inspector conveniencies (patch)

[Thomas Schilling]

I think I already sent these some days ago but they never got commited. So  
I revised them and resend them, in short it's (all concerning the  
inspector):

  - when inspecting gf:
    - display short docs for gf methods (when available)
    - sort them by applicability (according to a #lisp
      suggestion some time ago), although this is still a
      little buggy but IMO still better than no ordering at all
      users can specify their own function if they don't like
      the default by setting `*gf-method-getter*' (feel free
      to rename this to sth. more sensible)
  - when inspecting class:
    - abbrev'd docs for methods specialising on the class
    - print them one per line
    - order them by name (not customizable)

-ts

,----
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.253
diff -u -r1.253 swank.lisp
--- swank.lisp	19 Oct 2004 06:14:17 -0000	1.253
+++ swank.lisp	24 Oct 2004 19:48:01 -0000
@@ -2786,6 +2786,68 @@
                     collect "#<unbound>"
                   collect '(:newline)))))

+(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'.")
+
+;;; Largely inspired by (+ copied from) the McCLIM listener
+(defun methods-by-applicability (gf)
+  "Return methods ordered by qualifiers, then by most specific argument  
types.
+
+Qualifier ordering is: :before, :around, primary, and :after.
+We use the length of the class precedence list to determine which type is
+more specific."
+  ;;FIXME: How to deal with argument-precedence-order?
+  (let* ((methods (copy-list (swank-mop:generic-function-methods gf)))
+         (lambda-list (swank-mop:generic-function-lambda-list gf)))
+    ;; sorter function (most specific is defined as smaller)
+    (flet ((method< (meth1 meth2)
+             ;; First ordering rule is by qualifiers, that is  
:before-methods
+             ;; come before :around methods, before primary methods,  
before
+             ;; :after methods, other qualifiers are treated like none at  
all
+             ;; (so like primary methods)
+             (let ((qualifier-order '(:before :around nil :after)))
+               (let ((q1 (or (position (first  
(swank-mop:method-qualifiers meth1)) qualifier-order) 2))
+                     (q2 (or (position (first  
(swank-mop:method-qualifiers meth2)) qualifier-order) 2)))
+                 (cond ((< q1 q2) (return-from method< t))
+                       ((> q1 q2) (return-from method< nil)))))
+             ;; If qualifiers are equal, go by arguments
+             (loop for sp1 in (swank-mop:method-specializers meth1)
+                   for sp2 in (swank-mop:method-specializers meth2)
+                   do (cond
+                        ((eq sp1 sp2)) ;; continue comparision
+                        ;; an eql specializer is most specific
+                        ((typep sp1 'swank-mop:eql-specializer)
+                         (return-from method< t))
+                        ((typep sp2 'swank-mop:eql-specializer)
+                         (return-from method< nil))
+                        ;; otherwise the longer the CPL the more specific
+                        ;; the specializer is
+                        ;; FIXME: Taking the CPL as indicator has the  
problem
+                        ;; that unfinalized classes are most specific.  
Can we pick
+                        ;; a reasonable default or do something with  
SUBTYPEP ?
+                        (t (let ((l1 (if (swank-mop:class-finalized-p sp1)
+                                         (length  
(swank-mop:class-precedence-list sp1))
+                                         0))
+                                 (l2 (if (swank-mop:class-finalized-p sp2)
+                                         (length  
(swank-mop:class-precedence-list sp2))
+                                         0)))
+                             (cond
+                               ((> l1 l2)
+                                (return-from method< t))
+                               ((< l1 l2)
+                                (return-from method< nil))))))
+                   finally (return nil))))
+      (declare (dynamic-extent #'method<))
+      (sort methods #'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))))
+
  (defmethod inspect-for-emacs ((gf standard-generic-function) (inspector  
t))
    (declare (ignore inspector))
    (values "A generic function."
@@ -2797,13 +2859,17 @@
              "It uses " (:value  
,(swank-mop:generic-function-method-combination gf)) " method  
combination." (:newline)
              "Methods: " (:newline)
              ,@(loop
-                 for method in (swank-mop:generic-function-methods gf)
+                 for method in (funcall *gf-method-getter* gf)
                   collect `(:value ,method ,(inspector-princ
                                              ;; drop the first element  
(the name of the generic function)
                                              (cdr  
(method-for-inspect-value method))))
                   collect " "
                   collect (let ((meth method))
                             `(:action "[remove method]" ,(lambda ()  
(remove-method gf meth))))
+                 collect '(:newline)
+                 if (documentation method t)
+                 collect "  Documentation: " and
+                 collect (abbrev-doc (documentation method t))
                   collect '(:newline)))))

  (defmethod inspect-for-emacs ((method standard-method) (inspector t))
@@ -2860,8 +2926,18 @@
              ,@(when (swank-mop:specializer-direct-methods class)
                 `("It is used as a direct specializer in the following  
methods:" (:newline)
                   ,@(loop
-                      for method in (swank-mop:specializer-direct-methods  
class)
+                      for method in (sort (copy-list  
(swank-mop:specializer-direct-methods class))
+                                          #'string< :key (lambda (x)
+                                                           (symbol-name
+                                                            (let ((name  
(swank-mop::generic-function-name
+                                                                          
(swank-mop::method-generic-function x))))
+                                                              (if  
(symbolp name) name (second name))))))
+                      collect "  "
                        collect `(:value ,method ,(inspector-princ  
(method-for-inspect-value method)))
+                      collect '(:newline)
+                      if (documentation method t)
+                      collect "  Documentation: " and
+                      collect (abbrev-doc (documentation method t)) and
                        collect '(:newline))))
              "Prototype: " ,(if (swank-mop:class-finalized-p class)
                                 `(:value ,(swank-mop:class-prototype  
class))