* Re: Better help support for EIEIO classes and methods
2013-02-06 19:16 ` Stefan Monnier
@ 2013-02-10 15:21 ` David Engster
2013-02-11 3:57 ` Stefan Monnier
0 siblings, 1 reply; 10+ messages in thread
From: David Engster @ 2013-02-10 15:21 UTC (permalink / raw)
To: Stefan Monnier; +Cc: emacs-devel
[-- Attachment #1: Type: text/plain, Size: 917 bytes --]
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
[-- Attachment #2: eieio-describe-patch.diff --]
[-- Type: text/plain, Size: 16946 bytes --]
=== 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.")))))))
^ permalink raw reply [flat|nested] 10+ messages in thread