cgit.sxemacs.org Git - packages/blob - xemacs-packages/eieio/eieio-opt.el

   1 ;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
   2
   3 ;;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005 Eric M. Ludlam
   4 ;;
   5 ;; Author: <zappo@gnu.org>
   6 ;; RCS: $Id: eieio-opt.el,v 1.5 2007-11-26 15:01:05 michaels Exp $
   7 ;; Keywords: OO, lisp
   8 ;;
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13 ;;
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301, USA.
  23 ;;
  24 ;; Please send bug reports, etc. to zappo@gnu.org
  25
  26 ;;; Commentary:
  27 ;;
  28 ;;   This contains support functions to eieio.  These functions contain
  29 ;; some small class browser and class printing functions.
  30 ;;
  31
  32 (require 'eieio)
  33
  34 ;;; Code:
  35 ;;;###autoload
  36 (defun eieio-browse (&optional root-class)
  37   "Create an object browser window to show all objects.
  38 If optional ROOT-CLASS, then start with that, otherwise start with
  39 variable `eieio-default-superclass'."
  40   (interactive (if current-prefix-arg
  41                    (list (read (completing-read "Class: "
  42                                                 (eieio-build-class-alist)
  43                                                 nil t)))
  44                  nil))
  45   (if (not root-class) (setq root-class 'eieio-default-superclass))
  46   (if (not (class-p root-class)) (signal 'wrong-type-argument (list 'class-p root-class)))
  47   (display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t)
  48   (save-excursion
  49     (set-buffer (get-buffer "*EIEIO OBJECT BROWSE*"))
  50     (erase-buffer)
  51     (goto-char 0)
  52     (eieio-browse-tree root-class "" "")
  53     ))
  54
  55 (defun eieio-browse-tree (this-root prefix ch-prefix)
  56   "Recursively, draws the children of the given class on the screen.
  57 Argument THIS-ROOT is the local root of the tree.
  58 Argument PREFIX is the character prefix to use.
  59 Argument CH-PREFIX is another character prefix to display."
  60   (if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list 'class-p this-root)))
  61   (let ((myname (symbol-name this-root))
  62         (chl (aref (class-v this-root) class-children))
  63         (fprefix (concat ch-prefix "  +--"))
  64         (mprefix (concat ch-prefix "  |  "))
  65         (lprefix (concat ch-prefix "     ")))
  66     (insert prefix myname "\n")
  67     (while (cdr chl)
  68       (eieio-browse-tree (car chl) fprefix mprefix)
  69       (setq chl (cdr chl)))
  70     (if chl
  71         (eieio-browse-tree (car chl) fprefix lprefix))
  72     ))
  73
  74 ;;;###autoload
  75 (defalias 'describe-class 'eieio-describe-class)
  76 ;;;###autoload
  77 (defun eieio-describe-class (class)
  78   "Describe a CLASS defined by a string or symbol.
  79 If CLASS is actually an object, then also display current values of that obect."
  80   (interactive (list (eieio-read-class "Class: ")))
  81   (with-output-to-temp-buffer "*Help*"
  82     (if (class-option class :abstract)
  83         (princ "Abstract "))
  84     (princ "Class ")
  85     (prin1 class)
  86     (terpri)
  87     ;; Inheritence tree information
  88     (let ((pl (class-parents class)))
  89       (when pl
  90         (princ " Inherits from ")
  91         (while pl
  92           (princ "`") (prin1 (car pl)) (princ "'")
  93           (setq pl (cdr pl))
  94           (if pl (princ ", ")))
  95         (terpri)))
  96     (let ((ch (class-children class)))
  97       (when ch
  98         (princ " Children ")
  99         (while ch
 100           (princ "`") (prin1 (car ch)) (princ "'")
 101           (setq ch (cdr ch))
 102           (if ch (princ ", ")))
 103         (terpri)))
 104     (terpri)
 105     ;; System documentation
 106     (let ((doc (documentation-property class 'variable-documentation)))
 107       (when doc
 108         (princ "Documentation:")
 109         (terpri)
 110         (princ doc)
 111         (terpri)
 112         (terpri)))
 113     ;; Describe all the slots in this class
 114     (eieio-describe-class-slots class)
 115     ;; Describe all the methods specific to this class.
 116     (let ((methods (eieio-all-generic-functions class))
 117           (doc nil))
 118       (if (not methods) nil
 119         (princ "Specialized Methods:")
 120         (terpri)
 121         (terpri)
 122         (while methods
 123           (setq doc (eieio-method-documentation (car methods) class))
 124           (princ "`")
 125           (prin1 (car methods))
 126           (princ "'")
 127           (if (not doc)
 128               (princ "  Undocumented")
 129             (if (car doc)
 130                 (progn
 131                   (princ "  :STATIC ")
 132                   (prin1 (car (car doc)))
 133                   (terpri)
 134                   (princ (cdr (car doc)))))
 135             (setq doc (cdr doc))
 136             (if (car doc)
 137                 (progn
 138                   (princ "  :BEFORE ")
 139                   (prin1 (car (car doc)))
 140                   (terpri)
 141                   (princ (cdr (car doc)))))
 142             (setq doc (cdr doc))
 143             (if (car doc)
 144                 (progn
 145                   (princ "  :PRIMARY ")
 146                   (prin1 (car (car doc)))
 147                   (terpri)
 148                   (princ (cdr (car doc)))))
 149             (setq doc (cdr doc))
 150             (if (car doc)
 151                 (progn
 152                   (princ "  :AFTER ")
 153                   (prin1 (car (car doc)))
 154                   (terpri)
 155                   (princ (cdr (car doc)))))
 156             (terpri)
 157             (terpri))
 158           (setq methods (cdr methods)))))
 159     (buffer-string)))
 160
 161 (defun eieio-describe-class-slots (class)
 162   "Describe the slots in CLASS.
 163 Outputs to the standard output."
 164   (let* ((cv (class-v class))
 165          (docs   (aref cv class-public-doc))
 166          (names  (aref cv class-public-a))
 167          (deflt  (aref cv class-public-d))
 168          (types  (aref cv class-public-type))
 169          (i      0)
 170          (prot   (aref cv class-protection))
 171          )
 172     (princ "Instance Allocated Slots:")
 173     (terpri)
 174     (terpri)
 175     (while names
 176       (if (car prot) (princ "Private "))
 177       (princ "Slot: ")
 178       (prin1 (car names))
 179       (when (not (eq (aref types i) t))
 180         (princ "    type = ")
 181         (prin1 (aref types i)))
 182       (unless (eq (car deflt) eieio-unbound)
 183         (princ "    default = ")
 184         (prin1 (car deflt)))
 185       (when (car docs)
 186         (terpri)
 187         (princ "  ")
 188         (princ (car docs))
 189         (terpri))
 190       (terpri)
 191       (setq names (cdr names)
 192             docs (cdr docs)
 193             deflt (cdr deflt)
 194             prot (cdr prot)
 195             i (1+ i)))
 196     (setq docs  (aref cv class-class-allocation-doc)
 197           names (aref cv class-class-allocation-a)
 198           types (aref cv class-class-allocation-type)
 199           i     0
 200           prot  (aref cv class-class-allocation-protection))
 201     (when names
 202         (terpri)
 203         (princ "Class Allocated Slots:"))
 204         (terpri)
 205         (terpri)
 206     (while names
 207       (when (car prot)
 208         (princ "Private "))
 209       (princ "Slot: ")
 210       (prin1 (car names))
 211       (unless (eq (aref types i) t)
 212         (princ "    type = ")
 213         (prin1 (aref types i)))
 214       (when (car docs)
 215         (terpri)
 216         (princ "  ")
 217         (princ (car docs))
 218         (terpri))
 219       (terpri)
 220       (setq names (cdr names)
 221             docs (cdr docs)
 222             prot (cdr prot)
 223             i (1+ i)))))
 224
 225 (defun eieio-build-class-alist (&optional class instantiable-only buildlist)
 226   "Return an alist of all currently active classes for completion purposes.
 227 Optional argument CLASS is the class to start with.
 228 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 229 are not abstract, otherwise allow all classes.
 230 Optional argument BUILDLIST is more list to attach and is used internally."
 231   (let* ((cc (or class eieio-default-superclass))
 232          (sublst (aref (class-v cc) class-children)))
 233     (if (or (not instantiable-only) (not (class-abstract-p cc)))
 234         (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))
 235     (while sublst
 236       (setq buildlist (eieio-build-class-alist
 237                        (car sublst) instantiable-only buildlist))
 238       (setq sublst (cdr sublst)))
 239     buildlist))
 240
 241 (defvar eieio-read-class nil
 242   "History of the function `eieio-read-class' prompt.")
 243
 244 (defun eieio-read-class (prompt &optional histvar instantiable-only)
 245   "Return a class chosen by the user using PROMPT.
 246 Optional argument HISTVAR is a variable to use as history.
 247 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 248 are not abstract."
 249   (intern (completing-read prompt (eieio-build-class-alist) nil t nil
 250                            (or histvar 'eieio-read-class))))
 251
 252 (defun eieio-read-subclass (prompt class &optional histvar instantiable-only)
 253   "Return a class chosen by the user using PROMPT.
 254 CLASS is the base class, and completion occurs across all subclasses.
 255 Optional argument HISTVAR is a variable to use as history.
 256 If INSTANTIABLE-ONLY is non nil, only allow names of classes which
 257 are not abstract."
 258   (intern (completing-read prompt
 259                            (eieio-build-class-alist class instantiable-only)
 260                            nil t nil
 261                            (or histvar 'eieio-read-class))))
 262
 263 ;;; Collect all the generic functions created so far, and do cool stuff.
 264 ;;
 265 ;;;###autoload
 266 (defalias 'describe-method 'eieio-describe-generic)
 267 ;;;###autoload
 268 (defalias 'describe-generic 'eieio-describe-generic)
 269 ;;;###autoload
 270 (defalias 'eieio-describe-method 'eieio-describe-generic)
 271 ;;;###autoload
 272 (defun eieio-describe-generic (generic)
 273   "Describe the generic function GENERIC.
 274 Also extracts information about all methods specific to this generic."
 275   (interactive (list (eieio-read-generic "Generic Method: ")))
 276   (if (not (generic-p generic))
 277       (signal 'wrong-type-argument '(generic-p generic)))
 278   (with-output-to-temp-buffer "*Help*"
 279     (prin1 generic)
 280     (princ " is a generic function.")
 281     (terpri)
 282     (terpri)
 283     (let ((d (documentation generic)))
 284       (if (not d)
 285           (princ "The generic is not documented.\n")
 286         (princ "Documentation:")
 287         (terpri)
 288         (princ d)
 289         (terpri)
 290         (terpri)))
 291     (princ "Implementations:")
 292     (terpri)
 293     (terpri)
 294     (let ((i 3)
 295           (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
 296       ;; Loop over fanciful generics
 297       (while (< i 6)
 298         (let ((gm (aref (get generic 'eieio-method-tree) i)))
 299           (when gm
 300             (princ "Generic ")
 301             (princ (aref prefix (- i 3)))
 302             (terpri)
 303             (princ (or (nth 2 gm) "Undocumented"))
 304             (terpri)
 305             (terpri)))
 306         (setq i (1+ i)))
 307       (setq i 0)
 308       ;; Loop over defined class-specific methods
 309       (while (< i 3)
 310         (let ((gm (reverse (aref (get generic 'eieio-method-tree) i))))
 311           (while gm
 312             (princ "`")
 313             (prin1 (car (car gm)))
 314             (princ "'")
 315             ;; prefix type
 316             (princ " ")
 317             (princ (aref prefix i))
 318             (princ " ")
 319             ;; argument list
 320             (let* ((func (cdr (car gm)))
 321                    (arglst (eieio-lambda-arglist func)))
 322               (prin1 arglst))
 323             (terpri)
 324             ;; 3 because of cdr
 325             (princ (or (documentation (cdr (car gm)))
 326                        "Undocumented"))
 327             (setq gm (cdr gm))
 328             (terpri)
 329             (terpri)))
 330         (setq i (1+ i))))
 331     (buffer-string)))
 332
 333 (defun eieio-lambda-arglist (func)
 334   "Return the argument list of FUNC, a function body."
 335   (if (symbolp func) (setq func (symbol-function func)))
 336   (if (byte-code-function-p func)
 337       (eieio-compiled-function-arglist func)
 338     (car (cdr func))))
 339
 340 (defun eieio-all-generic-functions (&optional class)
 341   "Return a list of all generic functions.
 342 Optional CLASS argument returns only those functions that contain methods for CLASS."
 343   (let ((l nil) tree (cn (if class (symbol-name class) nil)))
 344     (mapatoms
 345      (lambda (symbol)
 346        (setq tree (get symbol 'eieio-method-obarray))
 347        (if tree
 348            (progn
 349              ;; A symbol might be interned for that class in one of
 350              ;; these three slots in the method-obarray.
 351              (if (or (not class)
 352                      (fboundp (intern-soft cn (aref tree 0)))
 353                      (fboundp (intern-soft cn (aref tree 1)))
 354                      (fboundp (intern-soft cn (aref tree 2))))
 355                  (setq l (cons symbol l)))))))
 356     l))
 357
 358 (defun eieio-method-documentation (generic class)
 359   "Return a list of the specific documentation of GENERIC for CLASS.
 360 If there is not an explicit method for CLASS in GENERIC, or if that
 361 function has no documentation, then return nil."
 362   (let ((tree (get generic 'eieio-method-obarray))
 363         (cn (symbol-name class))
 364         before primary after)
 365     (if (not tree)
 366         nil
 367       ;; A symbol might be interned for that class in one of
 368       ;; these three slots in the method-obarray.
 369       (setq before (intern-soft cn (aref tree 0))
 370             primary (intern-soft cn (aref tree 1))
 371             after (intern-soft cn (aref tree 2)))
 372       (if (not (or (fboundp before)
 373                    (fboundp primary)
 374                    (fboundp after)))
 375           nil
 376         (list (if (fboundp before)
 377                   (cons (eieio-lambda-arglist before)
 378                         (documentation before))
 379                 nil)
 380               (if (fboundp primary)
 381                   (cons (eieio-lambda-arglist primary)
 382                         (documentation primary))
 383                 nil)
 384               (if (fboundp after)
 385                   (cons (eieio-lambda-arglist after)
 386                         (documentation after))
 387                 nil))))))
 388
 389 (defvar eieio-read-generic nil
 390   "History of the `eieio-read-generic' prompt.")
 391
 392 (defun eieio-read-generic-p (fn)
 393   "Function used in function `eieio-read-generic'.
 394 This is because `generic-p' is a macro.
 395 Argument FN is the function to test."
 396   (generic-p fn))
 397
 398 (defun eieio-read-generic (prompt &optional historyvar)
 399   "Read a generic function from the minibuffer with PROMPT.
 400 Optional argument HISTORYVAR is the variable to use as history."
 401   (intern (completing-read prompt obarray 'eieio-read-generic-p
 402                            t nil (or historyvar 'eieio-read-generic))))
 403
 404 ;;; Help system augmentation
 405 ;;
 406 (defun eieio-help-mode-augmentation-maybee (&rest unused)
 407   "For buffers thrown into help mode, augment for eieio.
 408 Arguments UNUSED are not used."
 409   ;; Scan created buttons so far if we are in help mode.
 410   (when (eq major-mode 'help-mode)
 411     (save-excursion
 412       (goto-char (point-min))
 413       (let ((pos t) (inhibit-read-only t))
 414         (while pos
 415           (if (get-text-property (point) 'help-xref) ; move off reference
 416               (goto-char
 417                (or (next-single-property-change (point) 'help-xref)
 418                    (point))))
 419           (setq pos (next-single-property-change (point) 'help-xref))
 420           (when pos
 421             (goto-char pos)
 422             (let* ((help-data (get-text-property (point) 'help-xref))
 423                    (method (car help-data))
 424                    (args (cdr help-data)))
 425               (when (symbolp (car args))
 426                 (cond ((class-p (car args))
 427                        (setcar help-data 'eieio-describe-class))
 428                       ((generic-p (car args))
 429                        (setcar help-data 'eieio-describe-generic))
 430                       (t nil))
 431                 ))))
 432         ;; start back at the beginning, and highlight some sections
 433         (goto-char (point-min))
 434         (while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t)
 435             (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 436         (goto-char (point-min))
 437         (if (re-search-forward "^Specialized Methods:$" nil t)
 438             (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 439         (goto-char (point-min))
 440         (while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t)
 441             (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 442         (goto-char (point-min))
 443         (while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t)
 444             (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 445         (goto-char (point-min))
 446         (while (re-search-forward "^\\(Private \\)?Slot:" nil t)
 447             (put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
 448         ))))
 449
 450 (defun eieio-help-augment-keymap ()
 451   "Augment the help keymap for cool EIEIO stuff."
 452   (define-key help-map "g" 'describe-generic)
 453   (define-key help-map "C" 'describe-class))
 454
 455 (if (and (boundp 'help-map) help-map)
 456     (eieio-help-augment-keymap)
 457   (eval-after-load 'help 'eieio-help-augment-keymap))
 458
 459 ;;; How about showing the hierarchy in speedbar?  Cool!
 460 ;;
 461 (eval-when-compile
 462   (condition-case nil
 463       (require 'speedbar)
 464     (error (message "Error loading speedbar... ignored."))))
 465
 466 (defvar eieio-class-speedbar-key-map nil
 467   "Keymap used when working with a project in speedbar.")
 468
 469 (defun eieio-class-speedbar-make-map ()
 470   "Make a keymap for eieio under speedbar."
 471   (setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap))
 472
 473   ;; General viewing stuff
 474   (define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line)
 475   (define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line)
 476   (define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line)
 477   )
 478
 479 (if eieio-class-speedbar-key-map
 480     nil
 481   (if (not (featurep 'speedbar))
 482       (add-hook 'speedbar-load-hook (lambda ()
 483                                       (eieio-class-speedbar-make-map)
 484                                       (speedbar-add-expansion-list
 485                                        '("EIEIO"
 486                                          eieio-class-speedbar-menu
 487                                          eieio-class-speedbar-key-map
 488                                          eieio-class-speedbar))))
 489     (eieio-class-speedbar-make-map)
 490     (speedbar-add-expansion-list '("EIEIO"
 491                                    eieio-class-speedbar-menu
 492                                    eieio-class-speedbar-key-map
 493                                    eieio-class-speedbar))))
 494
 495 (defvar eieio-class-speedbar-menu
 496   ()
 497   "Menu part in easymenu format used in speedbar while in `eieio' mode.")
 498
 499 (defun eieio-class-speedbar (dir-or-object depth)
 500   "Create buttons in speedbar that represents the current project.
 501 DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the current
 502 expansion depth."
 503   (when (eq (point-min) (point-max))
 504     ;; This function is only called once, to start the whole deal.
 505     ;; Ceate, and expand the default object.
 506     (eieio-class-button eieio-default-superclass 0)
 507     (forward-line -1)
 508     (speedbar-expand-line)))
 509
 510 (defun eieio-class-button (class depth)
 511   "Draw a speedbar button at the current point for CLASS at DEPTH."
 512   (if (not (class-p class))
 513       (signal 'wrong-type-argument (list 'class-p class)))
 514   (let ((subclasses (aref (class-v class) class-children)))
 515     (if subclasses
 516         (speedbar-make-tag-line 'angle ?+
 517                                 'eieio-sb-expand
 518                                 class
 519                                 (symbol-name class)
 520                                 'eieio-describe-class-sb
 521                                 class
 522                                 'speedbar-directory-face
 523                                 depth)
 524       (speedbar-make-tag-line 'angle ?  nil nil
 525                               (symbol-name class)
 526                               'eieio-describe-class-sb
 527                               class
 528                               'speedbar-directory-face
 529                               depth))))
 530
 531 (defun eieio-sb-expand (text class indent)
 532   "For button TEXT, expand CLASS at the current location.
 533 Argument INDENT is the depth of indentation."
 534   (cond ((string-match "+" text)        ;we have to expand this file
 535          (speedbar-change-expand-button-char ?-)
 536          (speedbar-with-writable
 537            (save-excursion
 538              (end-of-line) (forward-char 1)
 539              (let ((subclasses (aref (class-v class) class-children)))
 540                (while subclasses
 541                  (eieio-class-button (car subclasses) (1+ indent))
 542                  (setq subclasses (cdr subclasses)))))))
 543         ((string-match "-" text)        ;we have to contract this node
 544          (speedbar-change-expand-button-char ?+)
 545          (speedbar-delete-subblock indent))
 546         (t (error "Ooops...  not sure what to do")))
 547   (speedbar-center-buffer-smartly))
 548
 549 (defun eieio-describe-class-sb (text token indent)
 550   "Describe the class TEXT in TOKEN.
 551 INDENT is the current indentation level."
 552   (speedbar-with-attached-buffer
 553    (eieio-describe-class token))
 554   (speedbar-maybee-jump-to-attached-frame))
 555
 556 (provide 'eieio-opt)
 557
 558 ;;; eieio-opt.el ends here