;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
-;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2008,
-;; 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1998-2003, 2005, 2008-2012
+;; Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Version: 0.2
;; Keywords: OO, lisp
;; Package: eieio
;;
(require 'eieio)
+(require 'button)
+(require 'help-mode)
+(require 'find-func)
;;; Code:
+;;;###autoload
(defun eieio-browse (&optional root-class)
"Create an object browser window to show all objects.
If optional ROOT-CLASS, then start with that, otherwise start with
;;; CLASS COMPLETION / DOCUMENTATION
-(defalias 'describe-class 'eieio-describe-class)
+;;;###autoload(defalias 'describe-class 'eieio-describe-class)
+;;;###autoload
(defun eieio-describe-class (class &optional headerfcn)
"Describe a CLASS defined by a string or symbol.
If CLASS is actually an object, then also display current values of that object.
(called-interactively-p 'interactive))
(when headerfcn (funcall headerfcn))
-
- (if (class-option class :abstract)
- (princ "Abstract "))
- (princ "Class ")
(prin1 class)
+ (princ " is a")
+ (if (class-option class :abstract)
+ (princ "n abstract"))
+ (princ " class")
+ ;; Print file location
+ (when (get class 'class-location)
+ (princ " in `")
+ (princ (file-name-nondirectory (get class 'class-location)))
+ (princ "'"))
(terpri)
- ;; Inheritence tree information
+ ;; Inheritance tree information
(let ((pl (class-parents class)))
(when pl
(princ " Inherits from ")
prot (cdr prot)
i (1+ i)))))
+;;;###autoload
(defun eieio-describe-constructor (fcn)
"Describe the constructor function FCN.
Uses `eieio-describe-class' to describe the class being constructed."
(eieio-describe-class
fcn (lambda ()
;; Describe the constructor part.
- (princ "Object Constructor Function: ")
(prin1 fcn)
+ (princ " is an object constructor function")
+ ;; Print file location
+ (when (get fcn 'class-location)
+ (princ " in `")
+ (princ (file-name-nondirectory (get fcn 'class-location)))
+ (princ "'"))
(terpri)
(princ "Creates an object of class ")
(prin1 fcn)
))
)
+(defun eieio-build-class-list (class)
+ "Return a list of all classes that inherit from CLASS."
+ (if (class-p class)
+ (apply #'append
+ (mapcar
+ (lambda (c)
+ (append (list c) (eieio-build-class-list c)))
+ (class-children-fast class)))
+ (list class)))
+
(defun eieio-build-class-alist (&optional class instantiable-only buildlist)
"Return an alist of all currently active classes for completion purposes.
Optional argument CLASS is the class to start with.
Optional argument BUILDLIST is more list to attach and is used internally."
(let* ((cc (or class eieio-default-superclass))
(sublst (aref (class-v cc) class-children)))
- (if (or (not instantiable-only) (not (class-abstract-p cc)))
- (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))
+ (unless (assoc (symbol-name cc) buildlist)
+ (when (or (not instantiable-only) (not (class-abstract-p cc)))
+ (setq buildlist (cons (cons (symbol-name cc) 1) buildlist))))
(while sublst
(setq buildlist (eieio-build-class-alist
(car sublst) instantiable-only buildlist))
;;; METHOD COMPLETION / DOC
(defalias 'describe-method 'eieio-describe-generic)
-(defalias 'describe-generic 'eieio-describe-generic)
+;;;###autoload(defalias 'describe-generic 'eieio-describe-generic)
(defalias 'eieio-describe-method 'eieio-describe-generic)
+;;;###autoload
(defun eieio-describe-generic (generic)
"Describe the generic function GENERIC.
Also extracts information about all methods specific to this generic."
(princ "Implementations:")
(terpri)
(terpri)
- (let ((i 3)
+ (let ((i 4)
(prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
;; Loop over fanciful generics
- (while (< i 6)
+ (while (< i 7)
(let ((gm (aref (get generic 'eieio-method-tree) i)))
(when gm
(princ "Generic ")
(setq i (1+ i)))
(setq i 0)
;; Loop over defined class-specific methods
- (while (< i 3)
- (let ((gm (reverse (aref (get generic 'eieio-method-tree) i))))
+ (while (< i 4)
+ (let ((gm (reverse (aref (get generic 'eieio-method-tree) i)))
+ location)
(while gm
(princ "`")
(prin1 (car (car gm)))
;; 3 because of cdr
(princ (or (documentation (cdr (car gm)))
"Undocumented"))
+ ;; Print file location if available
+ (when (and (setq location (get generic 'method-locations))
+ (setq location (assoc (caar gm) location)))
+ (setq location (cadr location))
+ (princ "\n\nDefined in `")
+ (princ (file-name-nondirectory location))
+ (princ "'\n"))
(setq gm (cdr gm))
(terpri)
(terpri)))
;;; HELP AUGMENTATION
;;
+(define-button-type 'eieio-method-def
+ :supertype 'help-xref
+ 'help-function (lambda (class method file)
+ (eieio-help-find-method-definition class method file))
+ 'help-echo (purecopy "mouse-2, RET: find method's definition"))
+
+(define-button-type 'eieio-class-def
+ :supertype 'help-xref
+ 'help-function (lambda (class file)
+ (eieio-help-find-class-definition class file))
+ 'help-echo (purecopy "mouse-2, RET: find class definition"))
+
+(defun eieio-help-find-method-definition (class method file)
+ (let ((filename (find-library-name file))
+ location buf)
+ (when (null filename)
+ (error "Cannot find library %s" file))
+ (setq buf (find-file-noselect filename))
+ (with-current-buffer buf
+ (goto-char (point-min))
+ (when
+ (re-search-forward
+ ;; Regexp for searching methods.
+ (concat "(defmethod[ \t\r\n]+" method
+ "\\([ \t\r\n]+:[a-zA-Z]+\\)?"
+ "[ \t\r\n]+(\\s-*(\\(\\sw\\|\\s_\\)+\\s-+"
+ class
+ "\\s-*)")
+ nil t)
+ (setq location (match-beginning 0))))
+ (if (null location)
+ (message "Unable to find location in file")
+ (pop-to-buffer buf)
+ (goto-char location)
+ (recenter)
+ (beginning-of-line))))
+
+(defun eieio-help-find-class-definition (class file)
+ (let ((filename (find-library-name file))
+ location buf)
+ (when (null filename)
+ (error "Cannot find library %s" file))
+ (setq buf (find-file-noselect filename))
+ (with-current-buffer buf
+ (goto-char (point-min))
+ (when
+ (re-search-forward
+ ;; Regexp for searching a class.
+ (concat "(defclass[ \t\r\n]+" class "[ \t\r\n]+")
+ nil t)
+ (setq location (match-beginning 0))))
+ (if (null location)
+ (message "Unable to find location in file")
+ (pop-to-buffer buf)
+ (goto-char location)
+ (recenter)
+ (beginning-of-line))))
+
+
(defun eieio-help-mode-augmentation-maybee (&rest unused)
"For buffers thrown into help mode, augment for EIEIO.
Arguments UNUSED are not used."
(goto-char (point-min))
(while (re-search-forward "^\\(Private \\)?Slot:" nil t)
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
+ (goto-char (point-min))
+ (cond
+ ((looking-at "\\(.+\\) is a generic function")
+ (let ((mname (match-string 1))
+ cname)
+ (while (re-search-forward "^`\\(.+\\)'[^\0]+?Defined in `\\(.+\\)'" nil t)
+ (setq cname (match-string-no-properties 1))
+ (help-xref-button 2 'eieio-method-def cname
+ mname
+ (cadr (assoc (intern cname)
+ (get (intern mname)
+ 'method-locations)))))))
+ ((looking-at "\\(.+\\) is an object constructor function in `\\(.+\\)'")
+ (let ((cname (match-string-no-properties 1)))
+ (help-xref-button 2 'eieio-class-def cname
+ (get (intern cname) 'class-location))))
+ ((looking-at "\\(.+\\) is a\\(n abstract\\)? class in `\\(.+\\)'")
+ (let ((cname (match-string-no-properties 1)))
+ (help-xref-button 3 'eieio-class-def cname
+ (get (intern cname) 'class-location)))))
))))
;;; SPEEDBAR SUPPORT
(provide 'eieio-opt)
-;; arch-tag: 71eab5f5-462f-4fa1-8ed1-f5ca1bf9adb6
;;; eieio-opt.el ends here
HCoop / bpt / emacs.git / blobdiff