X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/50c117fe86d94719807cbe08353c032779b3b910..6af5aad26411ffe21c3fe4bc5438347110910111:/lisp/emacs-lisp/eieio-opt.el diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 7f98730340..c4d6d35a13 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 @@ -60,7 +59,7 @@ Argument PREFIX is the character prefix to use. Argument CH-PREFIX is another character prefix to display." (cl-check-type this-root class) (let ((myname (symbol-name this-root)) - (chl (eieio--class-children (eieio--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 " "))) @@ -74,102 +73,11 @@ Argument CH-PREFIX is another character prefix to display." ;;; 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 (eieio--class-option (eieio--class-v class) :abstract) - "n abstract" - "") - " class") - (let ((location (find-lisp-object-file-name class 'eieio-defclass))) - (when location - (insert " in `") - (help-insert-xref-button - (help-fns-short-filename location) - 'eieio-class-def class location 'eieio-defclass) - (insert "'"))) - (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 "`") - (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 ((generics (eieio-all-generic-functions class))) - (when generics - (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) - (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-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 (eieio--class-v 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. @@ -178,7 +86,7 @@ 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 (eieio--class-v cc)))) + (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 @@ -214,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) @@ -242,11 +141,11 @@ are not abstract." (setq location (find-lisp-object-file-name ctr def))) (when location - (insert " in `") + (insert (format " in ‘")) (help-insert-xref-button (help-fns-short-filename location) - 'eieio-class-def ctr location 'eieio-defclass) - (insert "'")) + '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) @@ -256,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 ;; @@ -307,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))))) @@ -388,13 +243,13 @@ The value returned is a list of elements of the form (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) )) @@ -449,7 +304,7 @@ current expansion depth." (defun eieio-class-button (class depth) "Draw a speedbar button at the current point for CLASS at DEPTH." (cl-check-type class class) - (let ((subclasses (eieio--class-children (eieio--class-v class)))) + (let ((subclasses (eieio--class-children (cl--find-class class)))) (if subclasses (speedbar-make-tag-line 'angle ?+ 'eieio-sb-expand @@ -474,7 +329,7 @@ Argument INDENT is the depth of indentation." (speedbar-with-writable (save-excursion (end-of-line) (forward-char 1) - (let ((subclasses (eieio--class-children (eieio--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)))))))