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-symbol 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-class-slots (class)
 140   "Print help description for the slots in CLASS.
 141 Outputs to the current buffer."
 142   (let* ((cv (eieio--class-v class))
 143          (docs   (eieio--class-public-doc cv))
 144          (names  (eieio--class-public-a cv))
 145          (deflt  (eieio--class-public-d cv))
 146          (types  (eieio--class-public-type cv))
 147          (publp (eieio--class-public-printer cv))
 148          (i      0)
 149          (prot   (eieio--class-protection cv))
 150          )
 151     (insert (propertize "Instance Allocated Slots:\n\n"
 152                         'face 'bold))
 153     (while names
 154       (insert
 155        (concat
 156         (when (car prot)
 157           (propertize "Private " 'face 'bold))
 158         (propertize "Slot: " 'face 'bold)
 159         (prin1-to-string (car names))
 160         (unless (eq (aref types i) t)
 161           (concat "    type = "
 162                   (prin1-to-string (aref types i))))
 163         (unless (eq (car deflt) eieio-unbound)
 164           (concat "    default = "
 165                   (prin1-to-string (car deflt))))
 166         (when (car publp)
 167           (concat "    printer = "
 168                   (prin1-to-string (car publp))))
 169         (when (car docs)
 170           (concat "\n  " (car docs) "\n"))
 171         "\n"))
 172       (setq names (cdr names)
 173             docs (cdr docs)
 174             deflt (cdr deflt)
 175             publp (cdr publp)
 176             prot (cdr prot)
 177             i (1+ i)))
 178     (setq docs  (eieio--class-class-allocation-doc cv)
 179           names (eieio--class-class-allocation-a cv)
 180           types (eieio--class-class-allocation-type cv)
 181           i     0
 182           prot  (eieio--class-class-allocation-protection cv))
 183     (when names
 184       (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)))
 185     (while names
 186       (insert
 187        (concat
 188         (when (car prot)
 189           "Private ")
 190         "Slot: "
 191         (prin1-to-string (car names))
 192         (unless (eq (aref types i) t)
 193           (concat "    type = "
 194                   (prin1-to-string (aref types i))))
 195         (condition-case nil
 196             (let ((value (eieio-oref class (car names))))
 197               (concat "   value = "
 198                       (prin1-to-string value)))
 199           (error nil))
 200         (when (car docs)
 201           (concat "\n\n " (car docs) "\n"))
 202         "\n"))
 203       (setq names (cdr names)
 204             docs (cdr docs)
 205             prot (cdr prot)
 206             i (1+ i)))))
 207
 208 (defun eieio-build-class-alist (&optional class instantiable-only buildlist)
 209   "Return an alist of all currently active classes for completion purposes.
 210 Optional argument CLASS is the class to start with.
 211 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 212 are not abstract, otherwise allow all classes.
 213 Optional argument BUILDLIST is more list to attach and is used internally."
 214   (let* ((cc (or class 'eieio-default-superclass))
 215          (sublst (eieio--class-children (eieio--class-v cc))))
 216     (unless (assoc (symbol-name cc) buildlist)
 217       (when (or (not instantiable-only) (not (class-abstract-p cc)))
 218         ;; FIXME: Completion tables don't need alists, and ede/generic.el needs
 219         ;; the symbols rather than their names.
 220         (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
 221     (dolist (elem sublst)
 222       (setq buildlist (eieio-build-class-alist
 223                        elem instantiable-only buildlist)))
 224     buildlist))
 225
 226 (defvar eieio-read-class nil
 227   "History of the function `eieio-read-class' prompt.")
 228
 229 (defun eieio-read-class (prompt &optional histvar instantiable-only)
 230   "Return a class chosen by the user using PROMPT.
 231 Optional argument HISTVAR is a variable to use as history.
 232 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 233 are not abstract."
 234   (intern (completing-read prompt (eieio-build-class-alist nil instantiable-only)
 235                            nil t nil
 236                            (or histvar 'eieio-read-class))))
 237
 238 (defun eieio-read-subclass (prompt class &optional histvar instantiable-only)
 239   "Return a class chosen by the user using PROMPT.
 240 CLASS is the base class, and completion occurs across all subclasses.
 241 Optional argument HISTVAR is a variable to use as history.
 242 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 243 are not abstract."
 244   (intern (completing-read prompt
 245                            (eieio-build-class-alist class instantiable-only)
 246                            nil t nil
 247                            (or histvar 'eieio-read-class))))
 248
 249 ;;; METHOD COMPLETION / DOC
 250
 251 (define-button-type 'eieio-class-def
 252   :supertype 'help-function-def
 253   'help-echo (purecopy "mouse-2, RET: find class definition"))
 254
 255 (defconst eieio--defclass-regexp "(defclass[ \t\r\n]+%s[ \t\r\n]+")
 256 (with-eval-after-load 'find-func
 257   (defvar find-function-regexp-alist)
 258   (add-to-list 'find-function-regexp-alist
 259                `(eieio-defclass . eieio--defclass-regexp)))
 260
 261 ;;;###autoload
 262 (defun eieio-help-constructor (ctr)
 263   "Describe CTR if it is a class constructor."
 264   (when (class-p ctr)
 265     (erase-buffer)
 266     (let ((location (find-lisp-object-file-name ctr 'eieio-defclass))
 267           (def (symbol-function ctr)))
 268       (goto-char (point-min))
 269       (prin1 ctr)
 270       (insert (format " is an %s object constructor function"
 271                       (if (autoloadp def)
 272                           "autoloaded"
 273                         "")))
 274       (when (and (autoloadp def)
 275                  (null location))
 276         (setq location
 277               (find-lisp-object-file-name ctr def)))
 278       (when location
 279         (insert " in `")
 280         (help-insert-xref-button
 281          (help-fns-short-filename location)
 282          'eieio-class-def ctr location 'eieio-defclass)
 283         (insert "'"))
 284       (insert ".\nCreates an object of class " (symbol-name ctr) ".")
 285       (goto-char (point-max))
 286       (if (autoloadp def)
 287           (insert "\n\n[Class description not available until class definition is loaded.]\n")
 288         (save-excursion
 289           (insert (propertize "\n\nClass description:\n" 'face 'bold))
 290           (eieio-help-class ctr))
 291         ))))
 292
 293 (defun eieio--specializers-apply-to-class-p (specializers class)
 294   "Return non-nil if a method with SPECIALIZERS applies to CLASS."
 295   (let ((applies nil))
 296     (dolist (specializer specializers)
 297       (if (memq (car-safe specializer) '(subclass eieio--static))
 298           (setq specializer (nth 1 specializer)))
 299       ;; Don't include the methods that are "too generic", such as those
 300       ;; applying to `eieio-default-superclass'.
 301       (and (not (memq specializer '(t eieio-default-superclass)))
 302            (class-p specializer)
 303            (child-of-class-p class specializer)
 304            (setq applies t)))
 305     applies))
 306
 307 (defun eieio-all-generic-functions (&optional class)
 308   "Return a list of all generic functions.
 309 Optional CLASS argument returns only those functions that contain
 310 methods for CLASS."
 311   (let ((l nil))
 312     (mapatoms
 313      (lambda (symbol)
 314        (let ((generic (and (fboundp symbol) (cl--generic symbol))))
 315          (and generic
 316               (catch 'found
 317                 (if (null class) (throw 'found t))
 318                 (dolist (method (cl--generic-method-table generic))
 319                   (if (eieio--specializers-apply-to-class-p
 320                        (cl--generic-method-specializers method) class)
 321                       (throw 'found t))))
 322               (push symbol l)))))
 323     l))
 324
 325 (defun eieio-method-documentation (generic class)
 326   "Return info for all methods of GENERIC applicable to CLASS.
 327 The value returned is a list of elements of the form
 328 \(QUALIFIERS ARGS DOC)."
 329   (let ((generic (cl--generic generic))
 330         (docs ()))
 331     (when generic
 332       (dolist (method (cl--generic-method-table generic))
 333         (when (eieio--specializers-apply-to-class-p
 334                (cl--generic-method-specializers method) class)
 335           (push (cl--generic-method-info method) docs))))
 336     docs))
 337
 338 ;;; METHOD STATS
 339 ;;
 340 ;; Dump out statistics about all the active methods in a session.
 341 (defun eieio-display-method-list ()
 342   "Display a list of all the methods and what features are used."
 343   (interactive)
 344   (let* ((meth1 (eieio-all-generic-functions))
 345          (meth (sort meth1 (lambda (a b)
 346                              (string< (symbol-name a)
 347                                       (symbol-name b)))))
 348          (buff (get-buffer-create "*EIEIO Method List*"))
 349          (methidx 0)
 350          (standard-output buff)
 351          (slots '(method-static
 352                   method-before
 353                   method-primary
 354                   method-after
 355                   method-generic-before
 356                   method-generic-primary
 357                   method-generic-after))
 358          (slotn '("static"
 359                   "before"
 360                   "primary"
 361                   "after"
 362                   "G bef"
 363                   "G prim"
 364                   "G aft"))
 365          (idxarray (make-vector (length slots) 0))
 366          (primaryonly 0)
 367          (oneprimary 0)
 368          )
 369     (switch-to-buffer-other-window buff)
 370     (erase-buffer)
 371     (dolist (S slotn)
 372       (princ S)
 373       (princ "\t")
 374       )
 375     (princ "Method Name")
 376     (terpri)
 377     (princ "--------------------------------------------------------------------")
 378     (terpri)
 379     (dolist (M meth)
 380       (let ((mtree (get M 'eieio-method-tree))
 381             (P nil) (numP)
 382             (!P nil))
 383         (dolist (S slots)
 384           (let ((num (length (aref mtree (symbol-value S)))))
 385             (aset idxarray (symbol-value S)
 386                   (+ num (aref idxarray (symbol-value S))))
 387             (prin1 num)
 388             (princ "\t")
 389             (when (< 0 num)
 390               (if (eq S 'method-primary)
 391                   (setq P t numP num)
 392                 (setq !P t)))
 393             ))
 394         ;; Is this a primary-only impl method?
 395         (when (and P (not !P))
 396           (setq primaryonly (1+ primaryonly))
 397           (when (= numP 1)
 398             (setq oneprimary (1+ oneprimary))
 399             (princ "*"))
 400           (princ "* ")
 401           )
 402         (prin1 M)
 403         (terpri)
 404         (setq methidx (1+ methidx))
 405         )
 406       )
 407     (princ "--------------------------------------------------------------------")
 408     (terpri)
 409     (dolist (S slots)
 410       (prin1 (aref idxarray (symbol-value S)))
 411       (princ "\t")
 412       )
 413     (prin1 methidx)
 414     (princ " Total symbols")
 415     (terpri)
 416     (dolist (S slotn)
 417       (princ S)
 418       (princ "\t")
 419       )
 420     (terpri)
 421     (terpri)
 422     (princ "Methods Primary Only: ")
 423     (prin1 primaryonly)
 424     (princ "\t")
 425     (princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100)))
 426     (princ "% of total methods")
 427     (terpri)
 428     (princ "Only One Primary Impl: ")
 429     (prin1 oneprimary)
 430     (princ "\t")
 431     (princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100)))
 432     (princ "% of total primary methods")
 433     (terpri)
 434     ))
 435
 436 ;;; SPEEDBAR SUPPORT
 437 ;;
 438
 439 (defvar eieio-class-speedbar-key-map nil
 440   "Keymap used when working with a project in speedbar.")
 441
 442 (defun eieio-class-speedbar-make-map ()
 443   "Make a keymap for EIEIO under speedbar."
 444   (setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap))
 445
 446   ;; General viewing stuff
 447   (define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line)
 448   (define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line)
 449   (define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line)
 450   )
 451
 452 (if eieio-class-speedbar-key-map
 453     nil
 454   (if (not (featurep 'speedbar))
 455       (add-hook 'speedbar-load-hook (lambda ()
 456                                       (eieio-class-speedbar-make-map)
 457                                       (speedbar-add-expansion-list
 458                                        '("EIEIO"
 459                                          eieio-class-speedbar-menu
 460                                          eieio-class-speedbar-key-map
 461                                          eieio-class-speedbar))))
 462     (eieio-class-speedbar-make-map)
 463     (speedbar-add-expansion-list '("EIEIO"
 464                                    eieio-class-speedbar-menu
 465                                    eieio-class-speedbar-key-map
 466                                    eieio-class-speedbar))))
 467
 468 (defvar eieio-class-speedbar-menu
 469   ()
 470   "Menu part in easymenu format used in speedbar while in `eieio' mode.")
 471
 472 (defun eieio-class-speedbar (_dir-or-object _depth)
 473   "Create buttons in speedbar that represents the current project.
 474 DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the
 475 current expansion depth."
 476   (when (eq (point-min) (point-max))
 477     ;; This function is only called once, to start the whole deal.
 478     ;; Create and expand the default object.
 479     (eieio-class-button 'eieio-default-superclass 0)
 480     (forward-line -1)
 481     (speedbar-expand-line)))
 482
 483 (defun eieio-class-button (class depth)
 484   "Draw a speedbar button at the current point for CLASS at DEPTH."
 485   (cl-check-type class class)
 486   (let ((subclasses (eieio--class-children (eieio--class-v class))))
 487     (if subclasses
 488         (speedbar-make-tag-line 'angle ?+
 489                                 'eieio-sb-expand
 490                                 class
 491                                 (symbol-name class)
 492                                 'eieio-describe-class-sb
 493                                 class
 494                                 'speedbar-directory-face
 495                                 depth)
 496       (speedbar-make-tag-line 'angle ?  nil nil
 497                               (symbol-name class)
 498                               'eieio-describe-class-sb
 499                               class
 500                               'speedbar-directory-face
 501                               depth))))
 502
 503 (defun eieio-sb-expand (text class indent)
 504   "For button TEXT, expand CLASS at the current location.
 505 Argument INDENT is the depth of indentation."
 506   (cond ((string-match "+" text)        ;we have to expand this file
 507          (speedbar-change-expand-button-char ?-)
 508          (speedbar-with-writable
 509            (save-excursion
 510              (end-of-line) (forward-char 1)
 511              (let ((subclasses (eieio--class-children (eieio--class-v class))))
 512                (while subclasses
 513                  (eieio-class-button (car subclasses) (1+ indent))
 514                  (setq subclasses (cdr subclasses)))))))
 515         ((string-match "-" text)        ;we have to contract this node
 516          (speedbar-change-expand-button-char ?+)
 517          (speedbar-delete-subblock indent))
 518         (t (error "Ooops...  not sure what to do")))
 519   (speedbar-center-buffer-smartly))
 520
 521 (defun eieio-describe-class-sb (_text token _indent)
 522   "Describe the class TEXT in TOKEN.
 523 INDENT is the current indentation level."
 524   (dframe-with-attached-buffer
 525    (describe-function token))
 526   (dframe-maybee-jump-to-attached-frame))
 527
 528 (provide 'eieio-opt)
 529
 530 ;; Local variables:
 531 ;; generated-autoload-file: "eieio.el"
 532 ;; End:
 533
 534 ;;; eieio-opt.el ends here