code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/eieio-opt.el

   1 ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
   2
   3 ;; Copyright (C) 1996, 1998-2003, 2005, 2008-2015 Free Software
   4 ;; Foundation, Inc.
   5
   6 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   7 ;; Keywords: OO, lisp
   8 ;; Package: eieio
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26 ;;
  27 ;;   This contains support functions to eieio.  These functions contain
  28 ;; some small class browser and class printing functions.
  29 ;;
  30
  31 (require 'eieio)
  32 (require 'find-func)
  33 (require 'speedbar)
  34 (require 'help-mode)
  35
  36 ;;; Code:
  37 ;;;###autoload
  38 (defun eieio-browse (&optional root-class)
  39   "Create an object browser window to show all objects.
  40 If optional ROOT-CLASS, then start with that, otherwise start with
  41 variable `eieio-default-superclass'."
  42   (interactive (if current-prefix-arg
  43                    (list (read (completing-read "Class: "
  44                                                 (eieio-build-class-alist)
  45                                                 nil t)))
  46                  nil))
  47   (if (not root-class) (setq root-class 'eieio-default-superclass))
  48   (cl-check-type root-class class)
  49   (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t)
  50   (with-current-buffer (get-buffer "*EIEIO OBJECT BROWSE*")
  51     (erase-buffer)
  52     (goto-char 0)
  53     (eieio-browse-tree root-class "" "")
  54     ))
  55
  56 (defun eieio-browse-tree (this-root prefix ch-prefix)
  57   "Recursively draw the children of the given class on the screen.
  58 Argument THIS-ROOT is the local root of the tree.
  59 Argument PREFIX is the character prefix to use.
  60 Argument CH-PREFIX is another character prefix to display."
  61   (cl-check-type this-root class)
  62   (let ((myname (symbol-name this-root))
  63         (chl (eieio--class-children (eieio--class-v this-root)))
  64         (fprefix (concat ch-prefix "  +--"))
  65         (mprefix (concat ch-prefix "  |  "))
  66         (lprefix (concat ch-prefix "     ")))
  67     (insert prefix myname "\n")
  68     (while (cdr chl)
  69       (eieio-browse-tree (car chl) fprefix mprefix)
  70       (setq chl (cdr chl)))
  71     (if chl
  72         (eieio-browse-tree (car chl) fprefix lprefix))
  73     ))
  74
  75 ;;; CLASS COMPLETION / DOCUMENTATION
  76
  77 ;;;###autoload
  78 (defun eieio-help-class (class)
  79   "Print help description for CLASS.
  80 If CLASS is actually an object, then also display current values of that object."
  81   ;; Header line
  82   (prin1 class)
  83   (insert " is a"
  84           (if (eieio--class-option (eieio--class-v class) :abstract)
  85               "n abstract"
  86             "")
  87           " class")
  88   (let ((location (find-lisp-object-file-name class 'eieio-defclass)))
  89     (when location
  90       (insert " in `")
  91       (help-insert-xref-button
  92        (help-fns-short-filename location)
  93        'eieio-class-def class location 'eieio-defclass)
  94       (insert "'")))
  95   (insert ".\n")
  96   ;; Parents
  97   (let ((pl (eieio-class-parents class))
  98         cur)
  99     (when pl
 100       (insert " Inherits from ")
 101       (while (setq cur (pop pl))
 102         (setq cur (eieio--class-name cur))
 103         (insert "`")
 104         (help-insert-xref-button (symbol-name cur)
 105                                  'help-function cur)
 106         (insert (if pl "', " "'")))
 107       (insert ".\n")))
 108   ;; Children
 109   (let ((ch (eieio-class-children class))
 110         cur)
 111     (when ch
 112       (insert " Children ")
 113       (while (setq cur (pop ch))
 114         (insert "`")
 115         (help-insert-xref-button (symbol-name cur)
 116                                  'help-function cur)
 117         (insert (if ch "', " "'")))
 118       (insert ".\n")))
 119   ;; System documentation
 120   (let ((doc (documentation-property class 'variable-documentation)))
 121     (when doc
 122       (insert "\n" doc "\n\n")))
 123   ;; Describe all the slots in this class.
 124   (eieio-help-class-slots class)
 125   ;; Describe all the methods specific to this class.
 126   (let ((generics (eieio-all-generic-functions class)))
 127     (when generics
 128       (insert (propertize "Specialized Methods:\n\n" 'face 'bold))
 129       (dolist (generic generics)
 130         (insert "`")
 131         (help-insert-xref-button (symbol-name generic) 'help-function generic)
 132         (insert "'")
 133         (pcase-dolist (`(,qualifiers ,args ,doc)
 134                        (eieio-method-documentation generic class))
 135           (insert (format " %s%S\n" qualifiers args)
 136                   (or doc "")))
 137         (insert "\n\n")))))
 138
 139 (defun eieio--help-print-slot (slot)
 140   (insert
 141    (concat
 142     (propertize "Slot: " 'face 'bold)
 143     (prin1-to-string (cl--slot-descriptor-name slot))
 144     (unless (eq (cl--slot-descriptor-type slot) t)
 145       (concat "    type = "
 146               (prin1-to-string (cl--slot-descriptor-type slot))))
 147     (unless (eq (cl--slot-descriptor-initform slot) eieio-unbound)
 148       (concat "    default = "
 149               (prin1-to-string (cl--slot-descriptor-initform slot))))
 150     (when (alist-get :printer (cl--slot-descriptor-props slot))
 151       (concat "    printer = "
 152               (prin1-to-string
 153                (alist-get :printer (cl--slot-descriptor-props slot)))))
 154     (when (alist-get :documentation (cl--slot-descriptor-props slot))
 155       (concat "\n  " (alist-get :documentation (cl--slot-descriptor-props slot))
 156               "\n")))
 157    "\n"))
 158
 159 (defun eieio-help-class-slots (class)
 160   "Print help description for the slots in CLASS.
 161 Outputs to the current buffer."
 162   (let* ((cv (eieio--class-v class))
 163          (slots (eieio--class-slots cv))
 164          (cslots (eieio--class-class-slots cv)))
 165     (insert (propertize "Instance Allocated Slots:\n\n"
 166                         'face 'bold))
 167     (dotimes (i (length slots))
 168       (eieio--help-print-slot (aref slots i)))
 169     (when (> (length cslots) 0)
 170       (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)))
 171     (dotimes (i (length cslots))
 172       (eieio--help-print-slot (aref cslots i)))))
 173
 174 (defun eieio-build-class-alist (&optional class instantiable-only buildlist)
 175   "Return an alist of all currently active classes for completion purposes.
 176 Optional argument CLASS is the class to start with.
 177 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 178 are not abstract, otherwise allow all classes.
 179 Optional argument BUILDLIST is more list to attach and is used internally."
 180   (let* ((cc (or class 'eieio-default-superclass))
 181          (sublst (eieio--class-children (eieio--class-v cc))))
 182     (unless (assoc (symbol-name cc) buildlist)
 183       (when (or (not instantiable-only) (not (class-abstract-p cc)))
 184         ;; FIXME: Completion tables don't need alists, and ede/generic.el needs
 185         ;; the symbols rather than their names.
 186         (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
 187     (dolist (elem sublst)
 188       (setq buildlist (eieio-build-class-alist
 189                        elem instantiable-only buildlist)))
 190     buildlist))
 191
 192 (defvar eieio-read-class nil
 193   "History of the function `eieio-read-class' prompt.")
 194
 195 (defun eieio-read-class (prompt &optional histvar instantiable-only)
 196   "Return a class chosen by the user using PROMPT.
 197 Optional argument HISTVAR is a variable to use as history.
 198 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 199 are not abstract."
 200   (intern (completing-read prompt (eieio-build-class-alist nil instantiable-only)
 201                            nil t nil
 202                            (or histvar 'eieio-read-class))))
 203
 204 (defun eieio-read-subclass (prompt class &optional histvar instantiable-only)
 205   "Return a class chosen by the user using PROMPT.
 206 CLASS is the base class, and completion occurs across all subclasses.
 207 Optional argument HISTVAR is a variable to use as history.
 208 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 209 are not abstract."
 210   (intern (completing-read prompt
 211                            (eieio-build-class-alist class instantiable-only)
 212                            nil t nil
 213                            (or histvar 'eieio-read-class))))
 214
 215 ;;; METHOD COMPLETION / DOC
 216
 217 (define-button-type 'eieio-class-def
 218   :supertype 'help-function-def
 219   'help-echo (purecopy "mouse-2, RET: find class definition"))
 220
 221 (defconst eieio--defclass-regexp "(defclass[ \t\r\n]+%s[ \t\r\n]+")
 222 (with-eval-after-load 'find-func
 223   (defvar find-function-regexp-alist)
 224   (add-to-list 'find-function-regexp-alist
 225                `(eieio-defclass . eieio--defclass-regexp)))
 226
 227 ;;;###autoload
 228 (defun eieio-help-constructor (ctr)
 229   "Describe CTR if it is a class constructor."
 230   (when (class-p ctr)
 231     (erase-buffer)
 232     (let ((location (find-lisp-object-file-name ctr 'eieio-defclass))
 233           (def (symbol-function ctr)))
 234       (goto-char (point-min))
 235       (prin1 ctr)
 236       (insert (format " is an %s object constructor function"
 237                       (if (autoloadp def)
 238                           "autoloaded"
 239                         "")))
 240       (when (and (autoloadp def)
 241                  (null location))
 242         (setq location
 243               (find-lisp-object-file-name ctr def)))
 244       (when location
 245         (insert " in `")
 246         (help-insert-xref-button
 247          (help-fns-short-filename location)
 248          'eieio-class-def ctr location 'eieio-defclass)
 249         (insert "'"))
 250       (insert ".\nCreates an object of class " (symbol-name ctr) ".")
 251       (goto-char (point-max))
 252       (if (autoloadp def)
 253           (insert "\n\n[Class description not available until class definition is loaded.]\n")
 254         (save-excursion
 255           (insert (propertize "\n\nClass description:\n" 'face 'bold))
 256           (eieio-help-class ctr))
 257         ))))
 258
 259 (defun eieio--specializers-apply-to-class-p (specializers class)
 260   "Return non-nil if a method with SPECIALIZERS applies to CLASS."
 261   (let ((applies nil))
 262     (dolist (specializer specializers)
 263       (if (memq (car-safe specializer) '(subclass eieio--static))
 264           (setq specializer (nth 1 specializer)))
 265       ;; Don't include the methods that are "too generic", such as those
 266       ;; applying to `eieio-default-superclass'.
 267       (and (not (memq specializer '(t eieio-default-superclass)))
 268            (class-p specializer)
 269            (child-of-class-p class specializer)
 270            (setq applies t)))
 271     applies))
 272
 273 (defun eieio-all-generic-functions (&optional class)
 274   "Return a list of all generic functions.
 275 Optional CLASS argument returns only those functions that contain
 276 methods for CLASS."
 277   (let ((l nil))
 278     (mapatoms
 279      (lambda (symbol)
 280        (let ((generic (and (fboundp symbol) (cl--generic symbol))))
 281          (and generic
 282               (catch 'found
 283                 (if (null class) (throw 'found t))
 284                 (dolist (method (cl--generic-method-table generic))
 285                   (if (eieio--specializers-apply-to-class-p
 286                        (cl--generic-method-specializers method) class)
 287                       (throw 'found t))))
 288               (push symbol l)))))
 289     l))
 290
 291 (defun eieio-method-documentation (generic class)
 292   "Return info for all methods of GENERIC applicable to CLASS.
 293 The value returned is a list of elements of the form
 294 \(QUALIFIERS ARGS DOC)."
 295   (let ((generic (cl--generic generic))
 296         (docs ()))
 297     (when generic
 298       (dolist (method (cl--generic-method-table generic))
 299         (when (eieio--specializers-apply-to-class-p
 300                (cl--generic-method-specializers method) class)
 301           (push (cl--generic-method-info method) docs))))
 302     docs))
 303
 304 ;;; METHOD STATS
 305 ;;
 306 ;; Dump out statistics about all the active methods in a session.
 307 (defun eieio-display-method-list ()
 308   "Display a list of all the methods and what features are used."
 309   (interactive)
 310   (let* ((meth1 (eieio-all-generic-functions))
 311          (meth (sort meth1 (lambda (a b)
 312                              (string< (symbol-name a)
 313                                       (symbol-name b)))))
 314          (buff (get-buffer-create "*EIEIO Method List*"))
 315          (methidx 0)
 316          (standard-output buff)
 317          (slots '(method-static
 318                   method-before
 319                   method-primary
 320                   method-after
 321                   method-generic-before
 322                   method-generic-primary
 323                   method-generic-after))
 324          (slotn '("static"
 325                   "before"
 326                   "primary"
 327                   "after"
 328                   "G bef"
 329                   "G prim"
 330                   "G aft"))
 331          (idxarray (make-vector (length slots) 0))
 332          (primaryonly 0)
 333          (oneprimary 0)
 334          )
 335     (switch-to-buffer-other-window buff)
 336     (erase-buffer)
 337     (dolist (S slotn)
 338       (princ S)
 339       (princ "\t")
 340       )
 341     (princ "Method Name")
 342     (terpri)
 343     (princ "--------------------------------------------------------------------")
 344     (terpri)
 345     (dolist (M meth)
 346       (let ((mtree (get M 'eieio-method-tree))
 347             (P nil) (numP)
 348             (!P nil))
 349         (dolist (S slots)
 350           (let ((num (length (aref mtree (symbol-value S)))))
 351             (aset idxarray (symbol-value S)
 352                   (+ num (aref idxarray (symbol-value S))))
 353             (prin1 num)
 354             (princ "\t")
 355             (when (< 0 num)
 356               (if (eq S 'method-primary)
 357                   (setq P t numP num)
 358                 (setq !P t)))
 359             ))
 360         ;; Is this a primary-only impl method?
 361         (when (and P (not !P))
 362           (setq primaryonly (1+ primaryonly))
 363           (when (= numP 1)
 364             (setq oneprimary (1+ oneprimary))
 365             (princ "*"))
 366           (princ "* ")
 367           )
 368         (prin1 M)
 369         (terpri)
 370         (setq methidx (1+ methidx))
 371         )
 372       )
 373     (princ "--------------------------------------------------------------------")
 374     (terpri)
 375     (dolist (S slots)
 376       (prin1 (aref idxarray (symbol-value S)))
 377       (princ "\t")
 378       )
 379     (prin1 methidx)
 380     (princ " Total symbols")
 381     (terpri)
 382     (dolist (S slotn)
 383       (princ S)
 384       (princ "\t")
 385       )
 386     (terpri)
 387     (terpri)
 388     (princ "Methods Primary Only: ")
 389     (prin1 primaryonly)
 390     (princ "\t")
 391     (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100)))
 392     (princ "% of total methods")
 393     (terpri)
 394     (princ "Only One Primary Impl: ")
 395     (prin1 oneprimary)
 396     (princ "\t")
 397     (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100)))
 398     (princ "% of total primary methods")
 399     (terpri)
 400     ))
 401
 402 ;;; SPEEDBAR SUPPORT
 403 ;;
 404
 405 (defvar eieio-class-speedbar-key-map nil
 406   "Keymap used when working with a project in speedbar.")
 407
 408 (defun eieio-class-speedbar-make-map ()
 409   "Make a keymap for EIEIO under speedbar."
 410   (setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap))
 411
 412   ;; General viewing stuff
 413   (define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line)
 414   (define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line)
 415   (define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line)
 416   )
 417
 418 (if eieio-class-speedbar-key-map
 419     nil
 420   (if (not (featurep 'speedbar))
 421       (add-hook 'speedbar-load-hook (lambda ()
 422                                       (eieio-class-speedbar-make-map)
 423                                       (speedbar-add-expansion-list
 424                                        '("EIEIO"
 425                                          eieio-class-speedbar-menu
 426                                          eieio-class-speedbar-key-map
 427                                          eieio-class-speedbar))))
 428     (eieio-class-speedbar-make-map)
 429     (speedbar-add-expansion-list '("EIEIO"
 430                                    eieio-class-speedbar-menu
 431                                    eieio-class-speedbar-key-map
 432                                    eieio-class-speedbar))))
 433
 434 (defvar eieio-class-speedbar-menu
 435   ()
 436   "Menu part in easymenu format used in speedbar while in `eieio' mode.")
 437
 438 (defun eieio-class-speedbar (_dir-or-object _depth)
 439   "Create buttons in speedbar that represents the current project.
 440 DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the
 441 current expansion depth."
 442   (when (eq (point-min) (point-max))
 443     ;; This function is only called once, to start the whole deal.
 444     ;; Create and expand the default object.
 445     (eieio-class-button 'eieio-default-superclass 0)
 446     (forward-line -1)
 447     (speedbar-expand-line)))
 448
 449 (defun eieio-class-button (class depth)
 450   "Draw a speedbar button at the current point for CLASS at DEPTH."
 451   (cl-check-type class class)
 452   (let ((subclasses (eieio--class-children (eieio--class-v class))))
 453     (if subclasses
 454         (speedbar-make-tag-line 'angle ?+
 455                                 'eieio-sb-expand
 456                                 class
 457                                 (symbol-name class)
 458                                 'eieio-describe-class-sb
 459                                 class
 460                                 'speedbar-directory-face
 461                                 depth)
 462       (speedbar-make-tag-line 'angle ?  nil nil
 463                               (symbol-name class)
 464                               'eieio-describe-class-sb
 465                               class
 466                               'speedbar-directory-face
 467                               depth))))
 468
 469 (defun eieio-sb-expand (text class indent)
 470   "For button TEXT, expand CLASS at the current location.
 471 Argument INDENT is the depth of indentation."
 472   (cond ((string-match "+" text)        ;we have to expand this file
 473          (speedbar-change-expand-button-char ?-)
 474          (speedbar-with-writable
 475            (save-excursion
 476              (end-of-line) (forward-char 1)
 477              (let ((subclasses (eieio--class-children (eieio--class-v class))))
 478                (while subclasses
 479                  (eieio-class-button (car subclasses) (1+ indent))
 480                  (setq subclasses (cdr subclasses)))))))
 481         ((string-match "-" text)        ;we have to contract this node
 482          (speedbar-change-expand-button-char ?+)
 483          (speedbar-delete-subblock indent))
 484         (t (error "Ooops...  not sure what to do")))
 485   (speedbar-center-buffer-smartly))
 486
 487 (defun eieio-describe-class-sb (_text token _indent)
 488   "Describe the class TEXT in TOKEN.
 489 INDENT is the current indentation level."
 490   (dframe-with-attached-buffer
 491    (describe-function token))
 492   (dframe-maybee-jump-to-attached-frame))
 493
 494 (provide 'eieio-opt)
 495
 496 ;; Local variables:
 497 ;; generated-autoload-file: "eieio.el"
 498 ;; End:
 499
 500 ;;; eieio-opt.el ends here