diff options
author | Stefan Monnier <monnier@iro.umontreal.ca> | 2015-07-07 02:14:16 -0400 |
---|---|---|
committer | Stefan Monnier <monnier@iro.umontreal.ca> | 2015-07-07 02:14:16 -0400 |
commit | 59b5723c9b613f14cd60cd3239cfdbc0d2343b18 (patch) | |
tree | 923edc0b04619ab41af69078d8cd9e3f86df5038 | |
parent | 287bce988895b104c33d53faacfffd91d8d8e0f1 (diff) | |
download | emacs-59b5723c9b613f14cd60cd3239cfdbc0d2343b18.tar.gz |
Add online-help support to describe types
* lisp/help-fns.el (describe-symbol-backends): Move to help-mode.el.
(describe-symbol): Improve the selection of default.
* lisp/help-mode.el: Require cl-lib.
(describe-symbol-backends): Move from help-fns.el.
(help-make-xrefs): Use it.
* lisp/emacs-lisp/cl-extra.el (describe-symbol-backends): Add entry
for types.
(cl--typedef-regexp): New const.
(find-function-regexp-alist): Add entry for types.
(cl-help-type, cl-type-definition): New buttons.
(cl-find-class): New function.
(cl-describe-type): New command.
(cl--describe-class, cl--describe-class-slot)
(cl--describe-class-slots): New functions, moved from eieio-opt.el.
* lisp/emacs-lisp/cl-generic.el (cl--generic-method-documentation)
(cl--generic-all-functions, cl--generic-specializers-apply-to-type-p):
New functions. Moved from eieio-opt.el.
(cl--generic-class-parents): New function, extracted from
cl--generic-struct-specializers.
(cl--generic-struct-specializers): Use it.
* lisp/emacs-lisp/cl-macs.el (cl-defstruct): Use pcase-dolist.
Improve constructor's docstrings.
(cl-struct-unknown-slot): New error.
(cl-struct-slot-offset): Use it.
* lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Record the type
definition in current-load-list.
* lisp/emacs-lisp/eieio-core.el (eieio--known-slot-names): New var.
(eieio--add-new-slot): Set it.
(eieio-defclass-internal): Use new name for current-load-list.
(eieio-oref): Add compiler-macro to warn about unknown slots.
* lisp/emacs-lisp/eieio.el (defclass): Update eieio--known-slot-names
as compile-time as well. Improve constructor docstrings.
* lisp/emacs-lisp/eieio-opt.el (eieio-help-class)
(eieio--help-print-slot, eieio-help-class-slots): Move to cl-extra.el.
(eieio-class-def): Remove button.
(eieio-help-constructor): Use new name for load-history element.
(eieio--specializers-apply-to-class-p, eieio-all-generic-functions)
(eieio-method-documentation): Move to cl-generic.el.
(eieio-display-method-list): Use new names.
* lisp/emacs-lisp/lisp-mode.el (lisp-imenu-generic-expression):
Add "define-linline".
(lisp-fdefs): Remove "defsubst".
(el-fdefs): Add "defsubst", "cl-defsubst", and "define-linline".
* lisp/emacs-lisp/macroexp.el (macroexp--warned): New var.
(macroexp--warn-and-return): Use it to avoid inf-loops.
Add `compile-only' argument.
-rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 163 | ||||
-rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 71 | ||||
-rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 22 | ||||
-rw-r--r-- | lisp/emacs-lisp/cl-preloaded.el | 1 | ||||
-rw-r--r-- | lisp/emacs-lisp/eieio-core.el | 96 | ||||
-rw-r--r-- | lisp/emacs-lisp/eieio-opt.el | 156 | ||||
-rw-r--r-- | lisp/emacs-lisp/eieio.el | 19 | ||||
-rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 7 | ||||
-rw-r--r-- | lisp/emacs-lisp/macroexp.el | 52 | ||||
-rw-r--r-- | lisp/help-fns.el | 23 | ||||
-rw-r--r-- | lisp/help-mode.el | 38 |
11 files changed, 360 insertions, 288 deletions
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 3313cc77db5..38cc772e8b0 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -688,6 +688,169 @@ including `cl-block' and `cl-eval-when'." (prog1 (cl-prettyprint form) (message "")))) +;;; Integration into the online help system. + +(eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class. +(require 'help-mode) + +;; FIXME: We could go crazy and add another entry so describe-symbol can be +;; used with the slot names of CL structs (and/or EIEIO objects). +(add-to-list 'describe-symbol-backends + `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s)))) + +(defconst cl--typedef-regexp + (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct" + "cl-deftype" "deftype")) + "[ \t\r\n]+%s[ \t\r\n]+")) +(with-eval-after-load 'find-func + (defvar find-function-regexp-alist) + (add-to-list 'find-function-regexp-alist + `(define-type . cl--typedef-regexp))) + +(define-button-type 'cl-help-type + :supertype 'help-function-def + 'help-function #'cl-describe-type + 'help-echo (purecopy "mouse-2, RET: describe this type")) + +(define-button-type 'cl-type-definition + :supertype 'help-function-def + 'help-echo (purecopy "mouse-2, RET: find type definition")) + +(declare-function help-fns-short-filename "help-fns" (filename)) + +;;;###autoload +(defun cl-find-class (type) (cl--find-class type)) + +;;;###autoload +(defun cl-describe-type (type) + "Display the documentation for type TYPE (a symbol)." + (interactive + (let ((str (completing-read "Describe type: " obarray #'cl-find-class t))) + (if (<= (length str) 0) + (user-error "Abort!") + (list (intern str))))) + (help-setup-xref (list #'cl-describe-type type) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer standard-output + (let ((class (cl-find-class type))) + (if class + (cl--describe-class type class) + ;; FIXME: Describe other types (the built-in ones, or those from + ;; cl-deftype). + (user-error "Unknown type %S" type)))) + (with-current-buffer standard-output + ;; Return the text we displayed. + (buffer-string))))) + +(defun cl--describe-class (type &optional class) + (unless class (setq class (cl--find-class type))) + (let ((location (find-lisp-object-file-name type 'define-type)) + ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. + (metatype (cl--class-name (symbol-value (aref class 0))))) + (insert (symbol-name type) + (substitute-command-keys " is a type (of kind ‘")) + (help-insert-xref-button (symbol-name metatype) + 'cl-help-type metatype) + (insert (substitute-command-keys "’)")) + (when location + (insert (substitute-command-keys " in ‘")) + (help-insert-xref-button + (help-fns-short-filename location) + 'cl-type-definition type location 'define-type) + (insert (substitute-command-keys "’"))) + (insert ".\n") + + ;; Parents. + (let ((pl (cl--class-parents class)) + cur) + (when pl + (insert " Inherits from ") + (while (setq cur (pop pl)) + (setq cur (cl--class-name cur)) + (insert (substitute-command-keys "‘")) + (help-insert-xref-button (symbol-name cur) + 'cl-help-type cur) + (insert (substitute-command-keys (if pl "’, " "’")))) + (insert ".\n"))) + + ;; Children, if available. ¡For EIEIO! + (let ((ch (condition-case nil + (cl-struct-slot-value metatype 'children class) + (cl-struct-unknown-slot nil))) + cur) + (when ch + (insert " Children ") + (while (setq cur (pop ch)) + (insert (substitute-command-keys "‘")) + (help-insert-xref-button (symbol-name cur) + 'cl-help-type cur) + (insert (substitute-command-keys (if ch "’, " "’")))) + (insert ".\n"))) + + ;; Type's documentation. + (let ((doc (cl--class-docstring class))) + (when doc + (insert "\n" doc "\n\n"))) + + ;; Describe all the slots in this class. + (cl--describe-class-slots class) + + ;; Describe all the methods specific to this class. + (let ((generics (cl--generic-all-functions type))) + (when generics + (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) + (dolist (generic generics) + (insert (substitute-command-keys "‘")) + (help-insert-xref-button (symbol-name generic) + 'help-function generic) + (insert (substitute-command-keys "’")) + (pcase-dolist (`(,qualifiers ,args ,doc) + (cl--generic-method-documentation generic type)) + (insert (format " %s%S\n" qualifiers args) + (or doc ""))) + (insert "\n\n")))))) + +(defun cl--describe-class-slot (slot) + (insert + (concat + (propertize "Slot: " 'face 'bold) + (prin1-to-string (cl--slot-descriptor-name slot)) + (unless (eq (cl--slot-descriptor-type slot) t) + (concat " type = " + (prin1-to-string (cl--slot-descriptor-type slot)))) + ;; FIXME: The default init form is treated differently for structs and for + ;; eieio objects: for structs, the default is nil, for eieio-objects + ;; it's a special "unbound" value. + (unless nil ;; (eq (cl--slot-descriptor-initform slot) eieio-unbound) + (concat " default = " + (prin1-to-string (cl--slot-descriptor-initform slot)))) + (when (alist-get :printer (cl--slot-descriptor-props slot)) + (concat " printer = " + (prin1-to-string + (alist-get :printer (cl--slot-descriptor-props slot))))) + (when (alist-get :documentation (cl--slot-descriptor-props slot)) + (concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot)) + "\n"))) + "\n")) + +(defun cl--describe-class-slots (class) + "Print help description for the slots in CLASS. +Outputs to the current buffer." + (let* ((slots (cl--class-slots class)) + ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. + (metatype (cl--class-name (symbol-value (aref class 0)))) + ;; ¡For EIEIO! + (cslots (condition-case nil + (cl-struct-slot-value metatype 'class-slots class) + (cl-struct-unknown-slot nil)))) + (insert (propertize "Instance Allocated Slots:\n\n" + 'face 'bold)) + (mapc #'cl--describe-class-slot slots) + (when (> (length cslots) 0) + (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)) + (mapc #'cl--describe-class-slot cslots)))) (run-hooks 'cl-extra-load-hook) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5923e4db996..a3bb7c3ad7b 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -95,6 +95,7 @@ ;; usually be simplified, or even completely skipped. (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'cl-macs)) ;For cl--find-class. (eval-when-compile (require 'pcase)) (cl-defstruct (cl--generic-generalizer @@ -883,6 +884,55 @@ Can only be used from within the lexical body of a primary or around method." (insert (substitute-command-keys "’.\n")))) (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) +(defun cl--generic-specializers-apply-to-type-p (specializers type) + "Return non-nil if a method with SPECIALIZERS applies to TYPE." + (let ((applies nil)) + (dolist (specializer specializers) + (if (memq (car-safe specializer) '(subclass eieio--static)) + (setq specializer (nth 1 specializer))) + ;; Don't include the methods that are "too generic", such as those + ;; applying to `eieio-default-superclass'. + (and (not (memq specializer '(t eieio-default-superclass))) + (or (equal type specializer) + (when (symbolp specializer) + (let ((sclass (cl--find-class specializer)) + (tclass (cl--find-class type))) + (when (and sclass tclass) + (member specializer (cl--generic-class-parents tclass)))))) + (setq applies t))) + applies)) + +(defun cl--generic-all-functions (&optional type) + "Return a list of all generic functions. +Optional TYPE argument returns only those functions that contain +methods for TYPE." + (let ((l nil)) + (mapatoms + (lambda (symbol) + (let ((generic (and (fboundp symbol) (cl--generic symbol)))) + (and generic + (catch 'found + (if (null type) (throw 'found t)) + (dolist (method (cl--generic-method-table generic)) + (if (cl--generic-specializers-apply-to-type-p + (cl--generic-method-specializers method) type) + (throw 'found t)))) + (push symbol l))))) + l)) + +(defun cl--generic-method-documentation (function type) + "Return info for all methods of FUNCTION (a symbol) applicable to TYPE. +The value returned is a list of elements of the form +\(QUALIFIERS ARGS DOC)." + (let ((generic (cl--generic function)) + (docs ())) + (when generic + (dolist (method (cl--generic-method-table generic)) + (when (cl--generic-specializers-apply-to-type-p + (cl--generic-method-specializers method) type) + (push (cl--generic-method-info method) docs)))) + docs)) + ;;; Support for (head <val>) specializers. ;; For both the `eql' and the `head' specializers, the dispatch @@ -958,19 +1008,22 @@ Can only be used from within the lexical body of a primary or around method." (if (eq (symbol-function tag) :quick-object-witness-check) tag)))) +(defun cl--generic-class-parents (class) + (let ((parents ()) + (classes (list class))) + ;; BFS precedence. FIXME: Use a topological sort. + (while (let ((class (pop classes))) + (cl-pushnew (cl--class-name class) parents) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse parents))) + (defun cl--generic-struct-specializers (tag) (and (symbolp tag) (boundp tag) (let ((class (symbol-value tag))) (when (cl-typep class 'cl-structure-class) - (let ((types ()) - (classes (list class))) - ;; BFS precedence. - (while (let ((class (pop classes))) - (push (cl--class-name class) types) - (setq classes - (append classes - (cl--class-parents class))))) - (nreverse types)))))) + (cl--generic-class-parents class))))) (defconst cl--generic-struct-generalizer (cl-generic-make-generalizer diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5bcf0882791..f5e1ffb0008 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2722,20 +2722,16 @@ non-nil value, that slot cannot be set via `setf'. (push `(defalias ',copier #'copy-sequence) forms)) (if constructor (push (list constructor - (cons '&key (delq nil (copy-sequence slots)))) - constrs)) - (while constrs - (let* ((name (caar constrs)) - (rest (cdr (pop constrs))) - (args (car rest)) - (doc (cadr rest)) - (anames (cl--arglist-args args)) + (cons '&key (delq nil (copy-sequence slots)))) + constrs)) + (pcase-dolist (`(,cname ,args ,doc) constrs) + (let* ((anames (cl--arglist-args args)) (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) - (push `(cl-defsubst ,name + (push `(cl-defsubst ,cname (&cl-defs (nil ,@descs) ,@args) - ,@(if (stringp doc) (list doc) - (if (stringp docstring) (list docstring))) + ,(if (stringp doc) (list doc) + (format "Constructor for objects of type `%s'." name)) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) (,(or type #'vector) ,@make)) @@ -2859,6 +2855,8 @@ slots skipped by :initial-offset may appear in the list." descs))) (nreverse descs))) +(define-error 'cl-struct-unknown-slot "struct %S has no slot %S") + (defun cl-struct-slot-offset (struct-type slot-name) "Return the offset of slot SLOT-NAME in STRUCT-TYPE. The returned zero-based slot index is relative to the start of @@ -2868,7 +2866,7 @@ does not contain SLOT-NAME." (declare (side-effect-free t) (pure t)) (or (gethash slot-name (cl--class-index-table (cl--struct-get-class struct-type))) - (error "struct %s has no slot %s" struct-type slot-name))) + (signal 'cl-struct-unknown-slot (list struct-type slot-name)))) (defvar byte-compile-function-environment) (defvar byte-compile-macro-environment) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 60f654258b0..03480b2756b 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -147,6 +147,7 @@ ok) (error "Included struct %S has changed since compilation of %S" parent name)))) + (add-to-list 'current-load-list `(define-type . ,name)) (cl--struct-register-child parent-class tag) (unless (eq named t) (eval `(defconst ,tag ',class) t) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 8a09f071e2e..7fcf85c1ced 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -261,6 +261,8 @@ It creates an autoload function for CNAME's constructor." (and (eieio-object-p obj) (object-of-class-p obj class)))) +(defvar eieio--known-slot-names nil) + (defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. SLOTS are the slots residing in that class definition, and OPTIONS @@ -473,7 +475,7 @@ See `defclass' for more information." (put cname 'variable-documentation docstring))) ;; Save the file location where this class is defined. - (add-to-list 'current-load-list `(eieio-defclass . ,cname)) + (add-to-list 'current-load-list `(define-type . ,cname)) ;; We have a list of custom groups. Store them into the options. (let ((g (eieio--class-option-assoc options :custom-groups))) @@ -603,47 +605,48 @@ if default value is nil." :key #'cl--slot-descriptor-name))) (cold (car (cl-member a (eieio--class-class-slots newc) :key #'cl--slot-descriptor-name)))) - (condition-case nil - (if (sequencep d) (setq d (copy-sequence d))) - ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's - ;; skip it if it doesn't work. - (error nil)) - ;; (if (sequencep type) (setq type (copy-sequence type))) - ;; (if (sequencep cust) (setq cust (copy-sequence cust))) - ;; (if (sequencep custg) (setq custg (copy-sequence custg))) - - ;; To prevent override information w/out specification of storage, - ;; we need to do this little hack. - (if cold (setq alloc :class)) - - (if (memq alloc '(nil :instance)) - ;; In this case, we modify the INSTANCE version of a given slot. - (progn - ;; Only add this element if it is so-far unique - (if (not old) - (progn - (eieio--perform-slot-validation-for-default slot skipnil) - (push slot (eieio--class-slots newc)) - ) - ;; When defaultoverride is true, we are usually adding new local - ;; attributes which must override the default value of any slot - ;; passed in by one of the parent classes. - (when defaultoverride - (eieio--slot-override old slot skipnil))) - (when init - (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc) - :test #'equal))) - - ;; CLASS ALLOCATED SLOTS - (if (not cold) + (cl-pushnew a eieio--known-slot-names) + (condition-case nil + (if (sequencep d) (setq d (copy-sequence d))) + ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's + ;; skip it if it doesn't work. + (error nil)) + ;; (if (sequencep type) (setq type (copy-sequence type))) + ;; (if (sequencep cust) (setq cust (copy-sequence cust))) + ;; (if (sequencep custg) (setq custg (copy-sequence custg))) + + ;; To prevent override information w/out specification of storage, + ;; we need to do this little hack. + (if cold (setq alloc :class)) + + (if (memq alloc '(nil :instance)) + ;; In this case, we modify the INSTANCE version of a given slot. (progn - (eieio--perform-slot-validation-for-default slot skipnil) - ;; Here we have found a :class version of a slot. This - ;; requires a very different approach. - (push slot (eieio--class-class-slots newc))) - (when defaultoverride - ;; There is a match, and we must override the old value. - (eieio--slot-override cold slot skipnil)))))) + ;; Only add this element if it is so-far unique + (if (not old) + (progn + (eieio--perform-slot-validation-for-default slot skipnil) + (push slot (eieio--class-slots newc)) + ) + ;; When defaultoverride is true, we are usually adding new local + ;; attributes which must override the default value of any slot + ;; passed in by one of the parent classes. + (when defaultoverride + (eieio--slot-override old slot skipnil))) + (when init + (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc) + :test #'equal))) + + ;; CLASS ALLOCATED SLOTS + (if (not cold) + (progn + (eieio--perform-slot-validation-for-default slot skipnil) + ;; Here we have found a :class version of a slot. This + ;; requires a very different approach. + (push slot (eieio--class-class-slots newc))) + (when defaultoverride + ;; There is a match, and we must override the old value. + (eieio--slot-override cold slot skipnil)))))) (defun eieio-copy-parents-into-subclass (newc) "Copy into NEWC the slots of PARENTS. @@ -720,9 +723,18 @@ Argument FN is the function calling this verifier." ;;; Get/Set slots in an object. -;; + (defun eieio-oref (obj slot) "Return the value in OBJ at SLOT in the object vector." + (declare (compiler-macro + (lambda (exp) + (ignore obj) + (pcase slot + ((and (or `',name (and name (pred keywordp))) + (guard (not (memq name eieio--known-slot-names)))) + (macroexp--warn-and-return + (format "Unknown slot `%S'" name) exp 'compile-only)) + (_ exp))))) (cl-check-type slot symbol) (cl-check-type obj (or eieio-object class)) (let* ((class (cond ((symbolp obj) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index f7dbdf5014b..9ecc59434e1 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -31,7 +31,6 @@ (require 'eieio) (require 'find-func) (require 'speedbar) -(require 'help-mode) ;;; Code: ;;;###autoload @@ -78,101 +77,7 @@ Argument CH-PREFIX is another character prefix to display." (declare-function help-fns-short-filename "help-fns" (filename)) ;;;###autoload -(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 (eieio--class-option (cl--find-class class) :abstract) - "n abstract" - "") - " class") - (let ((location (find-lisp-object-file-name class 'eieio-defclass))) - (when location - (insert (substitute-command-keys " in ‘")) - (help-insert-xref-button - (help-fns-short-filename location) - 'eieio-class-def class location 'eieio-defclass) - (insert (substitute-command-keys "’")))) - (insert ".\n") - ;; Parents - (let ((pl (eieio-class-parents class)) - cur) - (when pl - (insert " Inherits from ") - (while (setq cur (pop pl)) - (setq cur (eieio--class-name cur)) - (insert (substitute-command-keys "‘")) - (help-insert-xref-button (symbol-name cur) - 'help-function cur) - (insert (substitute-command-keys (if pl "’, " "’")))) - (insert ".\n"))) - ;; Children - (let ((ch (eieio-class-children class)) - cur) - (when ch - (insert " Children ") - (while (setq cur (pop ch)) - (insert (substitute-command-keys "‘")) - (help-insert-xref-button (symbol-name cur) - 'help-function cur) - (insert (substitute-command-keys (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 ((generics (eieio-all-generic-functions class))) - (when generics - (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) - (dolist (generic generics) - (insert (substitute-command-keys "‘")) - (help-insert-xref-button (symbol-name generic) 'help-function generic) - (insert (substitute-command-keys "’")) - (pcase-dolist (`(,qualifiers ,args ,doc) - (eieio-method-documentation generic class)) - (insert (format " %s%S\n" qualifiers args) - (or doc ""))) - (insert "\n\n"))))) - -(defun eieio--help-print-slot (slot) - (insert - (concat - (propertize "Slot: " 'face 'bold) - (prin1-to-string (cl--slot-descriptor-name slot)) - (unless (eq (cl--slot-descriptor-type slot) t) - (concat " type = " - (prin1-to-string (cl--slot-descriptor-type slot)))) - (unless (eq (cl--slot-descriptor-initform slot) eieio-unbound) - (concat " default = " - (prin1-to-string (cl--slot-descriptor-initform slot)))) - (when (alist-get :printer (cl--slot-descriptor-props slot)) - (concat " printer = " - (prin1-to-string - (alist-get :printer (cl--slot-descriptor-props slot))))) - (when (alist-get :documentation (cl--slot-descriptor-props slot)) - (concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot)) - "\n"))) - "\n")) - -(defun eieio-help-class-slots (class) - "Print help description for the slots in CLASS. -Outputs to the current buffer." - (let* ((cv (cl--find-class class)) - (slots (eieio--class-slots cv)) - (cslots (eieio--class-class-slots cv))) - (insert (propertize "Instance Allocated Slots:\n\n" - 'face 'bold)) - (dotimes (i (length slots)) - (eieio--help-print-slot (aref slots i))) - (when (> (length cslots) 0) - (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))) - (dotimes (i (length cslots)) - (eieio--help-print-slot (aref cslots i))))) +(define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1") (defun eieio-build-class-alist (&optional class instantiable-only buildlist) "Return an alist of all currently active classes for completion purposes. @@ -217,22 +122,13 @@ are not abstract." ;;; METHOD COMPLETION / DOC -(define-button-type 'eieio-class-def - :supertype 'help-function-def - 'help-echo (purecopy "mouse-2, RET: find class definition")) - -(defconst eieio--defclass-regexp "(defclass[ \t\r\n]+%s[ \t\r\n]+") -(with-eval-after-load 'find-func - (defvar find-function-regexp-alist) - (add-to-list 'find-function-regexp-alist - `(eieio-defclass . eieio--defclass-regexp))) ;;;###autoload (defun eieio-help-constructor (ctr) "Describe CTR if it is a class constructor." (when (class-p ctr) (erase-buffer) - (let ((location (find-lisp-object-file-name ctr 'eieio-defclass)) + (let ((location (find-lisp-object-file-name ctr 'define-type)) (def (symbol-function ctr))) (goto-char (point-min)) (prin1 ctr) @@ -248,7 +144,7 @@ are not abstract." (insert (substitute-command-keys " in ‘")) (help-insert-xref-button (help-fns-short-filename location) - 'eieio-class-def ctr location 'eieio-defclass) + 'cl-type-definition ctr location 'define-type) (insert (substitute-command-keys "’"))) (insert ".\nCreates an object of class " (symbol-name ctr) ".") (goto-char (point-max)) @@ -259,50 +155,6 @@ are not abstract." (eieio-help-class ctr)) )))) -(defun eieio--specializers-apply-to-class-p (specializers class) - "Return non-nil if a method with SPECIALIZERS applies to CLASS." - (let ((applies nil)) - (dolist (specializer specializers) - (if (memq (car-safe specializer) '(subclass eieio--static)) - (setq specializer (nth 1 specializer))) - ;; Don't include the methods that are "too generic", such as those - ;; applying to `eieio-default-superclass'. - (and (not (memq specializer '(t eieio-default-superclass))) - (class-p specializer) - (child-of-class-p class specializer) - (setq applies t))) - applies)) - -(defun eieio-all-generic-functions (&optional class) - "Return a list of all generic functions. -Optional CLASS argument returns only those functions that contain -methods for CLASS." - (let ((l nil)) - (mapatoms - (lambda (symbol) - (let ((generic (and (fboundp symbol) (cl--generic symbol)))) - (and generic - (catch 'found - (if (null class) (throw 'found t)) - (dolist (method (cl--generic-method-table generic)) - (if (eieio--specializers-apply-to-class-p - (cl--generic-method-specializers method) class) - (throw 'found t)))) - (push symbol l))))) - l)) - -(defun eieio-method-documentation (generic class) - "Return info for all methods of GENERIC applicable to CLASS. -The value returned is a list of elements of the form -\(QUALIFIERS ARGS DOC)." - (let ((generic (cl--generic generic)) - (docs ())) - (when generic - (dolist (method (cl--generic-method-table generic)) - (when (eieio--specializers-apply-to-class-p - (cl--generic-method-specializers method) class) - (push (cl--generic-method-info method) docs)))) - docs)) ;;; METHOD STATS ;; @@ -310,7 +162,7 @@ The value returned is a list of elements of the form (defun eieio-display-method-list () "Display a list of all the methods and what features are used." (interactive) - (let* ((meth1 (eieio-all-generic-functions)) + (let* ((meth1 (cl--generic-all-functions)) (meth (sort meth1 (lambda (a b) (string< (symbol-name a) (symbol-name b))))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index eee848f7869..84a68a83736 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -142,6 +142,10 @@ and reference them using the function `class-option'." (alloc (plist-get soptions :allocation)) (label (plist-get soptions :label))) + ;; Update eieio--known-slot-names already in case we compile code which + ;; uses this before the class is loaded. + (cl-pushnew sname eieio--known-slot-names) + (if eieio-error-unsupported-class-tags (let ((tmp soptions)) (while tmp @@ -254,13 +258,12 @@ This method is obsolete." (if (not (stringp abs)) (setq abs (format "Class %s is abstract" name))) `(defun ,name (&rest _) - ,(format "You cannot create a new object of type %S." name) + ,(format "You cannot create a new object of type `%S'." name) (error ,abs))) ;; Non-abstract classes need a constructor. `(defun ,name (&rest slots) - ,(format "Create a new object with name NAME of class type %S." - name) + ,(format "Create a new object of class type `%S'." name) (declare (compiler-macro (lambda (whole) (if (not (stringp (car slots))) @@ -941,6 +944,8 @@ of `eq'." (error "EIEIO: `change-class' is unimplemented")) ;; Hook ourselves into help system for describing classes and methods. +;; FIXME: This is not actually needed any more since we can click on the +;; hyperlink from the constructor's docstring to see the type definition. (add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) ;;; Interfacing with edebug @@ -978,7 +983,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "b7995d9076e4dd4b9358b2aa66835619") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "cb1aba7670b6a4b9c6f968c0ad6dc130") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ @@ -988,11 +993,7 @@ variable `eieio-default-superclass'. \(fn &optional ROOT-CLASS)" t nil) -(autoload 'eieio-help-class "eieio-opt" "\ -Print help description for CLASS. -If CLASS is actually an object, then also display current values of that object. - -\(fn CLASS)" nil nil) +(define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1") (autoload 'eieio-help-constructor "eieio-opt" "\ Describe CTR if it is a class constructor. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 72a23cfdfc6..8aa34c7bef9 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -95,7 +95,7 @@ (regexp-opt '("defun" "defmacro" ;; Elisp. - "defun*" "defsubst" + "defun*" "defsubst" "define-inline" "define-advice" "defadvice" "define-skeleton" "define-compilation-mode" "define-minor-mode" "define-global-minor-mode" @@ -230,7 +230,7 @@ (throw 'found t)))))) (let-when-compile - ((lisp-fdefs '("defmacro" "defsubst" "defun")) + ((lisp-fdefs '("defmacro" "defun")) (lisp-vdefs '("defvar")) (lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1" "prog2" "lambda" "unwind-protect" "condition-case" @@ -240,7 +240,8 @@ ;; Elisp constructs. Now they are update dynamically ;; from obarray but they are also used for setting up ;; the keywords for Common Lisp. - (el-fdefs '("define-advice" "defadvice" "defalias" + (el-fdefs '("defsubst" "cl-defsubst" "define-inline" + "define-advice" "defadvice" "defalias" "define-derived-mode" "define-minor-mode" "define-generic-mode" "define-global-minor-mode" "define-globalized-minor-mode" "define-skeleton" diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 57cbec580b0..ffc6585e191 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -119,20 +119,28 @@ and also to avoid outputting the warning during normal execution." (member '(declare-function . byte-compile-macroexpand-declare-function) macroexpand-all-environment)) +(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-and-return (msg form) +(defun macroexp--warn-and-return (msg form &optional compile-only) (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) (cond ((null msg) form) ((macroexp--compiling-p) - `(progn - (macroexp--funcall-if-compiled ',when-compiled) - ,form)) + (if (gethash form macroexp--warned) + ;; Already wrapped this exp with a warning: avoid inf-looping + ;; where we keep adding the same warning onto `form' because + ;; macroexpand-all gets right back to macroexpanding `form'. + form + (puthash form form macroexp--warned) + `(progn + (macroexp--funcall-if-compiled ',when-compiled) + ,form))) (t - (message "%s%s" (if (stringp load-file-name) - (concat (file-relative-name load-file-name) ": ") - "") - msg) + (unless compile-only + (message "%s%s" (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") + msg)) form)))) (defun macroexp--obsolete-warning (fun obsolescence-data type) @@ -208,30 +216,30 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--cons 'condition-case (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) form)) (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2)) (`(function ,(and f `(lambda . ,_))) (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form)) + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form)) (`(,(or `function `quote) . ,_) form) (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare)) (macroexp--cons fun - (macroexp--cons (macroexp--all-clauses bindings 1) - (macroexp--all-forms body) - (cdr form)) - form)) + (macroexp--cons (macroexp--all-clauses bindings 1) + (macroexp--all-forms body) + (cdr form)) + form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form)) + (macroexp--all-forms args) + form)) ;; The following few cases are for normal function calls that ;; are known to funcall one of their arguments. The byte ;; compiler has traditionally handled these functions specially diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 0a22c5ebcff..1c7a68abdec 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -33,6 +33,7 @@ ;;; Code: (require 'cl-lib) +(require 'help-mode) (defvar help-fns-describe-function-functions nil "List of functions to run in help buffer in `describe-function'. @@ -970,15 +971,6 @@ file-local variable.\n") (buffer-string)))))))) -(defvar describe-symbol-backends - `((nil ,#'fboundp ,(lambda (s _b _f) (describe-function s))) - ("face" ,#'facep ,(lambda (s _b _f) (describe-face s))) - (nil - ,(lambda (symbol) - (or (and (boundp symbol) (not (keywordp symbol))) - (get symbol 'variable-documentation))) - ,#'describe-variable))) - (defvar help-xref-stack-item) ;;;###autoload @@ -986,23 +978,22 @@ file-local variable.\n") "Display the full documentation of SYMBOL. Will show the info of SYMBOL as a function, variable, and/or face." (interactive - ;; FIXME: also let the user enter a face name. - (let* ((v-or-f (variable-at-point)) - (found (symbolp v-or-f)) + (let* ((v-or-f (symbol-at-point)) + (found (cl-some (lambda (x) (funcall (nth 1 x) v-or-f)) + describe-symbol-backends)) (v-or-f (if found v-or-f (function-called-at-point))) (found (or found v-or-f)) (enable-recursive-minibuffers t) - val) - (setq val (completing-read (if found + (val (completing-read (if found (format - "Describe symbol (default %s): " v-or-f) + "Describe symbol (default %s): " v-or-f) "Describe symbol: ") obarray (lambda (vv) (cl-some (lambda (x) (funcall (nth 1 x) vv)) describe-symbol-backends)) t nil nil - (if found (symbol-name v-or-f)))) + (if found (symbol-name v-or-f))))) (list (if (equal val "") v-or-f (intern val))))) (if (not (symbolp symbol)) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index cdddd542532..e1fc9fd1984 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -30,6 +30,7 @@ ;;; Code: (require 'button) +(require 'cl-lib) (eval-when-compile (require 'easymenu)) (defvar help-mode-map @@ -216,7 +217,8 @@ The format is (FUNCTION ARGS...).") (goto-char (point-min)) (if (re-search-forward (format "^[ \t]*(\\(cl-\\)?define-compiler-macro[ \t]+%s" - (regexp-quote (symbol-name fun))) nil t) + (regexp-quote (symbol-name fun))) + nil t) (forward-line 0) (message "Unable to find location in file"))) (message "Unable to find file"))) @@ -385,6 +387,15 @@ it does not already exist." (error "Current buffer is not in Help mode")) (current-buffer)))) +(defvar describe-symbol-backends + `((nil ,#'fboundp ,(lambda (s _b _f) (describe-function s))) + ("face" ,#'facep ,(lambda (s _b _f) (describe-face s))) + (nil + ,(lambda (symbol) + (or (and (boundp symbol) (not (keywordp symbol))) + (get symbol 'variable-documentation))) + ,#'describe-variable))) + ;;;###autoload (defun help-make-xrefs (&optional buffer) "Parse and hyperlink documentation cross-references in the given BUFFER. @@ -487,28 +498,9 @@ that." ;; (pop-to-buffer (car location)) ;; (goto-char (cdr location)))) (help-xref-button 8 'help-function-def sym)) - ((and - (facep sym) - (save-match-data (looking-at "[ \t\n]+face\\W"))) - (help-xref-button 8 'help-face sym)) - ((and (or (boundp sym) - (get sym 'variable-documentation)) - (fboundp sym)) - ;; We can't intuit whether to use the - ;; variable or function doc -- supply both. - (help-xref-button 8 'help-symbol sym)) - ((and - (or (boundp sym) - (get sym 'variable-documentation)) - (or - (documentation-property - sym 'variable-documentation) - (documentation-property - (indirect-variable sym) - 'variable-documentation))) - (help-xref-button 8 'help-variable sym)) - ((fboundp sym) - (help-xref-button 8 'help-function sym))))))) + ((cl-some (lambda (x) (funcall (nth 1 x) sym)) + describe-symbol-backends) + (help-xref-button 8 'help-symbol sym))))))) ;; An obvious case of a key substitution: (save-excursion (while (re-search-forward |