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