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