;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
-;; Copyright (C) 1996, 1998-2003, 2005, 2008-2014 Free Software
+;; Copyright (C) 1996, 1998-2003, 2005, 2008-2015 Free Software
;; Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
Argument CH-PREFIX is another character prefix to display."
(eieio--check-type class-p this-root)
(let ((myname (symbol-name this-root))
- (chl (eieio--class-children (class-v this-root)))
+ (chl (eieio--class-children (eieio--class-v this-root)))
(fprefix (concat ch-prefix " +--"))
(mprefix (concat ch-prefix " | "))
(lprefix (concat ch-prefix " ")))
;; Header line
(prin1 class)
(insert " is a"
- (if (class-option class :abstract)
+ (if (eieio--class-option (eieio--class-v class) :abstract)
"n abstract"
"")
" class")
;; 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)
- (when methods
+ (let ((generics (eieio-all-generic-functions class)))
+ (when generics
(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"
- (or (cdr cur) "")))
- (setq counter (1+ counter))))
- (insert "\n\n")
- (setq methods (cdr methods))))))
+ (dolist (generic generics)
+ (insert "`")
+ (help-insert-xref-button (symbol-name generic) 'help-function generic)
+ (insert "'")
+ (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-class-slots (class)
"Print help description for the slots in CLASS.
Outputs to the current buffer."
- (let* ((cv (class-v class))
+ (let* ((cv (eieio--class-v class))
(docs (eieio--class-public-doc cv))
(names (eieio--class-public-a cv))
(deflt (eieio--class-public-d cv))
(defun eieio-build-class-list (class)
"Return a list of all classes that inherit from CLASS."
(if (class-p class)
- (apply #'append
- (mapcar
- (lambda (c)
- (append (list c) (eieio-build-class-list c)))
- (eieio-class-children-fast class)))
+ (cl-mapcan
+ (lambda (c)
+ (append (list c) (eieio-build-class-list c)))
+ (eieio--class-children (eieio--class-v class)))
(list class)))
(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
If INSTANTIABLE-ONLY is non nil, only allow names of classes which
are not abstract, otherwise allow all classes.
Optional argument BUILDLIST is more list to attach and is used internally."
- (let* ((cc (or class eieio-default-superclass))
- (sublst (eieio--class-children (class-v cc))))
+ (let* ((cc (or class 'eieio-default-superclass))
+ (sublst (eieio--class-children (eieio--class-v cc))))
(unless (assoc (symbol-name cc) buildlist)
(when (or (not instantiable-only) (not (class-abstract-p cc)))
+ ;; FIXME: Completion tables don't need alists, and ede/generic.el needs
+ ;; the symbols rather than their names.
(setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
- (while sublst
+ (dolist (elem sublst)
(setq buildlist (eieio-build-class-alist
- (car sublst) instantiable-only buildlist))
- (setq sublst (cdr sublst)))
+ elem instantiable-only buildlist)))
buildlist))
(defvar eieio-read-class nil
(eieio-help-class ctr))
))))
-
-;;;###autoload
-(defun eieio-help-generic (generic)
- "Describe GENERIC if it is a generic function."
- (when (and (symbolp generic) (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 (help-function-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--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 (eq 'subclass (car-safe specializer))
+ (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) tree (cn (if class (symbol-name class) nil)))
+ (let ((l nil))
(mapatoms
(lambda (symbol)
- (setq tree (get symbol 'eieio-method-obarray))
- (if tree
- (progn
- ;; A symbol might be interned for that class in one of
- ;; these three slots in the method-obarray.
- (if (or (not class)
- (fboundp (intern-soft cn (aref tree 0)))
- (fboundp (intern-soft cn (aref tree 1)))
- (fboundp (intern-soft cn (aref tree 2))))
- (setq l (cons symbol l)))))))
+ (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 a list of the specific documentation of GENERIC for CLASS.
-If there is not an explicit method for CLASS in GENERIC, or if that
-function has no documentation, then return nil."
- (let ((tree (get generic 'eieio-method-obarray))
- (cn (symbol-name class))
- before primary after)
- (if (not tree)
- nil
- ;; A symbol might be interned for that class in one of
- ;; these three slots in the method-obarray.
- (setq before (intern-soft cn (aref tree 0))
- primary (intern-soft cn (aref tree 1))
- after (intern-soft cn (aref tree 2)))
- (if (not (or (fboundp before)
- (fboundp primary)
- (fboundp after)))
- nil
- (list (if (fboundp before)
- (cons (help-function-arglist before)
- (documentation before))
- nil)
- (if (fboundp primary)
- (cons (help-function-arglist primary)
- (documentation primary))
- nil)
- (if (fboundp after)
- (cons (help-function-arglist after)
- (documentation after))
- nil))))))
-
-(defvar eieio-read-generic nil
- "History of the `eieio-read-generic' prompt.")
-
-(defun eieio-read-generic-p (fn)
- "Function used in function `eieio-read-generic'.
-This is because `generic-p' is a macro.
-Argument FN is the function to test."
- (generic-p fn))
-
-(defun eieio-read-generic (prompt &optional historyvar)
- "Read a generic function from the minibuffer with PROMPT.
-Optional argument HISTORYVAR is the variable to use as history."
- (intern (completing-read prompt obarray 'eieio-read-generic-p
- t nil (or historyvar 'eieio-read-generic))))
+ "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
;;
()
"Menu part in easymenu format used in speedbar while in `eieio' mode.")
-(defun eieio-class-speedbar (dir-or-object depth)
+(defun eieio-class-speedbar (_dir-or-object _depth)
"Create buttons in speedbar that represents the current project.
DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the
current expansion depth."
(when (eq (point-min) (point-max))
;; This function is only called once, to start the whole deal.
;; Create and expand the default object.
- (eieio-class-button eieio-default-superclass 0)
+ (eieio-class-button 'eieio-default-superclass 0)
(forward-line -1)
(speedbar-expand-line)))
(defun eieio-class-button (class depth)
"Draw a speedbar button at the current point for CLASS at DEPTH."
(eieio--check-type class-p class)
- (let ((subclasses (eieio--class-children (class-v class))))
+ (let ((subclasses (eieio--class-children (eieio--class-v class))))
(if subclasses
(speedbar-make-tag-line 'angle ?+
'eieio-sb-expand
(speedbar-with-writable
(save-excursion
(end-of-line) (forward-char 1)
- (let ((subclasses (eieio--class-children (class-v class))))
+ (let ((subclasses (eieio--class-children (eieio--class-v class))))
(while subclasses
(eieio-class-button (car subclasses) (1+ indent))
(setq subclasses (cdr subclasses)))))))
(t (error "Ooops... not sure what to do")))
(speedbar-center-buffer-smartly))
-(defun eieio-describe-class-sb (text token indent)
+(defun eieio-describe-class-sb (_text token _indent)
"Describe the class TEXT in TOKEN.
INDENT is the current indentation level."
(dframe-with-attached-buffer