From: David Engster Date: Wed, 8 Jan 2014 21:30:12 +0000 (+0100) Subject: Rewrite EIEIO help functions and hook them into help system. X-Git-Tag: emacs-24.3.90~173^2^2~42^2~45^2~387^2~14^2 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=0f918d96d79265531f65fd37a81e73b240f8f3d5;p=emacs.git Rewrite EIEIO help functions and hook them into help system. * help-fns.el (help-fns-describe-function-functions): New variable to call functions for augmenting help buffers. (describe-function-1): Remove explicit calls to `help-fns--compiler-macro', `help-fns--parent-mode' and `help-fns--obsolete'. Put them in above new variable instead, and call them through `run-hook-with-args'. * emacs-lisp/eieio-opt.el (eieio-help-class): Rename from `eieio-describe-class'. Not meant for interactive use anymore, but to augment existing help buffers. Remove optional second argument. Create proper button for file location. Rewrite function to use `insert' instead of `princ' and `prin1' where possible. (eieio-help-class-slots): Rename from `eieio-describe-class-slots'. (eieio-method-def, eieio-class-def): Move further up. (describe-method, describe-generic, eieio-describe-method): Remove aliases. (eieio-help-constructor, eieio-help-generic): Rename from `eieio-describe-constructor' and `eieio-describe-generic', resp. Rewrite to use `insert' in the current buffer and use proper help buttons. (eieio-help-find-method-definition) (eieio-help-find-class-definition): Also accept symbols as arguments. (eieio-help-mode-augmentation-maybee): Remove. (eieio-describe-class-sb): Use `describe-function'. * emacs-lisp/eieio.el (help-fns-describe-function-functions): Add `eieio-help-generic' and `eieio-help-constructor'. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 9f5e87f5e1e..0fe9c08374b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,11 +1,32 @@ -2014-01-07 David Engster +2014-01-08 David Engster * help-fns.el (help-fns-describe-function-functions): New variable to call functions for augmenting help buffers. (describe-function-1): Remove explicit calls to `help-fns--compiler-macro', `help-fns--parent-mode' and - `help-fns--obsolete'. Put them in above new variable instead. - Call all of them through `run-hook-with-args'. + `help-fns--obsolete'. Put them in above new variable instead, and + call them through `run-hook-with-args'. + * emacs-lisp/eieio-opt.el (eieio-help-class): Rename from + `eieio-describe-class'. Not meant for interactive use anymore, + but to augment existing help buffers. Remove optional second + argument. Create proper button for file location. Rewrite + function to use `insert' instead of `princ' and `prin1' where + possible. + (eieio-help-class-slots): Rename from `eieio-describe-class-slots'. + (eieio-method-def, eieio-class-def): Move further up. + (describe-method, describe-generic, eieio-describe-method): Remove + aliases. + (eieio-help-constructor, eieio-help-generic): Rename from + `eieio-describe-constructor' and `eieio-describe-generic', resp. + Rewrite to use `insert' in the current buffer and use proper help + buttons. + (eieio-help-find-method-definition) + (eieio-help-find-class-definition): Also accept symbols as + arguments. + (eieio-help-mode-augmentation-maybee): Remove. + (eieio-describe-class-sb): Use `describe-function'. + * emacs-lisp/eieio.el (help-fns-describe-function-functions): Add + `eieio-help-generic' and `eieio-help-constructor'. 2014-01-07 Martin Rudalics diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 647bbb344b1..9269c744b9f 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -74,108 +74,81 @@ Argument CH-PREFIX is another character prefix to display." ;;; CLASS COMPLETION / DOCUMENTATION -;;;###autoload(defalias 'describe-class 'eieio-describe-class) - ;;;###autoload -(defun eieio-describe-class (class &optional headerfcn) - "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 (eieio-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 (eieio-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))) - -(defun eieio-describe-class-slots (class) - "Describe the slots in CLASS. -Outputs to the standard output." +(defun eieio-help-class (class) + "Print help description for CLASS. +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 (eieio-class-parents class)) + cur) + (when pl + (insert " Inherits from ") + (while (setq cur (pop pl)) + (insert "`") + (help-insert-xref-button (symbol-name cur) + 'help-function cur) + (insert (if pl "', " "'"))) + (insert ".\n"))) + ;; Children + (let ((ch (eieio-class-children class)) + cur) + (when ch + (insert " Children ") + (while (setq cur (pop ch)) + (insert "`") + (help-insert-xref-button (symbol-name cur) + 'help-function 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-help-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 argshl dochl) + (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-help-class-slots (class) + "Print help description for the slots in CLASS. +Outputs to the current buffer." (let* ((cv (class-v class)) (docs (eieio--class-public-doc cv)) (names (eieio--class-public-a cv)) @@ -185,28 +158,27 @@ Outputs to the standard output." (i 0) (prot (eieio--class-protection cv)) ) - (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 +191,30 @@ Outputs to the standard output." i 0 prot (eieio--class-class-allocation-protection cv)) (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) @@ -326,91 +267,112 @@ are not abstract." ;;; METHOD COMPLETION / DOC -(defalias 'describe-method 'eieio-describe-generic) -;;;###autoload(defalias 'describe-generic 'eieio-describe-generic) -(defalias 'eieio-describe-method 'eieio-describe-generic) +(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-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: "))) - (eieio--check-type 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))) +(defun eieio-help-constructor (ctr) + "Describe CTR if it is a class constructor." + (when (class-p ctr) + (erase-buffer) + (let ((location (get ctr 'class-location)) + (def (symbol-function ctr))) + (goto-char (point-min)) + (prin1 ctr) + (insert (format " is an %s object constructor function" + (if (autoloadp def) + "autoloaded" + ""))) + (when (and (autoloadp def) + (null location)) + (setq location + (find-lisp-object-file-name ctr def))) + (when location + (insert " in `") + (help-insert-xref-button + (file-name-nondirectory location) + 'eieio-class-def ctr location) + (insert "'")) + (insert ".\nCreates an object of class " (symbol-name ctr) ".") + (goto-char (point-max)) + (if (autoloadp def) + (insert "\n\n[Class description not available until class definition is loaded.]\n") + (save-excursion + (insert (propertize "\n\nClass description:\n" 'face 'bold)) + (eieio-help-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." @@ -584,21 +546,13 @@ Optional argument HISTORYVAR is the variable to use as history." ;;; 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)) @@ -622,6 +576,8 @@ Optional argument HISTORYVAR is the variable to use as history." (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) @@ -642,71 +598,6 @@ Optional argument HISTORYVAR is the variable to use as history." (recenter) (beginning-of-line)))) - -(defun eieio-help-mode-augmentation-maybee (&rest unused) - "For buffers thrown into help mode, augment for EIEIO. -Arguments UNUSED are not used." - ;; Scan created buttons so far if we are in help mode. - (when (eq major-mode 'help-mode) - (save-excursion - (goto-char (point-min)) - (let ((pos t) (inhibit-read-only t)) - (while pos - (if (get-text-property (point) 'help-xref) ; move off reference - (goto-char - (or (next-single-property-change (point) 'help-xref) - (point)))) - (setq pos (next-single-property-change (point) 'help-xref)) - (when pos - (goto-char pos) - (let* ((help-data (get-text-property (point) 'help-xref)) - ;(method (car help-data)) - (args (cdr help-data))) - (when (symbolp (car args)) - (cond ((class-p (car args)) - (setcar help-data 'eieio-describe-class)) - ((generic-p (car args)) - (setcar help-data 'eieio-describe-generic)) - (t nil)) - )))) - ;; start back at the beginning, and highlight some sections - (goto-char (point-min)) - (while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) - (goto-char (point-min)) - (if (re-search-forward "^Specialized Methods:$" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) - (goto-char (point-min)) - (while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) - (goto-char (point-min)) - (while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) - (goto-char (point-min)) - (while (re-search-forward "^\\(Private \\)?Slot:" nil t) - (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)) - (goto-char (point-min)) - (cond - ((looking-at "\\(.+\\) is a generic function") - (let ((mname (match-string 1)) - cname) - (while (re-search-forward "^`\\(.+\\)'[^\0]+?Defined in `\\(.+\\)'" nil t) - (setq cname (match-string-no-properties 1)) - (help-xref-button 2 'eieio-method-def cname - mname - (cadr (assoc (intern cname) - (get (intern mname) - 'method-locations))))))) - ((looking-at "\\(.+\\) is an object constructor function in `\\(.+\\)'") - (let ((cname (match-string-no-properties 1))) - (help-xref-button 2 'eieio-class-def cname - (get (intern cname) 'class-location)))) - ((looking-at "\\(.+\\) is a\\(n abstract\\)? class in `\\(.+\\)'") - (let ((cname (match-string-no-properties 1))) - (help-xref-button 3 'eieio-class-def cname - (get (intern cname) 'class-location))))) - )))) - ;;; SPEEDBAR SUPPORT ;; @@ -796,7 +687,7 @@ Argument INDENT is the depth of indentation." "Describe the class TEXT in TOKEN. INDENT is the current indentation level." (dframe-with-attached-buffer - (eieio-describe-class token)) + (describe-function token)) (dframe-maybee-jump-to-attached-frame)) (provide 'eieio-opt) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 3b1ba003d94..4d572601243 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -865,6 +865,10 @@ This may create or delete slots, but does not affect the return value of `eq'." (error "EIEIO: `change-class' is unimplemented")) +;; 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)