Re: Better help support for EIEIO classes and methods

[David Engster]

Stefan Monnier writes:
>> But there's usually more than one implementation for a method, and the
>> link will just point to the one which was first defined.
>
> Can we hope that the first definition is usually a defgeneric rather
> than a defmethod?  If not, indeed, it might be better to remove the
> link (which you should be able to do from the hook I suggested).

defgeneric is seldom used, since just defmethod already implicitly
includes it.

Attached is a first iteration on how this might work. eieio-opt is in
dire need of further cleanup, but first I want to make sure you're OK
with the general direction this is taking.

This patch only hooks into describe-function for class constructors and
methods. The next step would be how to describe plain classes. In CEDET
upstream, we hooked into describe-variable through defadvice, but it's
not clear to me at all where we could place a hook there...

-David

=== modified file 'lisp/emacs-lisp/eieio-opt.el'
--- lisp/emacs-lisp/eieio-opt.el        2013-01-01 09:11:05 +0000
+++ lisp/emacs-lisp/eieio-opt.el        2013-02-10 15:13:43 +0000
@@ -77,101 +77,76 @@
 ;;;###autoload(defalias 'describe-class 'eieio-describe-class)
 
 ;;;###autoload
-(defun eieio-describe-class (class &optional headerfcn)
+(defun eieio-describe-class (class)
   "Describe a CLASS defined by a string or symbol.
-If CLASS is actually an object, then also display current values of that 
object.
-Optional HEADERFCN should be called to insert a few bits of info first."
-  (interactive (list (eieio-read-class "Class: ")))
-  (with-output-to-temp-buffer (help-buffer) ;"*Help*"
-    (help-setup-xref (list #'eieio-describe-class class headerfcn)
-                    (called-interactively-p 'interactive))
-
-    (when headerfcn (funcall headerfcn))
-    (prin1 class)
-    (princ " is a")
-    (if (class-option class :abstract)
-       (princ "n abstract"))
-    (princ " class")
-    ;; Print file location
-    (when (get class 'class-location)
-      (princ " in `")
-      (princ (file-name-nondirectory (get class 'class-location)))
-      (princ "'"))
-    (terpri)
-    ;; Inheritance tree information
-    (let ((pl (class-parents class)))
-      (when pl
-       (princ " Inherits from ")
-       (while pl
-         (princ "`") (prin1 (car pl)) (princ "'")
-         (setq pl (cdr pl))
-         (if pl (princ ", ")))
-       (terpri)))
-    (let ((ch (class-children class)))
-      (when ch
-       (princ " Children ")
-       (while ch
-         (princ "`") (prin1 (car ch)) (princ "'")
-         (setq ch (cdr ch))
-         (if ch (princ ", ")))
-       (terpri)))
-    (terpri)
-    ;; System documentation
-    (let ((doc (documentation-property class 'variable-documentation)))
-      (when doc
-       (princ "Documentation:")
-       (terpri)
-       (princ doc)
-       (terpri)
-       (terpri)))
-    ;; Describe all the slots in this class
-    (eieio-describe-class-slots class)
-    ;; Describe all the methods specific to this class.
-    (let ((methods (eieio-all-generic-functions class))
-         (doc nil))
-      (if (not methods) nil
-       (princ "Specialized Methods:")
-       (terpri)
-       (terpri)
-       (while methods
-         (setq doc (eieio-method-documentation (car methods) class))
-         (princ "`")
-         (prin1 (car methods))
-         (princ "'")
-         (if (not doc)
-             (princ "  Undocumented")
-           (if (car doc)
-               (progn
-                 (princ "  :STATIC ")
-                 (prin1 (car (car doc)))
-                 (terpri)
-                 (princ (cdr (car doc)))))
-           (setq doc (cdr doc))
-           (if (car doc)
-               (progn
-                 (princ "  :BEFORE ")
-                 (prin1 (car (car doc)))
-                 (terpri)
-                 (princ (cdr (car doc)))))
-           (setq doc (cdr doc))
-           (if (car doc)
-               (progn
-                 (princ "  :PRIMARY ")
-                 (prin1 (car (car doc)))
-                 (terpri)
-                 (princ (cdr (car doc)))))
-           (setq doc (cdr doc))
-           (if (car doc)
-               (progn
-                 (princ "  :AFTER ")
-                 (prin1 (car (car doc)))
-                 (terpri)
-                 (princ (cdr (car doc)))))
-           (terpri)
-           (terpri))
-         (setq methods (cdr methods))))))
-  (with-current-buffer (help-buffer)
-    (buffer-string)))
+If CLASS is actually an object, then also display current values of that 
object."
+  ;; Header line
+  (prin1 class)
+  (insert " is a"
+         (if (class-option class :abstract)
+             "n abstract"
+           "")
+         " class")
+  (let ((location (get class 'class-location)))
+    (when location
+      (insert " in `")
+      (help-insert-xref-button
+       (file-name-nondirectory location)
+       'eieio-class-def class location)
+      (insert "'")))
+  (insert ".\n")
+  ;; Parents
+  (let ((pl (class-parents class))
+       cur)
+    (when pl
+      (insert " Inherits from ")
+      (while (setq cur (pop pl))
+       (insert "`")
+       (help-insert-xref-button (symbol-name cur)
+                                'help-variable cur)
+       (insert (if pl "', " "'")))
+      (insert ".\n")))
+  ;; Children
+  (let ((ch (class-children class))
+       cur)
+    (when ch
+      (insert " Children ")
+      (while (setq cur (pop ch))
+       (insert "`")
+       (help-insert-xref-button (symbol-name cur)
+                                'help-variable cur)
+       (insert (if ch "', " "'")))
+      (insert ".\n")))
+  ;; System documentation
+  (let ((doc (documentation-property class 'variable-documentation)))
+    (when doc
+      (insert "\n" doc "\n\n")))
+  ;; Describe all the slots in this class
+  (eieio-describe-class-slots class)
+  ;; Describe all the methods specific to this class.
+  (let ((methods (eieio-all-generic-functions class))
+       (type [":STATIC" ":BEFORE" ":PRIMARY" ":AFTER"])
+       counter doc)
+    (when methods
+      (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
+      (while methods
+       (setq doc (eieio-method-documentation (car methods) class))
+       (insert "`")
+       (help-insert-xref-button (symbol-name (car methods))
+                                'help-function (car methods))
+       (insert "'")
+       (if (not doc)
+           (insert "  Undocumented")
+         (setq counter 0)
+         (dolist (cur doc)
+           (when cur
+             (insert " " (aref type counter) " "
+                     (prin1-to-string (car cur) (current-buffer))
+                     "\n"
+                     (cdr cur)))
+             (setq counter (1+ counter))))
+       (insert "\n\n")
+       (setq methods (cdr methods))))))
 
 (defun eieio-describe-class-slots (class)
   "Describe the slots in CLASS.
@@ -185,28 +160,27 @@
         (i      0)
         (prot   (aref cv class-protection))
         )
-    (princ "Instance Allocated Slots:")
-    (terpri)
-    (terpri)
+    (insert (propertize "Instance Allocated Slots:\n\n"
+                       'face 'bold))
     (while names
-      (if (car prot) (princ "Private "))
-      (princ "Slot: ")
-      (prin1 (car names))
-      (when (not (eq (aref types i) t))
-       (princ "    type = ")
-       (prin1 (aref types i)))
-      (unless (eq (car deflt) eieio-unbound)
-       (princ "    default = ")
-       (prin1 (car deflt)))
-      (when (car publp)
-       (princ "    printer = ")
-       (prin1 (car publp)))
-      (when (car docs)
-       (terpri)
-       (princ "  ")
-       (princ (car docs))
-       (terpri))
-      (terpri)
+      (insert
+       (concat
+       (when (car prot)
+         (propertize "Private " 'face 'bold))
+       (propertize "Slot: " 'face 'bold)
+       (prin1-to-string (car names))
+       (unless (eq (aref types i) t)
+         (concat "    type = "
+                 (prin1-to-string (aref types i))))
+       (unless (eq (car deflt) eieio-unbound)
+         (concat "    default = "
+                 (prin1-to-string (car deflt))))
+       (when (car publp)
+         (concat "    printer = "
+                 (prin1-to-string (car publp))))
+       (when (car docs)
+         (concat "\n  " (car docs) "\n"))
+       "\n"))
       (setq names (cdr names)
            docs (cdr docs)
            deflt (cdr deflt)
@@ -219,61 +193,30 @@
          i     0
          prot  (aref cv class-class-allocation-protection))
     (when names
-       (terpri)
-       (princ "Class Allocated Slots:"))
-       (terpri)
-       (terpri)
+      (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)))
     (while names
-      (when (car prot)
-       (princ "Private "))
-      (princ "Slot: ")
-      (prin1 (car names))
-      (unless (eq (aref types i) t)
-       (princ "    type = ")
-       (prin1 (aref types i)))
-      (condition-case nil
-         (let ((value (eieio-oref class (car names))))
-           (princ "   value = ")
-           (prin1 value))
+      (insert
+       (concat
+       (when (car prot)
+         "Private ")
+       "Slot: "
+       (prin1-to-string (car names))
+       (unless (eq (aref types i) t)
+         (concat "    type = "
+                 (prin1-to-string (aref types i))))
+       (condition-case nil
+           (let ((value (eieio-oref class (car names))))
+             (concat "   value = "
+                     (prin1-to-string value)))
          (error nil))
-      (when (car docs)
-       (terpri)
-       (princ "  ")
-       (princ (car docs))
-       (terpri))
-      (terpri)
+       (when (car docs)
+         (concat "\n\n " (car docs) "\n"))
+       "\n"))
       (setq names (cdr names)
            docs (cdr docs)
            prot (cdr prot)
            i (1+ i)))))
 
-;;;###autoload
-(defun eieio-describe-constructor (fcn)
-  "Describe the constructor function FCN.
-Uses `eieio-describe-class' to describe the class being constructed."
-  (interactive
-   ;; Use eieio-read-class since all constructors have the same name as
-   ;; the class they create.
-   (list (eieio-read-class "Class: ")))
-  (eieio-describe-class
-   fcn (lambda ()
-        ;; Describe the constructor part.
-        (prin1 fcn)
-        (princ " is an object constructor function")
-        ;; Print file location
-        (when (get fcn 'class-location)
-          (princ " in `")
-          (princ (file-name-nondirectory (get fcn 'class-location)))
-          (princ "'"))
-        (terpri)
-        (princ "Creates an object of class ")
-        (prin1 fcn)
-        (princ ".")
-        (terpri)
-        (terpri)
-        ))
-  )
-
 (defun eieio-build-class-list (class)
   "Return a list of all classes that inherit from CLASS."
   (if (class-p class)
@@ -330,88 +273,99 @@
 ;;;###autoload(defalias 'describe-generic 'eieio-describe-generic)
 (defalias 'eieio-describe-method 'eieio-describe-generic)
 
-;;;###autoload
-(defun eieio-describe-generic (generic)
-  "Describe the generic function GENERIC.
-Also extracts information about all methods specific to this generic."
-  (interactive (list (eieio-read-generic "Generic Method: ")))
-  (if (not (generic-p generic))
-      (signal 'wrong-type-argument '(generic-p generic)))
-  (with-output-to-temp-buffer (help-buffer) ; "*Help*"
-    (help-setup-xref (list #'eieio-describe-generic generic)
-                    (called-interactively-p 'interactive))
-
-    (prin1 generic)
-    (princ " is a generic function")
-    (when (generic-primary-only-p generic)
-      (princ " with only ")
-      (when (generic-primary-only-one-p generic)
-       (princ "one "))
-      (princ "primary method")
-      (when (not (generic-primary-only-one-p generic))
-       (princ "s"))
-      )
-    (princ ".")
-    (terpri)
-    (terpri)
-    (let ((d (documentation generic)))
-      (if (not d)
-         (princ "The generic is not documented.\n")
-       (princ "Documentation:")
-       (terpri)
-       (princ d)
-       (terpri)
-       (terpri)))
-    (princ "Implementations:")
-    (terpri)
-    (terpri)
-    (let ((i 4)
-         (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
-      ;; Loop over fanciful generics
-      (while (< i 7)
-       (let ((gm (aref (get generic 'eieio-method-tree) i)))
-         (when gm
-           (princ "Generic ")
-           (princ (aref prefix (- i 3)))
-           (terpri)
-           (princ (or (nth 2 gm) "Undocumented"))
-           (terpri)
-           (terpri)))
-       (setq i (1+ i)))
-      (setq i 0)
-      ;; Loop over defined class-specific methods
-      (while (< i 4)
-       (let ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
-             location)
-         (while gm
-           (princ "`")
-           (prin1 (car (car gm)))
-           (princ "'")
-           ;; prefix type
-           (princ " ")
-           (princ (aref prefix i))
-           (princ " ")
-           ;; argument list
-           (let* ((func (cdr (car gm)))
-                  (arglst (eieio-lambda-arglist func)))
-             (prin1 arglst))
-           (terpri)
-           ;; 3 because of cdr
-           (princ (or (documentation (cdr (car gm)))
-                      "Undocumented"))
-           ;; Print file location if available
-           (when (and (setq location (get generic 'method-locations))
-                      (setq location (assoc (caar gm) location)))
-             (setq location (cadr location))
-             (princ "\n\nDefined in `")
-             (princ (file-name-nondirectory location))
-             (princ "'\n"))
-           (setq gm (cdr gm))
-           (terpri)
-           (terpri)))
-       (setq i (1+ i)))))
-  (with-current-buffer (help-buffer)
-    (buffer-string)))
+(define-button-type 'eieio-method-def
+  :supertype 'help-xref
+  'help-function (lambda (class method file)
+                  (eieio-help-find-method-definition class method file))
+  'help-echo (purecopy "mouse-2, RET: find method's definition"))
+
+(define-button-type 'eieio-class-def
+  :supertype 'help-xref
+  'help-function (lambda (class file)
+                  (eieio-help-find-class-definition class file))
+  'help-echo (purecopy "mouse-2, RET: find class definition"))
+
+;;;###autoload
+(defun eieio-help-constructor (ctr)
+  "Describe CTR if it is a class constructor."
+  (when (class-p ctr)
+    (let ((location (file-name-nondirectory (get ctr 'class-location))))
+      (goto-char (point-min))
+      (delete-region (point) (point-at-eol))
+      (prin1 ctr)
+      (insert " is an object constructor function in `")
+      (help-insert-xref-button
+       location
+       'eieio-class-def ctr location)
+      (insert "'.\nCreates an object of class " (symbol-name ctr) ".")
+      (goto-char (point-max))
+      (save-excursion
+       (insert (propertize "\n\nClass description:\n" 'face 'bold))
+       (eieio-describe-class ctr))
+      )))
+
+
+;;;###autoload
+(defun eieio-help-generic (generic)
+  "Describe GENERIC if it is a generic function."
+  (when (generic-p generic)
+    (save-excursion
+      (goto-char (point-min))
+      (when (re-search-forward " in `.+'.$" nil t)
+       (replace-match ".")))
+    (save-excursion
+      (insert "\n\nThis is a generic function"
+             (cond
+              ((and (generic-primary-only-p generic)
+                    (generic-primary-only-one-p generic))
+               " with only one primary method")
+              ((generic-primary-only-p generic)
+               " with only primary methods")
+              (t ""))
+             ".\n\n")
+      (insert (propertize "Implementations:\n\n" 'face 'bold))
+      (let ((i 4)
+           (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
+       ;; Loop over fanciful generics
+       (while (< i 7)
+         (let ((gm (aref (get generic 'eieio-method-tree) i)))
+           (when gm
+             (insert "Generic "
+                     (aref prefix (- i 3))
+                     "\n"
+                     (or (nth 2 gm) "Undocumented")
+                     "\n\n")))
+         (setq i (1+ i)))
+       (setq i 0)
+       ;; Loop over defined class-specific methods
+       (while (< i 4)
+         (let* ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
+                cname location)
+           (while gm
+             (setq cname (caar gm))
+             (insert "`")
+             (help-insert-xref-button (symbol-name cname)
+                                      'help-variable cname)
+             (insert "' " (aref prefix i) " ")
+             ;; argument list
+             (let* ((func (cdr (car gm)))
+                    (arglst (eieio-lambda-arglist func)))
+               (prin1 arglst (current-buffer)))
+             (insert "\n"
+                     (or (documentation (cdr (car gm)))
+                         "Undocumented"))
+             ;; Print file location if available
+             (when (and (setq location (get generic 'method-locations))
+                        (setq location (assoc cname location)))
+               (setq location (cadr location))
+               (insert "\n\nDefined in `")
+               (help-insert-xref-button
+                (file-name-nondirectory location)
+                'eieio-method-def cname generic location)
+               (insert "'\n"))
+             (setq gm (cdr gm))
+             (insert "\n")))
+         (setq i (1+ i)))))))
 
 (defun eieio-lambda-arglist (func)
   "Return the argument list of FUNC, a function body."
@@ -585,21 +539,13 @@
 
 ;;; HELP AUGMENTATION
 ;;
-(define-button-type 'eieio-method-def
-  :supertype 'help-xref
-  'help-function (lambda (class method file)
-                  (eieio-help-find-method-definition class method file))
-  'help-echo (purecopy "mouse-2, RET: find method's definition"))
-
-(define-button-type 'eieio-class-def
-  :supertype 'help-xref
-  'help-function (lambda (class file)
-                  (eieio-help-find-class-definition class file))
-  'help-echo (purecopy "mouse-2, RET: find class definition"))
-
 (defun eieio-help-find-method-definition (class method file)
   (let ((filename (find-library-name file))
        location buf)
+    (when (symbolp class)
+      (setq class (symbol-name class)))
+    (when (symbolp method)
+      (setq method (symbol-name method)))
     (when (null filename)
       (error "Cannot find library %s" file))
     (setq buf (find-file-noselect filename))
@@ -623,6 +569,8 @@
       (beginning-of-line))))
 
 (defun eieio-help-find-class-definition (class file)
+  (when (symbolp class)
+    (setq class (symbol-name class)))
   (let ((filename (find-library-name file))
        location buf)
     (when (null filename)

=== modified file 'lisp/emacs-lisp/eieio.el'
--- lisp/emacs-lisp/eieio.el    2013-02-02 03:38:21 +0000
+++ lisp/emacs-lisp/eieio.el    2013-02-09 14:11:48 +0000
@@ -3013,6 +3013,10 @@
     'method))
 (make-obsolete 'eieio-defgeneric nil "24.1")
 
+;; Hook ourselves into help system for describing classes and methods.
+(add-hook 'help-fns-describe-function-functions 'eieio-help-generic)
+(add-hook 'help-fns-describe-function-functions 'eieio-help-constructor)
+
 ;;; Interfacing with edebug
 ;;
 (defun eieio-edebug-prin1-to-string (object &optional noescape)

=== modified file 'lisp/help-fns.el'
--- lisp/help-fns.el    2013-02-01 15:56:22 +0000
+++ lisp/help-fns.el    2013-02-10 15:13:02 +0000
@@ -32,6 +32,12 @@
 
 ;;; Code:
 
+(defvar help-fns-describe-function-functions nil
+  "List of functions to run in help buffer in `describe-function'.
+Those functions will be run after the header line and argument
+list was inserted, and before the documentation will be inserted.
+The functions will receive the function name as argument.")
+
 ;; Functions
 
 ;;;###autoload
@@ -633,7 +639,7 @@
           (help-fns--compiler-macro function)
           (help-fns--parent-mode function)
           (help-fns--obsolete function)
-
+         (run-hook-with-args 'help-fns-describe-function-functions function)
           (insert "\n"
                   (or doc "Not documented.")))))))