(require 'eieio)
(require 'find-func)
(require 'speedbar)
-(require 'help-mode)
;;; Code:
;;;###autoload
nil t)))
nil))
(if (not root-class) (setq root-class 'eieio-default-superclass))
- (eieio--check-type class-p root-class)
+ (cl-check-type root-class class)
(display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t)
(with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*")
(erase-buffer)
Argument THIS-ROOT is the local root of the tree.
Argument PREFIX is the character prefix to use.
Argument CH-PREFIX is another character prefix to display."
- (eieio--check-type class-p this-root)
+ (cl-check-type this-root class)
(let ((myname (symbol-name this-root))
- (chl (eieio--class-children (class-v this-root)))
+ (chl (eieio--class-children (cl--find-class this-root)))
(fprefix (concat ch-prefix " +--"))
(mprefix (concat ch-prefix " | "))
(lprefix (concat ch-prefix " ")))
;;; CLASS COMPLETION / DOCUMENTATION
+;; Called via help-fns-describe-function-functions.
+(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 (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)
- (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"
- (or (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))
- (deflt (eieio--class-public-d cv))
- (types (eieio--class-public-type cv))
- (publp (eieio--class-public-printer cv))
- (i 0)
- (prot (eieio--class-protection cv))
- )
- (insert (propertize "Instance Allocated Slots:\n\n"
- 'face 'bold))
- (while names
- (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)
- publp (cdr publp)
- prot (cdr prot)
- i (1+ i)))
- (setq docs (eieio--class-class-allocation-doc cv)
- names (eieio--class-class-allocation-a cv)
- types (eieio--class-class-allocation-type cv)
- i 0
- prot (eieio--class-class-allocation-protection cv))
- (when names
- (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)))
- (while names
- (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)
- (concat "\n\n " (car docs) "\n"))
- "\n"))
- (setq names (cdr names)
- docs (cdr docs)
- prot (cdr prot)
- i (1+ i)))))
-
-(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)))
- (list class)))
+(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.
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 (cl--find-class 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
;;; METHOD COMPLETION / DOC
-(define-button-type 'eieio-method-def
- :supertype 'help-xref
- 'help-function (lambda (class method file)
- (eieio-help-find-method-definition class method file))
- 'help-echo (purecopy "mouse-2, RET: find method's definition"))
-
-(define-button-type 'eieio-class-def
- :supertype 'help-xref
- 'help-function (lambda (class file)
- (eieio-help-find-class-definition class file))
- 'help-echo (purecopy "mouse-2, RET: find class definition"))
;;;###autoload
(defun eieio-help-constructor (ctr)
"Describe CTR if it is a class constructor."
(when (class-p ctr)
(erase-buffer)
- (let ((location (get ctr 'class-location))
+ (let ((location (find-lisp-object-file-name ctr 'define-type))
(def (symbol-function ctr)))
(goto-char (point-min))
(prin1 ctr)
(setq location
(find-lisp-object-file-name ctr def)))
(when location
- (insert " in `")
+ (insert (format " in ‘"))
(help-insert-xref-button
- (file-name-nondirectory location)
- 'eieio-class-def ctr location)
- (insert "'"))
+ (help-fns-short-filename location)
+ 'cl-type-definition ctr location 'define-type)
+ (insert (format "’")))
(insert ".\nCreates an object of class " (symbol-name ctr) ".")
(goto-char (point-max))
(if (autoloadp def)
))))
-;;;###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 (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."
- (if (symbolp func) (setq func (symbol-function func)))
- (if (byte-code-function-p func)
- (eieio-compiled-function-arglist func)
- (car (cdr func))))
-
-(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)))
- (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)))))))
- 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 (eieio-lambda-arglist before)
- (documentation before))
- nil)
- (if (fboundp primary)
- (cons (eieio-lambda-arglist primary)
- (documentation primary))
- nil)
- (if (fboundp after)
- (cons (eieio-lambda-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))))
-
;;; METHOD STATS
;;
;; Dump out statistics about all the active methods in a session.
(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)))))
(princ "Methods Primary Only: ")
(prin1 primaryonly)
(princ "\t")
- (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100)))
+ (princ (format "%d" (floor (* 100.0 primaryonly) methidx)))
(princ "% of total methods")
(terpri)
(princ "Only One Primary Impl: ")
(prin1 oneprimary)
(princ "\t")
- (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100)))
+ (princ (format "%d" (floor (* 100.0 oneprimary) primaryonly)))
(princ "% of total primary methods")
(terpri)
))
-;;; HELP AUGMENTATION
-;;
-(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))
- (with-current-buffer buf
- (goto-char (point-min))
- (when
- (re-search-forward
- ;; Regexp for searching methods.
- (concat "(defmethod[ \t\r\n]+" method
- "\\([ \t\r\n]+:[a-zA-Z]+\\)?"
- "[ \t\r\n]+(\\s-*(\\(\\sw\\|\\s_\\)+\\s-+"
- class
- "\\s-*)")
- nil t)
- (setq location (match-beginning 0))))
- (if (null location)
- (message "Unable to find location in file")
- (pop-to-buffer buf)
- (goto-char location)
- (recenter)
- (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)
- (error "Cannot find library %s" file))
- (setq buf (find-file-noselect filename))
- (with-current-buffer buf
- (goto-char (point-min))
- (when
- (re-search-forward
- ;; Regexp for searching a class.
- (concat "(defclass[ \t\r\n]+" class "[ \t\r\n]+")
- nil t)
- (setq location (match-beginning 0))))
- (if (null location)
- (message "Unable to find location in file")
- (pop-to-buffer buf)
- (goto-char location)
- (recenter)
- (beginning-of-line))))
-
;;; SPEEDBAR SUPPORT
;;
()
"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))))
+ (cl-check-type class class)
+ (let ((subclasses (eieio--class-children (cl--find-class 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 (cl--find-class 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