[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 59b5723: Add online-help support to describe types
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] master 59b5723: Add online-help support to describe types |
|
Date: |
Tue, 07 Jul 2015 06:14:23 +0000 |
branch: master
commit 59b5723c9b613f14cd60cd3239cfdbc0d2343b18
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>
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.
---
lisp/emacs-lisp/cl-extra.el | 163 +++++++++++++++++++++++++++++++++++++++
lisp/emacs-lisp/cl-generic.el | 71 +++++++++++++++--
lisp/emacs-lisp/cl-macs.el | 22 +++---
lisp/emacs-lisp/cl-preloaded.el | 1 +
lisp/emacs-lisp/eieio-core.el | 96 +++++++++++++----------
lisp/emacs-lisp/eieio-opt.el | 156 +------------------------------------
lisp/emacs-lisp/eieio.el | 19 +++--
lisp/emacs-lisp/lisp-mode.el | 7 +-
lisp/emacs-lisp/macroexp.el | 52 +++++++-----
lisp/help-fns.el | 23 ++----
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 3313cc7..38cc772 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 5923e4d..a3bb7c3 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 5bcf088..f5e1ffb 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 60f6542..03480b2 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 8a09f07..7fcf85c 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 f7dbdf5..9ecc594 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 eee848f..84a68a8 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 72a23cf..8aa34c7 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 57cbec5..ffc6585 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 0a22c5e..1c7a68a 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 cdddd54..e1fc9fd 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
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 59b5723: Add online-help support to describe types,
Stefan Monnier <=