emacs-lisp/eieio-base.el, emacs-lisp/eieio-comp.el,
emacs-lisp/eieio-custom.el, emacs-lisp/eieio-datadebug.el, emacs-lisp/eieio-doc.el, emacs-lisp/eieio-opt.el, emacs-lisp/eieio-speedbar.el, emacs-lisp/eieio.el: Move from eieio/directory.
This commit is contained in:
Chong Yidong
parent
441983a560
commit
ac6cb46aa6
8 changed files with 5414 additions and 0 deletions
328
lisp/emacs-lisp/eieio-base.el
Normal file
328
lisp/emacs-lisp/eieio-base.el
Normal file
|
|
@ -0,0 +1,328 @@
|
|||
;;; eieio-base.el --- Base classes for EIEIO.
|
||||
|
||||
;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009
|
||||
;;; Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: OO, lisp
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; Base classes for EIEIO. These classes perform some basic tasks
|
||||
;; but are generally useless on their own. To use any of these classes,
|
||||
;; inherit from one or more of them.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'eieio)
|
||||
|
||||
;;; eieio-instance-inheritor
|
||||
;;
|
||||
;; Enable instance inheritance via the `clone' method.
|
||||
;; Works by using the `slot-unbound' method which usually throws an
|
||||
;; error if a slot is unbound.
|
||||
(defclass eieio-instance-inheritor ()
|
||||
((parent-instance :initarg :parent-instance
|
||||
:type eieio-instance-inheritor-child
|
||||
:documentation
|
||||
"The parent of this instance.
|
||||
If a slot of this class is reference, and is unbound, then the parent
|
||||
is checked for a value.")
|
||||
)
|
||||
"This special class can enable instance inheritance.
|
||||
Use `clone' to make a new object that does instance inheritance from
|
||||
a parent instance. When a slot in the child is referenced, and has
|
||||
not been set, use values from the parent."
|
||||
:abstract t)
|
||||
|
||||
(defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn)
|
||||
"If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
|
||||
SLOT-NAME, is the offending slot. FN is the function signalling the error."
|
||||
(if (slot-boundp object 'parent-instance)
|
||||
;; It may not look like it, but this line recurses back into this
|
||||
;; method if the parent instance's slot is unbound.
|
||||
(eieio-oref (oref object parent-instance) slot-name)
|
||||
;; Throw the regular signal.
|
||||
(call-next-method)))
|
||||
|
||||
(defmethod clone ((obj eieio-instance-inheritor) &rest params)
|
||||
"Clone OBJ, initializing `:parent' to OBJ.
|
||||
All slots are unbound, except those initialized with PARAMS."
|
||||
(let ((nobj (make-vector (length obj) eieio-unbound))
|
||||
(nm (aref obj object-name))
|
||||
(passname (and params (stringp (car params))))
|
||||
(num 1))
|
||||
(aset nobj 0 'object)
|
||||
(aset nobj object-class (aref obj object-class))
|
||||
;; The following was copied from the default clone.
|
||||
(if (not passname)
|
||||
(save-match-data
|
||||
(if (string-match "-\\([0-9]+\\)" nm)
|
||||
(setq num (1+ (string-to-number (match-string 1 nm)))
|
||||
nm (substring nm 0 (match-beginning 0))))
|
||||
(aset nobj object-name (concat nm "-" (int-to-string num))))
|
||||
(aset nobj object-name (car params)))
|
||||
;; Now initialize from params.
|
||||
(if params (shared-initialize nobj (if passname (cdr params) params)))
|
||||
(oset nobj parent-instance obj)
|
||||
nobj))
|
||||
|
||||
(defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor)
|
||||
slot)
|
||||
"Non-nil if the instance inheritor OBJECT's SLOT is bound.
|
||||
See `slot-boundp' for for details on binding slots.
|
||||
The instance inheritor uses unbound slots as a way cascading cloned
|
||||
slot values, so testing for a slot being bound requires extra steps
|
||||
for this kind of object."
|
||||
(if (slot-boundp object slot)
|
||||
;; If it is regularly bound, return t.
|
||||
t
|
||||
(if (slot-boundp object 'parent-instance)
|
||||
(eieio-instance-inheritor-slot-boundp (oref object parent-instance)
|
||||
slot)
|
||||
nil)))
|
||||
|
||||
|
||||
;;; eieio-instance-tracker
|
||||
;;
|
||||
;; Track all created instances of this class.
|
||||
;; The class must initialize the `tracking-symbol' slot, and that
|
||||
;; symbol is then used to contain these objects.
|
||||
(defclass eieio-instance-tracker ()
|
||||
((tracking-symbol :type symbol
|
||||
:allocation :class
|
||||
:documentation
|
||||
"The symbol used to maintain a list of our instances.
|
||||
The instance list is treated as a variable, with new instances added to it.")
|
||||
)
|
||||
"This special class enables instance tracking.
|
||||
Inheritors from this class must overload `tracking-symbol' which is
|
||||
a variable symbol used to store a list of all instances."
|
||||
:abstract t)
|
||||
|
||||
(defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
|
||||
&rest slots)
|
||||
"Make sure THIS is in our master list of this class.
|
||||
Optional argument SLOTS are the initialization arguments."
|
||||
;; Theoretically, this is never called twice for a given instance.
|
||||
(let ((sym (oref this tracking-symbol)))
|
||||
(if (not (memq this (symbol-value sym)))
|
||||
(set sym (append (symbol-value sym) (list this))))))
|
||||
|
||||
(defmethod delete-instance ((this eieio-instance-tracker))
|
||||
"Remove THIS from the master list of this class."
|
||||
(set (oref this tracking-symbol)
|
||||
(delq this (symbol-value (oref this tracking-symbol)))))
|
||||
|
||||
;; In retrospect, this is a silly function.
|
||||
(defun eieio-instance-tracker-find (key slot list-symbol)
|
||||
"Find KEY as an element of SLOT in the objects in LIST-SYMBOL.
|
||||
Returns the first match."
|
||||
(object-assoc key slot (symbol-value list-symbol)))
|
||||
|
||||
;;; eieio-singleton
|
||||
;;
|
||||
;; The singleton Design Pattern specifies that there is but one object
|
||||
;; of a given class ever created. The EIEIO singleton base class defines
|
||||
;; a CLASS allocated slot which contains the instance used. All calls to
|
||||
;; `make-instance' will either create a new instance and store it in this
|
||||
;; slot, or it will just return what is there.
|
||||
(defclass eieio-singleton ()
|
||||
((singleton :type eieio-singleton
|
||||
:allocation :class
|
||||
:documentation
|
||||
"The only instance of this class that will be instantiated.
|
||||
Multiple calls to `make-instance' will return this object."))
|
||||
"This special class causes subclasses to be singletons.
|
||||
A singleton is a class which will only ever have one instace."
|
||||
:abstract t)
|
||||
|
||||
(defmethod constructor :STATIC ((class eieio-singleton) name &rest slots)
|
||||
"Constructor for singleton CLASS.
|
||||
NAME and SLOTS initialize the new object.
|
||||
This constructor guarantees that no matter how many you request,
|
||||
only one object ever exists."
|
||||
;; NOTE TO SELF: In next version, make `slot-boundp' support classes
|
||||
;; with class allocated slots or default values.
|
||||
(let ((old (oref-default class singleton)))
|
||||
(if (eq old eieio-unbound)
|
||||
(oset-default class singleton (call-next-method))
|
||||
old)))
|
||||
|
||||
|
||||
;;; eieio-persistent
|
||||
;;
|
||||
;; For objects which must save themselves to disk. Provides an
|
||||
;; `object-write' method to save an object to disk, and a
|
||||
;; `eieio-persistent-read' function to call to read an object
|
||||
;; from disk.
|
||||
;;
|
||||
;; Also provide the method `eieio-persistent-path-relative' to
|
||||
;; calculate path names relative to a given instance. This will
|
||||
;; make the saved object location independent by converting all file
|
||||
;; references to be relative to the directory the object is saved to.
|
||||
;; You must call `eieio-peristent-path-relative' on each file name
|
||||
;; saved in your object.
|
||||
(defclass eieio-persistent ()
|
||||
((file :initarg :file
|
||||
:type string
|
||||
:documentation
|
||||
"The save file for this persistent object.
|
||||
This must be a string, and must be specified when the new object is
|
||||
instantiated.")
|
||||
(extension :type string
|
||||
:allocation :class
|
||||
:initform ".eieio"
|
||||
:documentation
|
||||
"Extension of files saved by this object.
|
||||
Enables auto-choosing nice file names based on name.")
|
||||
(file-header-line :type string
|
||||
:allocation :class
|
||||
:initform ";; EIEIO PERSISTENT OBJECT"
|
||||
:documentation
|
||||
"Header line for the save file.
|
||||
This is used with the `object-write' method.")
|
||||
(do-backups :type boolean
|
||||
:allocation :class
|
||||
:initform t
|
||||
:documentation
|
||||
"Saving this object should make backup files.
|
||||
Setting to nil will mean no backups are made."))
|
||||
"This special class enables persistence through save files
|
||||
Use the `object-save' method to write this object to disk. The save
|
||||
format is Emacs Lisp code which calls the constructor for the saved
|
||||
object. For this reason, only slots which do not have an `:initarg'
|
||||
specified will not be saved."
|
||||
:abstract t)
|
||||
|
||||
(defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt
|
||||
&optional name)
|
||||
"Perpare to save THIS. Use in an `interactive' statement.
|
||||
Query user for file name with PROMPT if THIS does not yet specify
|
||||
a file. Optional argument NAME specifies a default file name."
|
||||
(unless (slot-boundp this 'file)
|
||||
(oset this file
|
||||
(read-file-name prompt nil
|
||||
(if name
|
||||
(concat name (oref this extension))
|
||||
))))
|
||||
(oref this file))
|
||||
|
||||
(defun eieio-persistent-read (filename)
|
||||
"Read a persistent object from FILENAME, and return it."
|
||||
(let ((ret nil)
|
||||
(buffstr nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(save-excursion
|
||||
(set-buffer (get-buffer-create " *tmp eieio read*"))
|
||||
(insert-file-contents filename nil nil nil t)
|
||||
(goto-char (point-min))
|
||||
(setq buffstr (buffer-string)))
|
||||
;; Do the read in the buffer the read was initialized from
|
||||
;; so that any initialize-instance calls that depend on
|
||||
;; the current buffer will work.
|
||||
(setq ret (read buffstr))
|
||||
(if (not (child-of-class-p (car ret) 'eieio-persistent))
|
||||
(error "Corrupt object on disk"))
|
||||
(setq ret (eval ret))
|
||||
(oset ret file filename))
|
||||
(kill-buffer " *tmp eieio read*"))
|
||||
ret))
|
||||
|
||||
(defmethod object-write ((this eieio-persistent) &optional comment)
|
||||
"Write persistent object THIS out to the current stream.
|
||||
Optional argument COMMENT is a header line comment."
|
||||
(call-next-method this (or comment (oref this file-header-line))))
|
||||
|
||||
(defmethod eieio-persistent-path-relative ((this eieio-persistent) file)
|
||||
"For object THIS, make absolute file name FILE relative."
|
||||
(file-relative-name (expand-file-name file)
|
||||
(file-name-directory (oref this file))))
|
||||
|
||||
(defmethod eieio-persistent-save ((this eieio-persistent) &optional file)
|
||||
"Save persistent object THIS to disk.
|
||||
Optional argument FILE overrides the file name specified in the object
|
||||
instance."
|
||||
(save-excursion
|
||||
(let ((b (set-buffer (get-buffer-create " *tmp object write*")))
|
||||
(default-directory (file-name-directory (oref this file)))
|
||||
(cfn (oref this file)))
|
||||
(unwind-protect
|
||||
(save-excursion
|
||||
(erase-buffer)
|
||||
(let ((standard-output (current-buffer)))
|
||||
(oset this file
|
||||
(if file
|
||||
(eieio-persistent-path-relative this file)
|
||||
(file-name-nondirectory cfn)))
|
||||
(object-write this (oref this file-header-line)))
|
||||
(let ((backup-inhibited (not (oref this do-backups))))
|
||||
;; Old way - write file. Leaves message behind.
|
||||
;;(write-file cfn nil)
|
||||
|
||||
;; New way - Avoid the vast quantities of error checking
|
||||
;; just so I can get at the special flags that disable
|
||||
;; displaying random messages.
|
||||
(write-region (point-min) (point-max)
|
||||
cfn nil 1)
|
||||
))
|
||||
;; Restore :file, and kill the tmp buffer
|
||||
(oset this file cfn)
|
||||
(setq buffer-file-name nil)
|
||||
(kill-buffer b)))))
|
||||
|
||||
;; Notes on the persistent object:
|
||||
;; It should also set up some hooks to help it keep itself up to date.
|
||||
|
||||
|
||||
;;; Named object
|
||||
;;
|
||||
;; Named objects use the objects `name' as a slot, and that slot
|
||||
;; is accessed with the `object-name' symbol.
|
||||
|
||||
(defclass eieio-named ()
|
||||
()
|
||||
"Object with a name.
|
||||
Name storage already occurs in an object. This object provides get/set
|
||||
access to it."
|
||||
:abstract t)
|
||||
|
||||
(defmethod slot-missing ((obj eieio-named)
|
||||
slot-name operation &optional new-value)
|
||||
"Called when a on-existant slot is accessed.
|
||||
For variable `eieio-named', provide an imaginary `object-name' slot.
|
||||
Argument OBJ is the Named object.
|
||||
Argument SLOT-NAME is the slot that was attempted to be accessed.
|
||||
OPERATION is the type of access, such as `oref' or `oset'.
|
||||
NEW-VALUE is the value that was being set into SLOT if OPERATION were
|
||||
a set type."
|
||||
(if (or (eq slot-name 'object-name)
|
||||
(eq slot-name :object-name))
|
||||
(cond ((eq operation 'oset)
|
||||
(if (not (stringp new-value))
|
||||
(signal 'invalid-slot-type
|
||||
(list obj slot-name 'string new-value)))
|
||||
(object-set-name-string obj new-value))
|
||||
(t (object-name-string obj)))
|
||||
(call-next-method)))
|
||||
|
||||
(provide 'eieio-base)
|
||||
|
||||
;;; eieio-base.el ends here
|
||||
170
lisp/emacs-lisp/eieio-comp.el
Normal file
170
lisp/emacs-lisp/eieio-comp.el
Normal file
|
|
@ -0,0 +1,170 @@
|
|||
;;; eieio-comp.el -- eieio routines to help with byte compilation
|
||||
|
||||
;;; Copyright (C) 1995,1996, 1998, 1999, 2000, 2001, 2002, 2005, 2008,
|
||||
;;; 2009 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: oop, lisp, tools
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Byte compiler functions for defmethod. This will affect the new GNU
|
||||
;; byte compiler for Emacs 19 and better. This function will be called by
|
||||
;; the byte compiler whenever a `defmethod' is encountered in a file.
|
||||
;; It will output a function call to `eieio-defmethod' with the byte
|
||||
;; compiled function as a parameter.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(eval-and-compile
|
||||
(if (featurep 'xemacs)
|
||||
(progn
|
||||
;; XEmacs compatibility settings.
|
||||
(if (not (fboundp 'byte-compile-compiled-obj-to-list))
|
||||
(defun byte-compile-compiled-obj-to-list (moose) nil))
|
||||
(if (not (boundp 'byte-compile-outbuffer))
|
||||
(defvar byte-compile-outbuffer nil))
|
||||
(defmacro eieio-byte-compile-princ-code (code outbuffer)
|
||||
`(progn (if (atom ,code)
|
||||
(princ "#[" ,outbuffer)
|
||||
(princ "'(" ,outbuffer))
|
||||
(let ((codelist (if (byte-code-function-p ,code)
|
||||
(byte-compile-compiled-obj-to-list ,code)
|
||||
(append ,code nil))))
|
||||
(while codelist
|
||||
(eieio-prin1 (car codelist) ,outbuffer)
|
||||
(princ " " ,outbuffer)
|
||||
(setq codelist (cdr codelist))))
|
||||
(if (atom ,code)
|
||||
(princ "]" ,outbuffer)
|
||||
(princ ")" ,outbuffer))))
|
||||
(defun eieio-prin1 (code outbuffer)
|
||||
(cond ((byte-code-function-p code)
|
||||
(let ((codelist (byte-compile-compiled-obj-to-list code)))
|
||||
(princ "#[" outbuffer)
|
||||
(while codelist
|
||||
(eieio-prin1 (car codelist) outbuffer)
|
||||
(princ " " outbuffer)
|
||||
(setq codelist (cdr codelist)))
|
||||
(princ "]" outbuffer)))
|
||||
((vectorp code)
|
||||
(let ((i 0) (ln (length code)))
|
||||
(princ "[" outbuffer)
|
||||
(while (< i ln)
|
||||
(eieio-prin1 (aref code i) outbuffer)
|
||||
(princ " " outbuffer)
|
||||
(setq i (1+ i)))
|
||||
(princ "]" outbuffer)))
|
||||
(t (prin1 code outbuffer)))))
|
||||
;; Emacs:
|
||||
(defmacro eieio-byte-compile-princ-code (code outbuffer)
|
||||
(list 'prin1 code outbuffer))
|
||||
;; Dynamically bound in byte-compile-from-buffer.
|
||||
(defvar bytecomp-outbuffer)
|
||||
(defvar bytecomp-filename)))
|
||||
|
||||
(declare-function eieio-defgeneric-form "eieio" (method doc-string))
|
||||
|
||||
(defun byte-compile-defmethod-param-convert (paramlist)
|
||||
"Convert method params into the params used by the defmethod thingy.
|
||||
Argument PARAMLIST is the paramter list to convert."
|
||||
(let ((argfix nil))
|
||||
(while paramlist
|
||||
(setq argfix (cons (if (listp (car paramlist))
|
||||
(car (car paramlist))
|
||||
(car paramlist))
|
||||
argfix))
|
||||
(setq paramlist (cdr paramlist)))
|
||||
(nreverse argfix)))
|
||||
|
||||
;; This teaches the byte compiler how to do this sort of thing.
|
||||
(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
|
||||
|
||||
(defun byte-compile-file-form-defmethod (form)
|
||||
"Mumble about the method we are compiling.
|
||||
This function is mostly ripped from `byte-compile-file-form-defun', but
|
||||
it's been modified to handle the special syntax of the defmethod
|
||||
command. There should probably be one for defgeneric as well, but
|
||||
that is called but rarely. Argument FORM is the body of the method."
|
||||
(setq form (cdr form))
|
||||
(let* ((meth (car form))
|
||||
(key (progn (setq form (cdr form))
|
||||
(cond ((or (eq ':BEFORE (car form))
|
||||
(eq ':before (car form)))
|
||||
(setq form (cdr form))
|
||||
":before ")
|
||||
((or (eq ':AFTER (car form))
|
||||
(eq ':after (car form)))
|
||||
(setq form (cdr form))
|
||||
":after ")
|
||||
((or (eq ':PRIMARY (car form))
|
||||
(eq ':primary (car form)))
|
||||
(setq form (cdr form))
|
||||
":primary ")
|
||||
((or (eq ':STATIC (car form))
|
||||
(eq ':static (car form)))
|
||||
(setq form (cdr form))
|
||||
":static ")
|
||||
(t ""))))
|
||||
(params (car form))
|
||||
(lamparams (byte-compile-defmethod-param-convert params))
|
||||
(arg1 (car params))
|
||||
(class (if (listp arg1) (nth 1 arg1) nil))
|
||||
(my-outbuffer (if (featurep 'xemacs)
|
||||
byte-compile-outbuffer
|
||||
bytecomp-outbuffer)))
|
||||
(let ((name (format "%s::%s" (or class "#<generic>") meth)))
|
||||
(if byte-compile-verbose
|
||||
;; bytecomp-filename is from byte-compile-from-buffer.
|
||||
(message "Compiling %s... (%s)" (or bytecomp-filename "") name))
|
||||
(setq byte-compile-current-form name)) ; for warnings
|
||||
;; Flush any pending output
|
||||
(byte-compile-flush-pending)
|
||||
;; Byte compile the body. For the byte compiled forms, add the
|
||||
;; rest arguments, which will get ignored by the engine which will
|
||||
;; add them later (I hope)
|
||||
(let* ((new-one (byte-compile-lambda
|
||||
(append (list 'lambda lamparams)
|
||||
(cdr form))))
|
||||
(code (byte-compile-byte-code-maker new-one)))
|
||||
(princ "\n(eieio-defmethod '" my-outbuffer)
|
||||
(princ meth my-outbuffer)
|
||||
(princ " '(" my-outbuffer)
|
||||
(princ key my-outbuffer)
|
||||
(prin1 params my-outbuffer)
|
||||
(princ " " my-outbuffer)
|
||||
(eieio-byte-compile-princ-code code my-outbuffer)
|
||||
(princ "))" my-outbuffer))
|
||||
;; Now add this function to the list of known functions.
|
||||
;; Don't bother with a doc string. Not relevant here.
|
||||
(add-to-list 'byte-compile-function-environment
|
||||
(cons meth
|
||||
(eieio-defgeneric-form meth "")))
|
||||
|
||||
;; Remove it from the undefined list if it is there.
|
||||
(let ((elt (assq meth byte-compile-unresolved-functions)))
|
||||
(if elt (setq byte-compile-unresolved-functions
|
||||
(delq elt byte-compile-unresolved-functions))))
|
||||
|
||||
;; nil prevents cruft from appearing in the output buffer.
|
||||
nil))
|
||||
|
||||
(provide 'eieio-comp)
|
||||
|
||||
;;; eieio-comp.el ends here
|
||||
471
lisp/emacs-lisp/eieio-custom.el
Normal file
471
lisp/emacs-lisp/eieio-custom.el
Normal file
|
|
@ -0,0 +1,471 @@
|
|||
;;; eieio-custom.el -- eieio object customization
|
||||
|
||||
;;; Copyright (C) 1999, 2000, 2001, 2005, 2007, 2008, 2009
|
||||
;;; Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: OO, lisp
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This contains support customization of eieio objects. Enabling
|
||||
;; your object to be customizable requires use of the slot attirbute
|
||||
;; `:custom'.
|
||||
|
||||
(require 'eieio)
|
||||
(require 'widget)
|
||||
(require 'wid-edit)
|
||||
(require 'custom)
|
||||
|
||||
;;; Compatibility
|
||||
;;
|
||||
(eval-and-compile
|
||||
(if (featurep 'xemacs)
|
||||
(defalias 'eieio-overlay-lists (lambda () (list (extent-list))))
|
||||
(defalias 'eieio-overlay-lists 'overlay-lists)
|
||||
)
|
||||
)
|
||||
;;; Code:
|
||||
(defclass eieio-widget-test-class nil
|
||||
((a-string :initarg :a-string
|
||||
:initform "The moose is loose"
|
||||
:custom string
|
||||
:label "Amorphous String"
|
||||
:group (default foo)
|
||||
:documentation "A string for testing custom.
|
||||
This is the next line of documentation.")
|
||||
(listostuff :initarg :listostuff
|
||||
:initform ("1" "2" "3")
|
||||
:type list
|
||||
:custom (repeat (string :tag "Stuff"))
|
||||
:label "List of Strings"
|
||||
:group foo
|
||||
:documentation "A list of stuff.")
|
||||
(uninitialized :initarg :uninitialized
|
||||
:type string
|
||||
:custom string
|
||||
:documentation "This slot is not initialized.
|
||||
Used to make sure that custom doesn't barf when it encounters one
|
||||
of these.")
|
||||
(a-number :initarg :a-number
|
||||
:initform 2
|
||||
:custom integer
|
||||
:documentation "A number of thingies."))
|
||||
"A class for testing the widget on.")
|
||||
|
||||
(defcustom eieio-widget-test (eieio-widget-test-class "Foo")
|
||||
"Test variable for editing an object."
|
||||
:type 'object
|
||||
:group 'eieio)
|
||||
|
||||
(defface eieio-custom-slot-tag-face '((((class color)
|
||||
(background dark))
|
||||
(:foreground "light blue"))
|
||||
(((class color)
|
||||
(background light))
|
||||
(:foreground "blue"))
|
||||
(t (:italic t)))
|
||||
"Face used for unpushable variable tags."
|
||||
:group 'custom-faces)
|
||||
|
||||
(defvar eieio-wo nil
|
||||
"Buffer local variable in object customize buffers for the current widget.")
|
||||
(defvar eieio-co nil
|
||||
"Buffer local variable in object customize buffers for the current obj.")
|
||||
(defvar eieio-cog nil
|
||||
"Buffer local variable in object customize buffers for the current group.")
|
||||
|
||||
(defvar eieio-custom-ignore-eieio-co nil
|
||||
"When true, all customizable slots of the current object are updated.
|
||||
Updates occur regardless of the current customization group.")
|
||||
|
||||
(define-widget 'object-slot 'group
|
||||
"Abstractly modify a single slot in an object."
|
||||
:tag "Slot"
|
||||
:format "%t %v%h\n"
|
||||
:convert-widget 'widget-types-convert-widget
|
||||
:value-create 'eieio-slot-value-create
|
||||
:value-get 'eieio-slot-value-get
|
||||
:value-delete 'widget-children-value-delete
|
||||
:validate 'widget-children-validate
|
||||
:match 'eieio-object-match ;; same
|
||||
)
|
||||
|
||||
(defun eieio-slot-value-create (widget)
|
||||
"Create the value of WIDGET."
|
||||
(let ((chil nil)
|
||||
)
|
||||
; (setq chil (cons (widget-create-child-and-convert
|
||||
; widget 'visibility
|
||||
; :help-echo "Hide the value of this option."
|
||||
; :action 'eieio-custom-toggle-parent
|
||||
; t)
|
||||
; chil))
|
||||
(setq chil (cons
|
||||
(widget-create-child-and-convert
|
||||
widget (widget-get widget :childtype)
|
||||
:tag ""
|
||||
:value (widget-get widget :value))
|
||||
chil))
|
||||
(widget-put widget :children chil)))
|
||||
|
||||
(defun eieio-slot-value-get (widget)
|
||||
"Get the value of WIDGET."
|
||||
(widget-value (car (widget-get widget :children))))
|
||||
|
||||
(defun eieio-custom-toggle-hide (widget)
|
||||
"Toggle visibility of WIDGET."
|
||||
(let ((vc (car (widget-get widget :children))))
|
||||
(cond ((eq (widget-get vc :eieio-custom-state) 'hidden)
|
||||
(widget-put vc :eieio-custom-state 'visible)
|
||||
(widget-put vc :value-face (widget-get vc :orig-face)))
|
||||
(t
|
||||
(widget-put vc :eieio-custom-state 'hidden)
|
||||
(widget-put vc :orig-face (widget-get vc :value-face))
|
||||
(widget-put vc :value-face 'invisible)
|
||||
))
|
||||
(widget-value-set vc (widget-value vc))))
|
||||
|
||||
(defun eieio-custom-toggle-parent (widget &rest ignore)
|
||||
"Toggle visibility of parent of WIDGET.
|
||||
Optional argument IGNORE is an extraneous parameter."
|
||||
(eieio-custom-toggle-hide (widget-get widget :parent)))
|
||||
|
||||
(define-widget 'object-edit 'group
|
||||
"Abstractly modify a CLOS object."
|
||||
:tag "Object"
|
||||
:format "%v"
|
||||
:convert-widget 'widget-types-convert-widget
|
||||
:value-create 'eieio-object-value-create
|
||||
:value-get 'eieio-object-value-get
|
||||
:value-delete 'widget-children-value-delete
|
||||
:validate 'widget-children-validate
|
||||
:match 'eieio-object-match
|
||||
:clone-object-children nil
|
||||
)
|
||||
|
||||
(defun eieio-object-match (widget value)
|
||||
"Match info for WIDGET against VALUE."
|
||||
;; Write me
|
||||
t)
|
||||
|
||||
(defun eieio-filter-slot-type (widget slottype)
|
||||
"Filter WIDGETs SLOTTYPE."
|
||||
(if (widget-get widget :clone-object-children)
|
||||
slottype
|
||||
(cond ((eq slottype 'object)
|
||||
'object-edit)
|
||||
((and (listp slottype)
|
||||
(eq (car slottype) 'object))
|
||||
(cons 'object-edit (cdr slottype)))
|
||||
((equal slottype '(repeat object))
|
||||
'(repeat object-edit))
|
||||
((and (listp slottype)
|
||||
(equal (car slottype) 'repeat)
|
||||
(listp (car (cdr slottype)))
|
||||
(equal (car (car (cdr slottype))) 'object))
|
||||
(list 'repeat
|
||||
(cons 'object-edit
|
||||
(cdr (car (cdr slottype))))))
|
||||
(t slottype))))
|
||||
|
||||
(defun eieio-object-value-create (widget)
|
||||
"Create the value of WIDGET."
|
||||
(if (not (widget-get widget :value))
|
||||
(widget-put widget
|
||||
:value (cond ((widget-get widget :objecttype)
|
||||
(funcall (class-constructor
|
||||
(widget-get widget :objecttype))
|
||||
"Custom-new"))
|
||||
((widget-get widget :objectcreatefcn)
|
||||
(funcall (widget-get widget :objectcreatefcn)))
|
||||
(t (error "No create method specified")))))
|
||||
(let* ((chil nil)
|
||||
(obj (widget-get widget :value))
|
||||
(master-group (widget-get widget :eieio-group))
|
||||
(cv (class-v (object-class-fast obj)))
|
||||
(slots (aref cv class-public-a))
|
||||
(flabel (aref cv class-public-custom-label))
|
||||
(fgroup (aref cv class-public-custom-group))
|
||||
(fdoc (aref cv class-public-doc))
|
||||
(fcust (aref cv class-public-custom)))
|
||||
;; First line describes the object, but may not editable.
|
||||
(if (widget-get widget :eieio-show-name)
|
||||
(setq chil (cons (widget-create-child-and-convert
|
||||
widget 'string :tag "Object "
|
||||
:sample-face 'bold
|
||||
(object-name-string obj))
|
||||
chil)))
|
||||
;; Display information about the group being shown
|
||||
(when master-group
|
||||
(let ((groups (class-option (object-class-fast obj) :custom-groups)))
|
||||
(widget-insert "Groups:")
|
||||
(while groups
|
||||
(widget-insert " ")
|
||||
(if (eq (car groups) master-group)
|
||||
(widget-insert "*" (capitalize (symbol-name master-group)) "*")
|
||||
(widget-create 'push-button
|
||||
:thing (cons obj (car groups))
|
||||
:notify (lambda (widget &rest stuff)
|
||||
(eieio-customize-object
|
||||
(car (widget-get widget :thing))
|
||||
(cdr (widget-get widget :thing))))
|
||||
(capitalize (symbol-name (car groups)))))
|
||||
(setq groups (cdr groups)))
|
||||
(widget-insert "\n\n")))
|
||||
;; Loop over all the slots, creating child widgets.
|
||||
(while slots
|
||||
;; Output this slot if it has a customize flag associated with it.
|
||||
(when (and (car fcust)
|
||||
(or (not master-group) (member master-group (car fgroup)))
|
||||
(slot-boundp obj (car slots)))
|
||||
;; In this case, this slot has a custom type. Create it's
|
||||
;; children widgets.
|
||||
(let ((type (eieio-filter-slot-type widget (car fcust)))
|
||||
(stuff nil))
|
||||
;; This next bit is an evil hack to get some EDE functions
|
||||
;; working the way I like.
|
||||
(if (and (listp type)
|
||||
(setq stuff (member :slotofchoices type)))
|
||||
(let ((choices (eieio-oref obj (car (cdr stuff))))
|
||||
(newtype nil))
|
||||
(while (not (eq (car type) :slotofchoices))
|
||||
(setq newtype (cons (car type) newtype)
|
||||
type (cdr type)))
|
||||
(while choices
|
||||
(setq newtype (cons (list 'const (car choices))
|
||||
newtype)
|
||||
choices (cdr choices)))
|
||||
(setq type (nreverse newtype))))
|
||||
(setq chil (cons (widget-create-child-and-convert
|
||||
widget 'object-slot
|
||||
:childtype type
|
||||
:sample-face 'eieio-custom-slot-tag-face
|
||||
:tag
|
||||
(concat
|
||||
(make-string
|
||||
(or (widget-get widget :indent) 0)
|
||||
? )
|
||||
(if (car flabel)
|
||||
(car flabel)
|
||||
(let ((s (symbol-name
|
||||
(or
|
||||
(class-slot-initarg
|
||||
(object-class-fast obj)
|
||||
(car slots))
|
||||
(car slots)))))
|
||||
(capitalize
|
||||
(if (string-match "^:" s)
|
||||
(substring s (match-end 0))
|
||||
s)))))
|
||||
:value (slot-value obj (car slots))
|
||||
:doc (if (car fdoc) (car fdoc)
|
||||
"Slot not Documented.")
|
||||
:eieio-custom-visibility 'visible
|
||||
)
|
||||
chil))
|
||||
)
|
||||
)
|
||||
(setq slots (cdr slots)
|
||||
fdoc (cdr fdoc)
|
||||
fcust (cdr fcust)
|
||||
flabel (cdr flabel)
|
||||
fgroup (cdr fgroup)))
|
||||
(widget-put widget :children (nreverse chil))
|
||||
))
|
||||
|
||||
(defun eieio-object-value-get (widget)
|
||||
"Get the value of WIDGET."
|
||||
(let* ((obj (widget-get widget :value))
|
||||
(master-group eieio-cog)
|
||||
(cv (class-v (object-class-fast obj)))
|
||||
(fgroup (aref cv class-public-custom-group))
|
||||
(wids (widget-get widget :children))
|
||||
(name (if (widget-get widget :eieio-show-name)
|
||||
(car (widget-apply (car wids) :value-inline))
|
||||
nil))
|
||||
(chil (if (widget-get widget :eieio-show-name)
|
||||
(nthcdr 1 wids) wids))
|
||||
(cv (class-v (object-class-fast obj)))
|
||||
(slots (aref cv class-public-a))
|
||||
(fcust (aref cv class-public-custom)))
|
||||
;; If there are any prefix widgets, clear them.
|
||||
;; -- None yet
|
||||
;; Create a batch of initargs for each slot.
|
||||
(while (and slots chil)
|
||||
(if (and (car fcust)
|
||||
(or eieio-custom-ignore-eieio-co
|
||||
(not master-group) (member master-group (car fgroup)))
|
||||
(slot-boundp obj (car slots)))
|
||||
(progn
|
||||
;; Only customized slots have widgets
|
||||
(let ((eieio-custom-ignore-eieio-co t))
|
||||
(eieio-oset obj (car slots)
|
||||
(car (widget-apply (car chil) :value-inline))))
|
||||
(setq chil (cdr chil))))
|
||||
(setq slots (cdr slots)
|
||||
fgroup (cdr fgroup)
|
||||
fcust (cdr fcust)))
|
||||
;; Set any name updates on it.
|
||||
(if name (aset obj object-name name))
|
||||
;; This is the same object we had before.
|
||||
obj))
|
||||
|
||||
(defmethod eieio-done-customizing ((obj eieio-default-superclass))
|
||||
"When a applying change to a widget, call this method.
|
||||
This method is called by the default widget-edit commands. User made
|
||||
commands should also call this method when applying changes.
|
||||
Argument OBJ is the object that has been customized."
|
||||
nil)
|
||||
|
||||
(defun customize-object (obj &optional group)
|
||||
"Customize OBJ in a custom buffer.
|
||||
Optional argument GROUP is the sub-group of slots to display."
|
||||
(eieio-customize-object obj group))
|
||||
|
||||
(defmethod eieio-customize-object ((obj eieio-default-superclass)
|
||||
&optional group)
|
||||
"Customize OBJ in a specialized custom buffer.
|
||||
To override call the `eieio-custom-widget-insert' to just insert the
|
||||
object widget.
|
||||
Optional argument GROUP specifies a subgroup of slots to edit as a symbol.
|
||||
These groups are specified with the `:group' slot flag."
|
||||
;; Insert check for multiple edits here.
|
||||
(let* ((g (or group 'default)))
|
||||
(switch-to-buffer (get-buffer-create
|
||||
(concat "*CUSTOMIZE "
|
||||
(object-name obj) " "
|
||||
(symbol-name g) "*")))
|
||||
(toggle-read-only -1)
|
||||
(kill-all-local-variables)
|
||||
(erase-buffer)
|
||||
(let ((all (eieio-overlay-lists)))
|
||||
;; Delete all the overlays.
|
||||
(mapc 'delete-overlay (car all))
|
||||
(mapc 'delete-overlay (cdr all)))
|
||||
;; Add an apply reset option at the top of the buffer.
|
||||
(eieio-custom-object-apply-reset obj)
|
||||
(widget-insert "\n\n")
|
||||
(widget-insert "Edit object " (object-name obj) "\n\n")
|
||||
;; Create the widget editing the object.
|
||||
(make-local-variable 'eieio-wo)
|
||||
(setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g))
|
||||
;;Now generate the apply buttons
|
||||
(widget-insert "\n")
|
||||
(eieio-custom-object-apply-reset obj)
|
||||
;; Now initialize the buffer
|
||||
(use-local-map widget-keymap)
|
||||
(widget-setup)
|
||||
;;(widget-minor-mode)
|
||||
(goto-char (point-min))
|
||||
(widget-forward 3)
|
||||
(make-local-variable 'eieio-co)
|
||||
(setq eieio-co obj)
|
||||
(make-local-variable 'eieio-cog)
|
||||
(setq eieio-cog group)))
|
||||
|
||||
(defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass))
|
||||
"Insert an Apply and Reset button into the object editor.
|
||||
Argument OBJ os the object being customized."
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
(widget-apply eieio-wo :value-get)
|
||||
(eieio-done-customizing eieio-co)
|
||||
(bury-buffer))
|
||||
"Accept")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
;; I think the act of getting it sets
|
||||
;; it's value through the get function.
|
||||
(message "Applying Changes...")
|
||||
(widget-apply eieio-wo :value-get)
|
||||
(eieio-done-customizing eieio-co)
|
||||
(message "Applying Changes...Done."))
|
||||
"Apply")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
(message "Resetting.")
|
||||
(eieio-customize-object eieio-co eieio-cog))
|
||||
"Reset")
|
||||
(widget-insert " ")
|
||||
(widget-create 'push-button
|
||||
:notify (lambda (&rest ignore)
|
||||
(bury-buffer))
|
||||
"Cancel"))
|
||||
|
||||
(defmethod eieio-custom-widget-insert ((obj eieio-default-superclass)
|
||||
&rest flags)
|
||||
"Insert the widget used for editing object OBJ in the current buffer.
|
||||
Arguments FLAGS are widget compatible flags.
|
||||
Must return the created widget."
|
||||
(apply 'widget-create 'object-edit :value obj flags))
|
||||
|
||||
(define-widget 'object 'object-edit
|
||||
"Instance of a CLOS class."
|
||||
:format "%{%t%}:\n%v"
|
||||
:value-to-internal 'eieio-object-value-to-abstract
|
||||
:value-to-external 'eieio-object-abstract-to-value
|
||||
:clone-object-children t
|
||||
)
|
||||
|
||||
(defun eieio-object-value-to-abstract (widget value)
|
||||
"For WIDGET, convert VALUE to an abstract /safe/ representation."
|
||||
(if (eieio-object-p value) value
|
||||
(if (null value) value
|
||||
nil)))
|
||||
|
||||
(defun eieio-object-abstract-to-value (widget value)
|
||||
"For WIDGET, convert VALUE from an abstract /safe/ representation."
|
||||
value)
|
||||
|
||||
|
||||
;;; customization group functions
|
||||
;;
|
||||
;; These functions provide the ability to create dynamic menus to
|
||||
;; customize specific sections of an object. They do not hook directly
|
||||
;; into a filter, but can be used to create easymenu vectors.
|
||||
(defmethod eieio-customize-object-group ((obj eieio-default-superclass))
|
||||
"Create a list of vectors for customizing sections of OBJ."
|
||||
(mapcar (lambda (group)
|
||||
(vector (concat "Group " (symbol-name group))
|
||||
(list 'customize-object obj (list 'quote group))
|
||||
t))
|
||||
(class-option (object-class-fast obj) :custom-groups)))
|
||||
|
||||
(defvar eieio-read-custom-group-history nil
|
||||
"History for the custom group reader.")
|
||||
|
||||
(defmethod eieio-read-customization-group ((obj eieio-default-superclass))
|
||||
"Do a completing read on the name of a customization group in OBJ.
|
||||
Return the symbol for the group, or nil"
|
||||
(let ((g (class-option (object-class-fast obj) :custom-groups)))
|
||||
(if (= (length g) 1)
|
||||
(car g)
|
||||
;; Make the association list
|
||||
(setq g (mapcar (lambda (g) (cons (symbol-name g) g)) g))
|
||||
(cdr (assoc
|
||||
(completing-read (concat (oref obj name) " Custom Group: ")
|
||||
g nil t nil 'eieio-read-custom-group-history)
|
||||
g)))))
|
||||
|
||||
(provide 'eieio-custom)
|
||||
|
||||
;;; eieio-custom.el ends here
|
||||
151
lisp/emacs-lisp/eieio-datadebug.el
Normal file
151
lisp/emacs-lisp/eieio-datadebug.el
Normal file
|
|
@ -0,0 +1,151 @@
|
|||
;;; eieio-datadebug.el --- EIEIO extensions to the data debugger.
|
||||
|
||||
;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Keywords: OO, lisp
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; Extensions to data-debug for EIEIO objects.
|
||||
;;
|
||||
|
||||
(require 'eieio)
|
||||
(require 'data-debug)
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defun data-debug-insert-object-slots (object prefix)
|
||||
"Insert all the slots of OBJECT.
|
||||
PREFIX specifies what to insert at the start of each line."
|
||||
(let ((attrprefix (concat (make-string (length prefix) ? ) "] "))
|
||||
)
|
||||
(data-debug/eieio-insert-slots object attrprefix)
|
||||
)
|
||||
)
|
||||
|
||||
(defun data-debug-insert-object-slots-from-point (point)
|
||||
"Insert the object slots found at the object button at POINT."
|
||||
(let ((object (get-text-property point 'ddebug))
|
||||
(indent (get-text-property point 'ddebug-indent))
|
||||
start
|
||||
)
|
||||
(end-of-line)
|
||||
(setq start (point))
|
||||
(forward-char 1)
|
||||
(data-debug-insert-object-slots object
|
||||
(concat (make-string indent ? )
|
||||
"~ "))
|
||||
(goto-char start)
|
||||
))
|
||||
|
||||
(defun data-debug-insert-object-button (object prefix prebuttontext)
|
||||
"Insert a button representing OBJECT.
|
||||
PREFIX is the text that preceeds the button.
|
||||
PREBUTTONTEXT is some text between PREFIX and the object button."
|
||||
(let ((start (point))
|
||||
(end nil)
|
||||
(str (object-print object))
|
||||
(tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
|
||||
(object-name-string object)
|
||||
(object-class object)
|
||||
(class-parents (object-class object))
|
||||
(length (object-slots object))
|
||||
))
|
||||
)
|
||||
(insert prefix prebuttontext str)
|
||||
(setq end (point))
|
||||
(put-text-property (- end (length str)) end 'face 'font-lock-keyword-face)
|
||||
(put-text-property start end 'ddebug object)
|
||||
(put-text-property start end 'ddebug-indent(length prefix))
|
||||
(put-text-property start end 'ddebug-prefix prefix)
|
||||
(put-text-property start end 'help-echo tip)
|
||||
(put-text-property start end 'ddebug-function
|
||||
'data-debug-insert-object-slots-from-point)
|
||||
(insert "\n")
|
||||
)
|
||||
)
|
||||
|
||||
;;; METHODS
|
||||
;;
|
||||
;; Each object should have an opportunity to show stuff about itself.
|
||||
|
||||
(defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
|
||||
prefix)
|
||||
"Insert the slots of OBJ into the current DDEBUG buffer."
|
||||
(data-debug-insert-thing (object-name-string obj)
|
||||
prefix
|
||||
"Name: ")
|
||||
(let* ((cl (object-class obj))
|
||||
(cv (class-v cl)))
|
||||
(data-debug-insert-thing (class-constructor cl)
|
||||
prefix
|
||||
"Class: ")
|
||||
;; Loop over all the public slots
|
||||
(let ((publa (aref cv class-public-a))
|
||||
(publd (aref cv class-public-d))
|
||||
)
|
||||
(while publa
|
||||
(if (slot-boundp obj (car publa))
|
||||
(let ((i (class-slot-initarg cl (car publa)))
|
||||
(v (eieio-oref obj (car publa))))
|
||||
(data-debug-insert-thing
|
||||
v prefix (concat
|
||||
(if i (symbol-name i)
|
||||
(symbol-name (car publa)))
|
||||
" ")))
|
||||
;; Unbound case
|
||||
(let ((i (class-slot-initarg cl (car publa))))
|
||||
(data-debug-insert-custom
|
||||
"#unbound" prefix
|
||||
(concat (if i (symbol-name i)
|
||||
(symbol-name (car publa)))
|
||||
" ")
|
||||
'font-lock-keyword-face))
|
||||
)
|
||||
(setq publa (cdr publa) publd (cdr publd)))
|
||||
)))
|
||||
|
||||
;;; DEBUG METHODS
|
||||
;;
|
||||
;; A generic function to run DDEBUG on an object and popup a new buffer.
|
||||
;;
|
||||
(defmethod data-debug-show ((obj eieio-default-superclass))
|
||||
"Run ddebug against any EIEIO object OBJ"
|
||||
(data-debug-new-buffer (format "*%s DDEBUG*" (object-name obj)))
|
||||
(data-debug-insert-object-slots obj "]"))
|
||||
|
||||
;;; DEBUG FUNCTIONS
|
||||
;;
|
||||
(defun eieio-debug-methodinvoke (method class)
|
||||
"Show the method invocation order for METHOD with CLASS object."
|
||||
(interactive "aMethod: \nXClass Expression: ")
|
||||
(let* ((eieio-pre-method-execution-hooks
|
||||
(lambda (l) (throw 'moose l) ))
|
||||
(data
|
||||
(catch 'moose (eieio-generic-call
|
||||
method (list class))))
|
||||
(buf (data-debug-new-buffer "*Method Invocation*"))
|
||||
(data2 (mapcar (lambda (sym)
|
||||
(symbol-function (car sym)))
|
||||
data)))
|
||||
(data-debug-insert-thing data2 ">" "")))
|
||||
|
||||
(provide 'eieio-datadebug)
|
||||
|
||||
;;; eieio-datadebug.el ends here
|
||||
368
lisp/emacs-lisp/eieio-doc.el
Normal file
368
lisp/emacs-lisp/eieio-doc.el
Normal file
|
|
@ -0,0 +1,368 @@
|
|||
;;; eieio-doc.el --- create texinfo documentation for an eieio class
|
||||
|
||||
;;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2004, 2005
|
||||
;;; Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: OO, lisp, docs
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; Outputs into the current buffer documentation in texinfo format
|
||||
|
||||
(require 'eieio-opt)
|
||||
|
||||
;; for a class, all it's children, and all it's slots.
|
||||
|
||||
;;; Code:
|
||||
(defvar eieiodoc-currently-in-node nil
|
||||
"String representing the node we go BACK to.")
|
||||
|
||||
(defvar eieiodoc-current-section-level nil
|
||||
"String represending what type of section header to use.")
|
||||
|
||||
(defvar eieiodoc-prev-class nil
|
||||
"Non-nil when while `eieiodoc-recurse' is running.
|
||||
Can be referenced from the recursed function.")
|
||||
|
||||
(defvar eieiodoc-next-class nil
|
||||
"Non-nil when `eieiodoc-recurse' is running.
|
||||
Can be referenced from the recursed function.")
|
||||
|
||||
(defun eieiodoc-class-nuke (root-class indexstring &optional skiplist)
|
||||
"Call `eieiodoc-class' after nuking everything from POINT on.
|
||||
ROOT-CLASS, INDEXSTRING, and SKIPLIST are the same as `eieiodoc-class'."
|
||||
(delete-region (point) (point-max))
|
||||
(sit-for 0)
|
||||
(eieiodoc-class root-class indexstring skiplist))
|
||||
|
||||
(defvar eieiodoc--class-indexstring)
|
||||
(defvar eieiodoc--class-root)
|
||||
|
||||
(defun eieiodoc-class (root-class indexstring &optional skiplist)
|
||||
"Create documentation starting with ROOT-CLASS.
|
||||
The first job is to create an indented menu of all the classes
|
||||
starting with `root-class' and including all it's children. Once this
|
||||
is done, @nodes are created for all the subclasses. Each node is then
|
||||
documented with a description of the class, a brief inheritance tree
|
||||
\(with xrefs) and a list of all slots in a big table. Where each slot
|
||||
is inherited from is also documented. In addition, each class is
|
||||
documented in the index referenced by INDEXSTRING, a two letter code
|
||||
described in the texinfo manual.
|
||||
|
||||
The optional third argument SKIPLIST is a list of object not to put
|
||||
into any menus, nodes or lists."
|
||||
(interactive
|
||||
(list (intern-soft
|
||||
(completing-read "Class: " (eieio-build-class-alist) nil t))
|
||||
(read-string "Index name (2 chars): ")))
|
||||
(if (looking-at "[ \t\n]+@end ignore")
|
||||
(goto-char (match-end 0)))
|
||||
(save-excursion
|
||||
(setq eieiodoc-currently-in-node
|
||||
(if (re-search-backward "@node \\([^,]+\\)" nil t)
|
||||
(buffer-substring (match-beginning 1) (match-end 1))
|
||||
"Top")
|
||||
eieiodoc-current-section-level
|
||||
(if (re-search-forward "@\\(chapter\\|\\(sub\\)*section\\)"
|
||||
(+ (point) 500) t)
|
||||
(progn
|
||||
(goto-char (match-beginning 0))
|
||||
(cond ((looking-at "@chapter") "section")
|
||||
((looking-at "@section") "subsection")
|
||||
((looking-at "@\\(sub\\)+section") "subsubsection")
|
||||
(t "subsubsection")))
|
||||
"subsubsection")))
|
||||
(save-excursion
|
||||
(eieiodoc-main-menu root-class skiplist)
|
||||
(insert "\n")
|
||||
(let ((eieiodoc--class-indexstring indexstring)
|
||||
(eieiodoc--class-root root-class))
|
||||
(eieiodoc-recurse root-class 'eieiodoc-one-node nil skiplist))))
|
||||
|
||||
(defun eieiodoc-main-menu (class skiplist)
|
||||
"Create a menu of all classes under CLASS indented the correct amount.
|
||||
SKIPLIST is a list of objects to skip"
|
||||
(end-of-line)
|
||||
(insert "\n@menu\n")
|
||||
(eieiodoc-recurse class (lambda (class level)
|
||||
(insert "* " (make-string level ? )
|
||||
(symbol-name class) " ::\n"))
|
||||
nil skiplist)
|
||||
(insert "@end menu\n"))
|
||||
|
||||
(defun eieiodoc-one-node (class level)
|
||||
"Create a node for CLASS, and for all subclasses of CLASS in order.
|
||||
This function should only be called by `eieiodoc-class'
|
||||
Argument LEVEL is the current level of recursion we have hit."
|
||||
(message "Building node for %s" class)
|
||||
(insert "\n@node " (symbol-name class) ", "
|
||||
(if eieiodoc-next-class (symbol-name eieiodoc-next-class) " ") ", "
|
||||
(if eieiodoc-prev-class (symbol-name eieiodoc-prev-class) " ") ", "
|
||||
eieiodoc-currently-in-node "\n"
|
||||
"@comment node-name, next, previous, up\n"
|
||||
"@" eieiodoc-current-section-level " " (symbol-name class) "\n"
|
||||
"@" eieiodoc--class-indexstring
|
||||
"index " (symbol-name class) "\n\n")
|
||||
;; Now lets create a nifty little inheritance tree
|
||||
(let ((cl class)
|
||||
(revlist nil)
|
||||
(depth 0))
|
||||
(while cl
|
||||
(setq revlist (cons cl revlist)
|
||||
cl (class-parent cl)))
|
||||
(insert "@table @asis\n@item Inheritance Tree:\n")
|
||||
(while revlist
|
||||
(insert "@table @code\n@item "
|
||||
(if (and (child-of-class-p (car revlist) eieiodoc--class-root)
|
||||
(not (eq class (car revlist))))
|
||||
(concat "@w{@xref{" (symbol-name (car revlist)) "}.}")
|
||||
(symbol-name (car revlist)))
|
||||
"\n")
|
||||
(setq revlist (cdr revlist)
|
||||
depth (1+ depth)))
|
||||
(let ((clist (reverse (aref (class-v class) class-children))))
|
||||
(if (not clist)
|
||||
(insert "No children")
|
||||
(insert "@table @asis\n@item Children:\n")
|
||||
(while clist
|
||||
(insert "@w{@xref{" (symbol-name (car clist)) "}")
|
||||
(if (cdr clist) (insert ",") (insert "."))
|
||||
(insert "} ")
|
||||
(setq clist (cdr clist)))
|
||||
(insert "\n@end table\n")
|
||||
))
|
||||
(while (> depth 0)
|
||||
(insert "\n@end table\n")
|
||||
(setq depth (1- depth)))
|
||||
(insert "@end table\n\n "))
|
||||
;; Now lets build some documentation by extracting information from
|
||||
;; the class description vector
|
||||
(let* ((cv (class-v class))
|
||||
(docs (aref cv class-public-doc))
|
||||
(names (aref cv class-public-a))
|
||||
(deflt (aref cv class-public-d))
|
||||
(prot (aref cv class-protection))
|
||||
(typev (aref cv class-public-type))
|
||||
(i 0)
|
||||
(set-one nil)
|
||||
(anchor nil)
|
||||
)
|
||||
;; doc of the class itself
|
||||
(insert (eieiodoc-texify-docstring (documentation class) class)
|
||||
"\n\n@table @asis\n")
|
||||
(if names
|
||||
(progn
|
||||
(setq anchor (point))
|
||||
(insert "@item Slots:\n\n@table @code\n")
|
||||
(while names
|
||||
(if (eieiodoc-one-attribute class (car names) (car docs)
|
||||
(car prot) (car deflt) (aref typev i))
|
||||
(setq set-one t))
|
||||
(setq names (cdr names)
|
||||
docs (cdr docs)
|
||||
prot (cdr prot)
|
||||
deflt (cdr deflt)
|
||||
i (1+ i)))
|
||||
(insert "@end table\n\n")
|
||||
(if (not set-one) (delete-region (point) anchor))
|
||||
))
|
||||
(insert "@end table\n")
|
||||
;; Finally, document all the methods associated with this class.
|
||||
(let ((methods (eieio-all-generic-functions class))
|
||||
(doc nil))
|
||||
(if (not methods) nil
|
||||
(if (string= eieiodoc-current-section-level "subsubsection")
|
||||
(insert "@" eieiodoc-current-section-level)
|
||||
(insert "@sub" eieiodoc-current-section-level))
|
||||
(insert " Specialized Methods\n\n")
|
||||
(while methods
|
||||
(setq doc (eieio-method-documentation (car methods) class))
|
||||
(insert "@deffn Method " (symbol-name (car methods)))
|
||||
(if (not doc)
|
||||
(insert "\n Undocumented")
|
||||
(if (car doc)
|
||||
(progn
|
||||
(insert " :BEFORE ")
|
||||
(eieiodoc-output-deffn-args (car (car doc)))
|
||||
(insert "\n")
|
||||
(eieiodoc-insert-and-massage-docstring-with-args
|
||||
(cdr (car doc)) (car (car doc)) class)))
|
||||
(setq doc (cdr doc))
|
||||
(if (car doc)
|
||||
(progn
|
||||
(insert " :PRIMARY ")
|
||||
(eieiodoc-output-deffn-args (car (car doc)))
|
||||
(insert "\n")
|
||||
(eieiodoc-insert-and-massage-docstring-with-args
|
||||
(cdr (car doc)) (car (car doc)) class)))
|
||||
(setq doc (cdr doc))
|
||||
(if (car doc)
|
||||
(progn
|
||||
(insert " :AFTER ")
|
||||
(eieiodoc-output-deffn-args (car (car doc)))
|
||||
(insert "\n")
|
||||
(eieiodoc-insert-and-massage-docstring-with-args
|
||||
(cdr (car doc)) (car (car doc)) class)))
|
||||
(insert "\n@end deffn\n\n"))
|
||||
(setq methods (cdr methods)))))
|
||||
))
|
||||
|
||||
(defun eieiodoc-insert-and-massage-docstring-with-args (doc arglst class)
|
||||
"Update DOC with texinfo strings using ARGLST with @var.
|
||||
Argument CLASS is the class passed to `eieiodoc-texify-docstring'."
|
||||
(let ((start (point))
|
||||
(end nil)
|
||||
(case-fold-search nil))
|
||||
;; Insert the text
|
||||
(insert (eieiodoc-texify-docstring doc class))
|
||||
(setq end (point))
|
||||
(save-restriction
|
||||
(narrow-to-region start end)
|
||||
(save-excursion
|
||||
;; Now find arguments
|
||||
(while arglst
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward (upcase (symbol-name (car arglst))) nil t)
|
||||
(replace-match "@var{\\&}" t))
|
||||
(setq arglst (cdr arglst)))))))
|
||||
|
||||
(defun eieiodoc-output-deffn-args (arglst)
|
||||
"Output ARGLST for a deffn."
|
||||
(while arglst
|
||||
(insert (symbol-name (car arglst)) " ")
|
||||
(setq arglst (cdr arglst))))
|
||||
|
||||
(defun eieiodoc-one-attribute (class attribute doc priv deflt type)
|
||||
"Create documentation of CLASS for a single ATTRIBUTE.
|
||||
Assume this attribute is inside a table, so it is initiated with the
|
||||
@item indicator. If this attribute is not inserted (because it is
|
||||
contained in the parent) then return nil, else return t.
|
||||
DOC is the documentation to use, PRIV is non-nil if it is a private slot,
|
||||
and DEFLT is the default value. TYPE is the symbol describing what type
|
||||
validation is done on that slot."
|
||||
(let ((pv (eieiodoc-parent-diff class attribute))
|
||||
(ia (eieio-attribute-to-initarg class attribute))
|
||||
(set-me nil))
|
||||
(if (or (eq pv t) (not ia))
|
||||
nil ;; same in parent or no init arg
|
||||
(setq set-me t)
|
||||
(insert "@item " (if priv "Private: " "")
|
||||
(symbol-name ia))
|
||||
(if (and type (not (eq type t)))
|
||||
(insert "\nType: @code{" (format "%S" type) "}"))
|
||||
(if (not (eq deflt eieio-unbound))
|
||||
(insert " @*\nDefault Value: @code{"(format "%S" deflt) "}"))
|
||||
(insert "\n\n")
|
||||
(if (eq pv 'default)
|
||||
;; default differs only, xref the parent
|
||||
;; This should be upgraded to actually search for the last
|
||||
;; differing default (or the original.)
|
||||
(insert "@xref{" (symbol-name (class-parent class)) "}.\n")
|
||||
(insert (if doc (eieiodoc-texify-docstring doc class) "Not Documented")
|
||||
"\n@refill\n\n")))
|
||||
set-me))
|
||||
;;;
|
||||
;; Utilities
|
||||
;;
|
||||
(defun eieiodoc-recurse (rclass func &optional level skiplist)
|
||||
"Recurse down all children of RCLASS, calling FUNC on each one.
|
||||
LEVEL indicates the current depth below the first call we are. The
|
||||
function FUNC will be called with RCLASS and LEVEL. This will then
|
||||
recursivly call itself once for each child class of RCLASS. The
|
||||
optional fourth argument SKIPLIST is a list of objects to ignore while
|
||||
recursing."
|
||||
|
||||
(if (not level) (setq level 0))
|
||||
|
||||
;; we reverse the children so they appear in the same order as it
|
||||
;; does in the code that creates them.
|
||||
(let* ((children (reverse (aref (class-v rclass) class-children)))
|
||||
(ocnc eieiodoc-next-class)
|
||||
(eieiodoc-next-class (or (car children) ocnc))
|
||||
(eieiodoc-prev-class eieiodoc-prev-class))
|
||||
|
||||
(if (not (member rclass skiplist))
|
||||
(progn
|
||||
(apply func (list rclass level))
|
||||
|
||||
(setq eieiodoc-prev-class rclass)))
|
||||
|
||||
(while children
|
||||
(setq eieiodoc-next-class (or (car (cdr children)) ocnc))
|
||||
(setq eieiodoc-prev-class (eieiodoc-recurse (car children) func (1+ level)))
|
||||
(setq children (cdr children)))
|
||||
;; return the previous class so that the prev/next node gets it right
|
||||
eieiodoc-prev-class))
|
||||
|
||||
(defun eieiodoc-parent-diff (class slot)
|
||||
"Return nil if the parent of CLASS does not have slot SLOT.
|
||||
Return t if it does, and return 'default if the default has changed."
|
||||
(let ((df nil) (err t)
|
||||
(scoped-class (class-parent class))
|
||||
(eieio-skip-typecheck))
|
||||
(condition-case nil
|
||||
(setq df (eieio-oref-default (class-parent class) slot)
|
||||
err nil)
|
||||
(invalid-slot-name (setq df nil))
|
||||
(error (setq df nil)))
|
||||
(if err
|
||||
nil
|
||||
(if (equal df (eieio-oref-default class slot))
|
||||
t
|
||||
'default))))
|
||||
|
||||
(defun eieiodoc-texify-docstring (string class)
|
||||
"Take STRING, (a normal doc string), and convert it into a texinfo string.
|
||||
For instances where CLASS is the class being referenced, do not Xref
|
||||
that class.
|
||||
|
||||
`function' => @dfn{function}
|
||||
`variable' => @code{variable}
|
||||
`class' => @code{class} @xref{class}
|
||||
`unknown' => @code{unknonwn}
|
||||
'quoteme => @code{quoteme}
|
||||
non-nil => non-@code{nil}
|
||||
t => @code{t}
|
||||
:tag => @code{:tag}
|
||||
[ stuff ] => @code{[ stuff ]}
|
||||
Key => @kbd{Key}"
|
||||
(while (string-match "`\\([-a-zA-Z0-9]+\\)'" string)
|
||||
(let* ((vs (substring string (match-beginning 1) (match-end 1)))
|
||||
(v (intern-soft vs)))
|
||||
(setq string
|
||||
(concat
|
||||
(replace-match (concat
|
||||
(if (and (not (class-p v))(fboundp v))
|
||||
"@dfn{" "@code{")
|
||||
vs "}"
|
||||
(if (and (class-p v) (not (eq v class)))
|
||||
(concat " @xref{" vs "}.")))
|
||||
nil t string)))))
|
||||
(while (string-match "\\( \\|^\\|-\\)\\(nil\\|t\\|'[-a-zA-Z0-9]+\\|:[-a-zA-Z0-9]+\\)\\([ ,]\\|$\\)" string)
|
||||
(setq string (replace-match "@code{\\2}" t nil string 2)))
|
||||
(while (string-match "\\( \\|^\\)\\(\\[[^]]+\\]\\)\\( \\|$\\)" string)
|
||||
(setq string (replace-match "@code{\\2}" t nil string 2)))
|
||||
(while (string-match "\\( \\|^\\)\\(\\(\\(C-\\|M-\\|S-\\)+\\([^ \t\n]\\|RET\\|SPC\\|TAB\\)\\)\\|\\(RET\\|SPC\\|TAB\\)\\)\\( \\|$\\)" string)
|
||||
(setq string (replace-match "@kbd{\\2}" t nil string 2)))
|
||||
string)
|
||||
|
||||
(provide 'eieio-doc)
|
||||
|
||||
;;; eieio-doc.el ends here
|
||||
699
lisp/emacs-lisp/eieio-opt.el
Normal file
699
lisp/emacs-lisp/eieio-opt.el
Normal file
|
|
@ -0,0 +1,699 @@
|
|||
;;; eieio-opt.el -- eieio optional functions (debug, printing, speedbar)
|
||||
|
||||
;;; Copyright (C) 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005,
|
||||
;;; 2008, 2009 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: OO, lisp
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This contains support functions to eieio. These functions contain
|
||||
;; some small class browser and class printing functions.
|
||||
;;
|
||||
|
||||
(require 'eieio)
|
||||
|
||||
;;; Code:
|
||||
(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
|
||||
variable `eieio-default-superclass'."
|
||||
(interactive (if current-prefix-arg
|
||||
(list (read (completing-read "Class: "
|
||||
(eieio-build-class-alist)
|
||||
nil t)))
|
||||
nil))
|
||||
(if (not root-class) (setq root-class 'eieio-default-superclass))
|
||||
(if (not (class-p root-class)) (signal 'wrong-type-argument (list 'class-p root-class)))
|
||||
(display-buffer (get-buffer-create "*EIEIO OBJECT BROWSE*") t)
|
||||
(save-excursion
|
||||
(set-buffer (get-buffer "*EIEIO OBJECT BROWSE*"))
|
||||
(erase-buffer)
|
||||
(goto-char 0)
|
||||
(eieio-browse-tree root-class "" "")
|
||||
))
|
||||
|
||||
(defun eieio-browse-tree (this-root prefix ch-prefix)
|
||||
"Recursively, draws the children of the given class on the screen.
|
||||
Argument THIS-ROOT is the local root of the tree.
|
||||
Argument PREFIX is the character prefix to use.
|
||||
Argument CH-PREFIX is another character prefix to display."
|
||||
(if (not (class-p (eval this-root))) (signal 'wrong-type-argument (list 'class-p this-root)))
|
||||
(let ((myname (symbol-name this-root))
|
||||
(chl (aref (class-v this-root) class-children))
|
||||
(fprefix (concat ch-prefix " +--"))
|
||||
(mprefix (concat ch-prefix " | "))
|
||||
(lprefix (concat ch-prefix " ")))
|
||||
(insert prefix myname "\n")
|
||||
(while (cdr chl)
|
||||
(eieio-browse-tree (car chl) fprefix mprefix)
|
||||
(setq chl (cdr chl)))
|
||||
(if chl
|
||||
(eieio-browse-tree (car chl) fprefix lprefix))
|
||||
))
|
||||
|
||||
;;; CLASS COMPLETION / DOCUMENTATION
|
||||
;;;###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 obect.
|
||||
Optional HEADERFCN should be called to insert a few bits of info first."
|
||||
(interactive (list (eieio-read-class "Class: ")))
|
||||
(with-output-to-temp-buffer (help-buffer) ;"*Help*"
|
||||
(help-setup-xref (list #'eieio-describe-class class headerfcn)
|
||||
(interactive-p))
|
||||
|
||||
(when headerfcn (funcall headerfcn))
|
||||
|
||||
(if (class-option class :abstract)
|
||||
(princ "Abstract "))
|
||||
(princ "Class ")
|
||||
(prin1 class)
|
||||
(terpri)
|
||||
;; Inheritence tree information
|
||||
(let ((pl (class-parents class)))
|
||||
(when pl
|
||||
(princ " Inherits from ")
|
||||
(while pl
|
||||
(princ "`") (prin1 (car pl)) (princ "'")
|
||||
(setq pl (cdr pl))
|
||||
(if pl (princ ", ")))
|
||||
(terpri)))
|
||||
(let ((ch (class-children class)))
|
||||
(when ch
|
||||
(princ " Children ")
|
||||
(while ch
|
||||
(princ "`") (prin1 (car ch)) (princ "'")
|
||||
(setq ch (cdr ch))
|
||||
(if ch (princ ", ")))
|
||||
(terpri)))
|
||||
(terpri)
|
||||
;; System documentation
|
||||
(let ((doc (documentation-property class 'variable-documentation)))
|
||||
(when doc
|
||||
(princ "Documentation:")
|
||||
(terpri)
|
||||
(princ doc)
|
||||
(terpri)
|
||||
(terpri)))
|
||||
;; Describe all the slots in this class
|
||||
(eieio-describe-class-slots class)
|
||||
;; Describe all the methods specific to this class.
|
||||
(let ((methods (eieio-all-generic-functions class))
|
||||
(doc nil))
|
||||
(if (not methods) nil
|
||||
(princ "Specialized Methods:")
|
||||
(terpri)
|
||||
(terpri)
|
||||
(while methods
|
||||
(setq doc (eieio-method-documentation (car methods) class))
|
||||
(princ "`")
|
||||
(prin1 (car methods))
|
||||
(princ "'")
|
||||
(if (not doc)
|
||||
(princ " Undocumented")
|
||||
(if (car doc)
|
||||
(progn
|
||||
(princ " :STATIC ")
|
||||
(prin1 (car (car doc)))
|
||||
(terpri)
|
||||
(princ (cdr (car doc)))))
|
||||
(setq doc (cdr doc))
|
||||
(if (car doc)
|
||||
(progn
|
||||
(princ " :BEFORE ")
|
||||
(prin1 (car (car doc)))
|
||||
(terpri)
|
||||
(princ (cdr (car doc)))))
|
||||
(setq doc (cdr doc))
|
||||
(if (car doc)
|
||||
(progn
|
||||
(princ " :PRIMARY ")
|
||||
(prin1 (car (car doc)))
|
||||
(terpri)
|
||||
(princ (cdr (car doc)))))
|
||||
(setq doc (cdr doc))
|
||||
(if (car doc)
|
||||
(progn
|
||||
(princ " :AFTER ")
|
||||
(prin1 (car (car doc)))
|
||||
(terpri)
|
||||
(princ (cdr (car doc)))))
|
||||
(terpri)
|
||||
(terpri))
|
||||
(setq methods (cdr methods))))))
|
||||
(save-excursion
|
||||
(set-buffer (help-buffer))
|
||||
(buffer-string)))
|
||||
|
||||
(defun eieio-describe-class-slots (class)
|
||||
"Describe the slots in CLASS.
|
||||
Outputs to the standard output."
|
||||
(let* ((cv (class-v class))
|
||||
(docs (aref cv class-public-doc))
|
||||
(names (aref cv class-public-a))
|
||||
(deflt (aref cv class-public-d))
|
||||
(types (aref cv class-public-type))
|
||||
(publp (aref cv class-public-printer))
|
||||
(i 0)
|
||||
(prot (aref cv class-protection))
|
||||
)
|
||||
(princ "Instance Allocated Slots:")
|
||||
(terpri)
|
||||
(terpri)
|
||||
(while names
|
||||
(if (car prot) (princ "Private "))
|
||||
(princ "Slot: ")
|
||||
(prin1 (car names))
|
||||
(when (not (eq (aref types i) t))
|
||||
(princ " type = ")
|
||||
(prin1 (aref types i)))
|
||||
(unless (eq (car deflt) eieio-unbound)
|
||||
(princ " default = ")
|
||||
(prin1 (car deflt)))
|
||||
(when (car publp)
|
||||
(princ " printer = ")
|
||||
(prin1 (car publp)))
|
||||
(when (car docs)
|
||||
(terpri)
|
||||
(princ " ")
|
||||
(princ (car docs))
|
||||
(terpri))
|
||||
(terpri)
|
||||
(setq names (cdr names)
|
||||
docs (cdr docs)
|
||||
deflt (cdr deflt)
|
||||
publp (cdr publp)
|
||||
prot (cdr prot)
|
||||
i (1+ i)))
|
||||
(setq docs (aref cv class-class-allocation-doc)
|
||||
names (aref cv class-class-allocation-a)
|
||||
types (aref cv class-class-allocation-type)
|
||||
i 0
|
||||
prot (aref cv class-class-allocation-protection))
|
||||
(when names
|
||||
(terpri)
|
||||
(princ "Class Allocated Slots:"))
|
||||
(terpri)
|
||||
(terpri)
|
||||
(while names
|
||||
(when (car prot)
|
||||
(princ "Private "))
|
||||
(princ "Slot: ")
|
||||
(prin1 (car names))
|
||||
(unless (eq (aref types i) t)
|
||||
(princ " type = ")
|
||||
(prin1 (aref types i)))
|
||||
(condition-case nil
|
||||
(let ((value (eieio-oref class (car names))))
|
||||
(princ " value = ")
|
||||
(prin1 value))
|
||||
(error nil))
|
||||
(when (car docs)
|
||||
(terpri)
|
||||
(princ " ")
|
||||
(princ (car docs))
|
||||
(terpri))
|
||||
(terpri)
|
||||
(setq names (cdr names)
|
||||
docs (cdr docs)
|
||||
prot (cdr prot)
|
||||
i (1+ i)))))
|
||||
|
||||
(defun eieio-describe-constructor (fcn)
|
||||
"Describe the constructor function FCN.
|
||||
Uses `eieio-describe-class' to describe the class being constructed."
|
||||
(interactive
|
||||
;; Use eieio-read-class since all constructors have the same name as
|
||||
;; the class they create.
|
||||
(list (eieio-read-class "Class: ")))
|
||||
(eieio-describe-class
|
||||
fcn (lambda ()
|
||||
;; Describe the constructor part.
|
||||
(princ "Object Constructor Function: ")
|
||||
(prin1 fcn)
|
||||
(terpri)
|
||||
(princ "Creates an object of class ")
|
||||
(prin1 fcn)
|
||||
(princ ".")
|
||||
(terpri)
|
||||
(terpri)
|
||||
))
|
||||
)
|
||||
|
||||
(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.
|
||||
If INSTANTIABLE-ONLY is non nil, only allow names of classes which
|
||||
are not abstract, otherwise allow all classes.
|
||||
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)))
|
||||
(while sublst
|
||||
(setq buildlist (eieio-build-class-alist
|
||||
(car sublst) instantiable-only buildlist))
|
||||
(setq sublst (cdr sublst)))
|
||||
buildlist))
|
||||
|
||||
(defvar eieio-read-class nil
|
||||
"History of the function `eieio-read-class' prompt.")
|
||||
|
||||
(defun eieio-read-class (prompt &optional histvar instantiable-only)
|
||||
"Return a class chosen by the user using PROMPT.
|
||||
Optional argument HISTVAR is a variable to use as history.
|
||||
If INSTANTIABLE-ONLY is non nil, only allow names of classes which
|
||||
are not abstract."
|
||||
(intern (completing-read prompt (eieio-build-class-alist nil instantiable-only)
|
||||
nil t nil
|
||||
(or histvar 'eieio-read-class))))
|
||||
|
||||
(defun eieio-read-subclass (prompt class &optional histvar instantiable-only)
|
||||
"Return a class chosen by the user using PROMPT.
|
||||
CLASS is the base class, and completion occurs across all subclasses.
|
||||
Optional argument HISTVAR is a variable to use as history.
|
||||
If INSTANTIABLE-ONLY is non nil, only allow names of classes which
|
||||
are not abstract."
|
||||
(intern (completing-read prompt
|
||||
(eieio-build-class-alist class instantiable-only)
|
||||
nil t nil
|
||||
(or histvar 'eieio-read-class))))
|
||||
|
||||
;;; METHOD COMPLETION / DOC
|
||||
;;
|
||||
;;;###autoload
|
||||
(defalias 'describe-method 'eieio-describe-generic)
|
||||
;;;###autoload
|
||||
(defalias 'describe-generic 'eieio-describe-generic)
|
||||
;;;###autoload
|
||||
(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."
|
||||
(interactive (list (eieio-read-generic "Generic Method: ")))
|
||||
(if (not (generic-p generic))
|
||||
(signal 'wrong-type-argument '(generic-p generic)))
|
||||
(with-output-to-temp-buffer (help-buffer) ; "*Help*"
|
||||
(help-setup-xref (list #'eieio-describe-generic generic) (interactive-p))
|
||||
|
||||
(prin1 generic)
|
||||
(princ " is a generic function")
|
||||
(when (generic-primary-only-p generic)
|
||||
(princ " with only ")
|
||||
(when (generic-primary-only-one-p generic)
|
||||
(princ "one "))
|
||||
(princ "primary method")
|
||||
(when (not (generic-primary-only-one-p generic))
|
||||
(princ "s"))
|
||||
)
|
||||
(princ ".")
|
||||
(terpri)
|
||||
(terpri)
|
||||
(let ((d (documentation generic)))
|
||||
(if (not d)
|
||||
(princ "The generic is not documented.\n")
|
||||
(princ "Documentation:")
|
||||
(terpri)
|
||||
(princ d)
|
||||
(terpri)
|
||||
(terpri)))
|
||||
(princ "Implementations:")
|
||||
(terpri)
|
||||
(terpri)
|
||||
(let ((i 3)
|
||||
(prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] ))
|
||||
;; Loop over fanciful generics
|
||||
(while (< i 6)
|
||||
(let ((gm (aref (get generic 'eieio-method-tree) i)))
|
||||
(when gm
|
||||
(princ "Generic ")
|
||||
(princ (aref prefix (- i 3)))
|
||||
(terpri)
|
||||
(princ (or (nth 2 gm) "Undocumented"))
|
||||
(terpri)
|
||||
(terpri)))
|
||||
(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 gm
|
||||
(princ "`")
|
||||
(prin1 (car (car gm)))
|
||||
(princ "'")
|
||||
;; prefix type
|
||||
(princ " ")
|
||||
(princ (aref prefix i))
|
||||
(princ " ")
|
||||
;; argument list
|
||||
(let* ((func (cdr (car gm)))
|
||||
(arglst (eieio-lambda-arglist func)))
|
||||
(prin1 arglst))
|
||||
(terpri)
|
||||
;; 3 because of cdr
|
||||
(princ (or (documentation (cdr (car gm)))
|
||||
"Undocumented"))
|
||||
(setq gm (cdr gm))
|
||||
(terpri)
|
||||
(terpri)))
|
||||
(setq i (1+ i)))))
|
||||
(save-excursion
|
||||
(set-buffer (help-buffer))
|
||||
(buffer-string)))
|
||||
|
||||
(defun eieio-lambda-arglist (func)
|
||||
"Return the argument list of FUNC, a function body."
|
||||
(if (symbolp func) (setq func (symbol-function func)))
|
||||
(if (byte-code-function-p func)
|
||||
(eieio-compiled-function-arglist func)
|
||||
(car (cdr func))))
|
||||
|
||||
(defun eieio-all-generic-functions (&optional class)
|
||||
"Return a list of all generic functions.
|
||||
Optional CLASS argument returns only those functions that contain methods for CLASS."
|
||||
(let ((l nil) tree (cn (if class (symbol-name class) nil)))
|
||||
(mapatoms
|
||||
(lambda (symbol)
|
||||
(setq tree (get symbol 'eieio-method-obarray))
|
||||
(if tree
|
||||
(progn
|
||||
;; A symbol might be interned for that class in one of
|
||||
;; these three slots in the method-obarray.
|
||||
(if (or (not class)
|
||||
(fboundp (intern-soft cn (aref tree 0)))
|
||||
(fboundp (intern-soft cn (aref tree 1)))
|
||||
(fboundp (intern-soft cn (aref tree 2))))
|
||||
(setq l (cons symbol l)))))))
|
||||
l))
|
||||
|
||||
(defun eieio-method-documentation (generic class)
|
||||
"Return a list of the specific documentation of GENERIC for CLASS.
|
||||
If there is not an explicit method for CLASS in GENERIC, or if that
|
||||
function has no documentation, then return nil."
|
||||
(let ((tree (get generic 'eieio-method-obarray))
|
||||
(cn (symbol-name class))
|
||||
before primary after)
|
||||
(if (not tree)
|
||||
nil
|
||||
;; A symbol might be interned for that class in one of
|
||||
;; these three slots in the method-obarray.
|
||||
(setq before (intern-soft cn (aref tree 0))
|
||||
primary (intern-soft cn (aref tree 1))
|
||||
after (intern-soft cn (aref tree 2)))
|
||||
(if (not (or (fboundp before)
|
||||
(fboundp primary)
|
||||
(fboundp after)))
|
||||
nil
|
||||
(list (if (fboundp before)
|
||||
(cons (eieio-lambda-arglist before)
|
||||
(documentation before))
|
||||
nil)
|
||||
(if (fboundp primary)
|
||||
(cons (eieio-lambda-arglist primary)
|
||||
(documentation primary))
|
||||
nil)
|
||||
(if (fboundp after)
|
||||
(cons (eieio-lambda-arglist after)
|
||||
(documentation after))
|
||||
nil))))))
|
||||
|
||||
(defvar eieio-read-generic nil
|
||||
"History of the `eieio-read-generic' prompt.")
|
||||
|
||||
(defun eieio-read-generic-p (fn)
|
||||
"Function used in function `eieio-read-generic'.
|
||||
This is because `generic-p' is a macro.
|
||||
Argument FN is the function to test."
|
||||
(generic-p fn))
|
||||
|
||||
(defun eieio-read-generic (prompt &optional historyvar)
|
||||
"Read a generic function from the minibuffer with PROMPT.
|
||||
Optional argument HISTORYVAR is the variable to use as history."
|
||||
(intern (completing-read prompt obarray 'eieio-read-generic-p
|
||||
t nil (or historyvar 'eieio-read-generic))))
|
||||
|
||||
;;; METHOD STATS
|
||||
;;
|
||||
;; Dump out statistics about all the active methods in a session.
|
||||
(defun eieio-display-method-list ()
|
||||
"Display a list of all the methods and what features are used."
|
||||
(interactive)
|
||||
(let* ((meth1 (eieio-all-generic-functions))
|
||||
(meth (sort meth1 (lambda (a b)
|
||||
(string< (symbol-name a)
|
||||
(symbol-name b)))))
|
||||
(buff (get-buffer-create "*EIEIO Method List*"))
|
||||
(methidx 0)
|
||||
(standard-output buff)
|
||||
(slots '(method-static
|
||||
method-before
|
||||
method-primary
|
||||
method-after
|
||||
method-generic-before
|
||||
method-generic-primary
|
||||
method-generic-after))
|
||||
(slotn '("static"
|
||||
"before"
|
||||
"primary"
|
||||
"after"
|
||||
"G bef"
|
||||
"G prim"
|
||||
"G aft"))
|
||||
(idxarray (make-vector (length slots) 0))
|
||||
(primaryonly 0)
|
||||
(oneprimary 0)
|
||||
)
|
||||
(switch-to-buffer-other-window buff)
|
||||
(erase-buffer)
|
||||
(dolist (S slotn)
|
||||
(princ S)
|
||||
(princ "\t")
|
||||
)
|
||||
(princ "Method Name")
|
||||
(terpri)
|
||||
(princ "--------------------------------------------------------------------")
|
||||
(terpri)
|
||||
(dolist (M meth)
|
||||
(let ((mtree (get M 'eieio-method-tree))
|
||||
(P nil) (numP)
|
||||
(!P nil))
|
||||
(dolist (S slots)
|
||||
(let ((num (length (aref mtree (symbol-value S)))))
|
||||
(aset idxarray (symbol-value S)
|
||||
(+ num (aref idxarray (symbol-value S))))
|
||||
(prin1 num)
|
||||
(princ "\t")
|
||||
(when (< 0 num)
|
||||
(if (eq S 'method-primary)
|
||||
(setq P t numP num)
|
||||
(setq !P t)))
|
||||
))
|
||||
;; Is this a primary-only impl method?
|
||||
(when (and P (not !P))
|
||||
(setq primaryonly (1+ primaryonly))
|
||||
(when (= numP 1)
|
||||
(setq oneprimary (1+ oneprimary))
|
||||
(princ "*"))
|
||||
(princ "* ")
|
||||
)
|
||||
(prin1 M)
|
||||
(terpri)
|
||||
(setq methidx (1+ methidx))
|
||||
)
|
||||
)
|
||||
(princ "--------------------------------------------------------------------")
|
||||
(terpri)
|
||||
(dolist (S slots)
|
||||
(prin1 (aref idxarray (symbol-value S)))
|
||||
(princ "\t")
|
||||
)
|
||||
(prin1 methidx)
|
||||
(princ " Total symbols")
|
||||
(terpri)
|
||||
(dolist (S slotn)
|
||||
(princ S)
|
||||
(princ "\t")
|
||||
)
|
||||
(terpri)
|
||||
(terpri)
|
||||
(princ "Methods Primary Only: ")
|
||||
(prin1 primaryonly)
|
||||
(princ "\t")
|
||||
(princ (format "%d" (* (/ (float primaryonly) (float methidx)) 100)))
|
||||
(princ "% of total methods")
|
||||
(terpri)
|
||||
(princ "Only One Primary Impl: ")
|
||||
(prin1 oneprimary)
|
||||
(princ "\t")
|
||||
(princ (format "%d" (* (/ (float oneprimary) (float primaryonly)) 100)))
|
||||
(princ "% of total primary methods")
|
||||
(terpri)
|
||||
))
|
||||
|
||||
;;; HELP AUGMENTATION
|
||||
;;
|
||||
(defun eieio-help-mode-augmentation-maybee (&rest unused)
|
||||
"For buffers thrown into help mode, augment for eieio.
|
||||
Arguments UNUSED are not used."
|
||||
;; Scan created buttons so far if we are in help mode.
|
||||
(when (eq major-mode 'help-mode)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(let ((pos t) (inhibit-read-only t))
|
||||
(while pos
|
||||
(if (get-text-property (point) 'help-xref) ; move off reference
|
||||
(goto-char
|
||||
(or (next-single-property-change (point) 'help-xref)
|
||||
(point))))
|
||||
(setq pos (next-single-property-change (point) 'help-xref))
|
||||
(when pos
|
||||
(goto-char pos)
|
||||
(let* ((help-data (get-text-property (point) 'help-xref))
|
||||
;(method (car help-data))
|
||||
(args (cdr help-data)))
|
||||
(when (symbolp (car args))
|
||||
(cond ((class-p (car args))
|
||||
(setcar help-data 'eieio-describe-class))
|
||||
((generic-p (car args))
|
||||
(setcar help-data 'eieio-describe-generic))
|
||||
(t nil))
|
||||
))))
|
||||
;; start back at the beginning, and highlight some sections
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "^\\(Documentation\\|Implementations\\):$" nil t)
|
||||
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
|
||||
(goto-char (point-min))
|
||||
(if (re-search-forward "^Specialized Methods:$" nil t)
|
||||
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "^\\(Instance\\|Class\\) Allocated Slots:$" nil t)
|
||||
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward ":\\(STATIC\\|BEFORE\\|AFTER\\|PRIMARY\\)" nil t)
|
||||
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "^\\(Private \\)?Slot:" nil t)
|
||||
(put-text-property (match-beginning 0) (match-end 0) 'face 'bold))
|
||||
))))
|
||||
|
||||
;;; SPEEDBAR SUPPORT
|
||||
;;
|
||||
(eval-when-compile
|
||||
(condition-case nil
|
||||
(require 'speedbar)
|
||||
(error (message "Error loading speedbar... ignored."))))
|
||||
|
||||
(defvar eieio-class-speedbar-key-map nil
|
||||
"Keymap used when working with a project in speedbar.")
|
||||
|
||||
(defun eieio-class-speedbar-make-map ()
|
||||
"Make a keymap for eieio under speedbar."
|
||||
(setq eieio-class-speedbar-key-map (speedbar-make-specialized-keymap))
|
||||
|
||||
;; General viewing stuff
|
||||
(define-key eieio-class-speedbar-key-map "\C-m" 'speedbar-edit-line)
|
||||
(define-key eieio-class-speedbar-key-map "+" 'speedbar-expand-line)
|
||||
(define-key eieio-class-speedbar-key-map "-" 'speedbar-contract-line)
|
||||
)
|
||||
|
||||
(if eieio-class-speedbar-key-map
|
||||
nil
|
||||
(if (not (featurep 'speedbar))
|
||||
(add-hook 'speedbar-load-hook (lambda ()
|
||||
(eieio-class-speedbar-make-map)
|
||||
(speedbar-add-expansion-list
|
||||
'("EIEIO"
|
||||
eieio-class-speedbar-menu
|
||||
eieio-class-speedbar-key-map
|
||||
eieio-class-speedbar))))
|
||||
(eieio-class-speedbar-make-map)
|
||||
(speedbar-add-expansion-list '("EIEIO"
|
||||
eieio-class-speedbar-menu
|
||||
eieio-class-speedbar-key-map
|
||||
eieio-class-speedbar))))
|
||||
|
||||
(defvar eieio-class-speedbar-menu
|
||||
()
|
||||
"Menu part in easymenu format used in speedbar while in `eieio' mode.")
|
||||
|
||||
(defun eieio-class-speedbar (dir-or-object depth)
|
||||
"Create buttons in speedbar that represents the current project.
|
||||
DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the current
|
||||
expansion depth."
|
||||
(when (eq (point-min) (point-max))
|
||||
;; This function is only called once, to start the whole deal.
|
||||
;; Ceate, and expand the default object.
|
||||
(eieio-class-button eieio-default-superclass 0)
|
||||
(forward-line -1)
|
||||
(speedbar-expand-line)))
|
||||
|
||||
(defun eieio-class-button (class depth)
|
||||
"Draw a speedbar button at the current point for CLASS at DEPTH."
|
||||
(if (not (class-p class))
|
||||
(signal 'wrong-type-argument (list 'class-p class)))
|
||||
(let ((subclasses (aref (class-v class) class-children)))
|
||||
(if subclasses
|
||||
(speedbar-make-tag-line 'angle ?+
|
||||
'eieio-sb-expand
|
||||
class
|
||||
(symbol-name class)
|
||||
'eieio-describe-class-sb
|
||||
class
|
||||
'speedbar-directory-face
|
||||
depth)
|
||||
(speedbar-make-tag-line 'angle ? nil nil
|
||||
(symbol-name class)
|
||||
'eieio-describe-class-sb
|
||||
class
|
||||
'speedbar-directory-face
|
||||
depth))))
|
||||
|
||||
(defun eieio-sb-expand (text class indent)
|
||||
"For button TEXT, expand CLASS at the current location.
|
||||
Argument INDENT is the depth of indentation."
|
||||
(cond ((string-match "+" text) ;we have to expand this file
|
||||
(speedbar-change-expand-button-char ?-)
|
||||
(speedbar-with-writable
|
||||
(save-excursion
|
||||
(end-of-line) (forward-char 1)
|
||||
(let ((subclasses (aref (class-v class) class-children)))
|
||||
(while subclasses
|
||||
(eieio-class-button (car subclasses) (1+ indent))
|
||||
(setq subclasses (cdr subclasses)))))))
|
||||
((string-match "-" text) ;we have to contract this node
|
||||
(speedbar-change-expand-button-char ?+)
|
||||
(speedbar-delete-subblock indent))
|
||||
(t (error "Ooops... not sure what to do")))
|
||||
(speedbar-center-buffer-smartly))
|
||||
|
||||
(defun eieio-describe-class-sb (text token indent)
|
||||
"Describe the class TEXT in TOKEN.
|
||||
INDENT is the current indentation level."
|
||||
(speedbar-with-attached-buffer
|
||||
(eieio-describe-class token))
|
||||
(speedbar-maybee-jump-to-attached-frame))
|
||||
|
||||
(provide 'eieio-opt)
|
||||
|
||||
;;; eieio-opt.el ends here
|
||||
424
lisp/emacs-lisp/eieio-speedbar.el
Normal file
424
lisp/emacs-lisp/eieio-speedbar.el
Normal file
|
|
@ -0,0 +1,424 @@
|
|||
;;; eieio-speedbar.el -- Classes for managing speedbar displays.
|
||||
|
||||
;;; Copyright (C) 1999, 2000, 2001, 2002, 2005, 2007, 2008 Free
|
||||
;;; Software Foundation, Inc.
|
||||
|
||||
;; Author: Eric M. Ludlam <zappo@gnu.org>
|
||||
;; Version: 0.2
|
||||
;; Keywords: OO, tools
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This provides some classes that can be used as a parent which
|
||||
;; will automatically provide SPEEDBAR support for any list of objects
|
||||
;; of that type.
|
||||
;;
|
||||
;; This file requires speedbar version 0.10 or later.
|
||||
|
||||
;;; Creating a new speedbar mode based on a pre-existing object hierarchy
|
||||
;;
|
||||
;; To create a new speedbar mode based on lists of objects is easier
|
||||
;; than creating a whole new speedbar mode from scratch.
|
||||
;;
|
||||
;; 1) Objects that will have lists of items that can be expanded
|
||||
;; should also inherit from the classes:
|
||||
;; * `eieio-speedbar' - specify your own button behavior
|
||||
;; * `eieio-speedbar-directory-button' - objects that behave like directories
|
||||
;; * `eieio-speedbar-file-button' - objects that behave like files
|
||||
;;
|
||||
;; 2) Objects that have lists of children should implement the method
|
||||
;; `eieio-speedbar-object-children' which returns a list of more
|
||||
;; objects, or a list of strings.
|
||||
;;
|
||||
;; 3) Objects that return a list of strings should also implement these
|
||||
;; methods:
|
||||
;; * `eieio-speedbar-child-make-tag-lines' - make tag lines for a child.
|
||||
;; * `eieio-speedbar-child-description' - describe non-object children
|
||||
;;
|
||||
;; 4) Objects which have expanded information should implement the method
|
||||
;; `eieio-speedbar-description' to produce more information.
|
||||
;;
|
||||
;; 5) Objects that are associated with a directory should implement
|
||||
;; the method `eieio-speedbar-derive-line-path' which returns a
|
||||
;; path.
|
||||
;;
|
||||
;; 6) Objects that have a specialized behavior when clicked should
|
||||
;; define the method `eieio-speedbar-handle-click'.
|
||||
;;
|
||||
;; To initialize a new eieio based speedbar display, do the following.
|
||||
;;
|
||||
;; 1) Create a keymap variable `foo-speedbar-key-map'.
|
||||
;; This keymap variable should be initialized in a function.
|
||||
;; If you have no special needs, use `eieio-speedbar-key-map'
|
||||
;;
|
||||
;; 2) Create a variable containing an easymenu definition compatible
|
||||
;; with speedbar. if you have no special needs, use
|
||||
;; `eieio-speedbar-menu'.
|
||||
;;
|
||||
;; 3) Create a function which returns the top-level list of children
|
||||
;; objects to be displayed in speedbar.
|
||||
;;
|
||||
;; 4) Call `eieio-speedbar-create' as specified in it's documentation
|
||||
;; string. This will automatically handle cases when speedbar is
|
||||
;; not already loaded, and specifying all overload functions.
|
||||
;;
|
||||
;; 5) Create an initliazer function which looks like this:
|
||||
;;
|
||||
;; (defun my-speedbar-mode-initilaize ()
|
||||
;; "documentation"
|
||||
;; (interactive)
|
||||
;; (speedbar-frame-mode 1)
|
||||
;; (speedbar-change-initial-expansion-list mymodename)
|
||||
;; (speedbar-get-focus))
|
||||
;;
|
||||
;; where `mymodename' is the same value as passed to `eieio-speedbar-create'
|
||||
;; as the MODENAME parameter.
|
||||
|
||||
;; @todo - Can we make this ECB friendly?
|
||||
|
||||
;;; Code:
|
||||
(require 'eieio)
|
||||
(require 'eieio-custom)
|
||||
(require 'speedbar)
|
||||
|
||||
;;; Support a way of adding generic object based modes into speedbar.
|
||||
;;
|
||||
(defun eieio-speedbar-make-map ()
|
||||
"Make the generic object based speedbar keymap."
|
||||
(let ((map (speedbar-make-specialized-keymap)))
|
||||
|
||||
;; General viewing things
|
||||
(define-key map "\C-m" 'speedbar-edit-line)
|
||||
(define-key map "+" 'speedbar-expand-line)
|
||||
(define-key map "=" 'speedbar-expand-line)
|
||||
(define-key map "-" 'speedbar-contract-line)
|
||||
|
||||
;; Some object based things
|
||||
(define-key map "C" 'eieio-speedbar-customize-line)
|
||||
map))
|
||||
|
||||
(defvar eieio-speedbar-key-map (eieio-speedbar-make-map)
|
||||
"A Generic object based speedbar display keymap.")
|
||||
|
||||
(defvar eieio-speedbar-menu
|
||||
'([ "Edit Object/Field" speedbar-edit-line t]
|
||||
[ "Expand Object" speedbar-expand-line
|
||||
(save-excursion (beginning-of-line)
|
||||
(looking-at "[0-9]+: *.\\+. "))]
|
||||
[ "Contract Object" speedbar-contract-line
|
||||
(save-excursion (beginning-of-line)
|
||||
(looking-at "[0-9]+: *.-. "))]
|
||||
"---"
|
||||
[ "Customize Object" eieio-speedbar-customize-line
|
||||
(eieio-object-p (speedbar-line-token)) ]
|
||||
)
|
||||
"Menu part in easymenu format used in speedbar while browsing objects.")
|
||||
|
||||
;; Note to self: Fix this silly thing!
|
||||
(defalias 'eieio-speedbar-customize-line 'speedbar-edit-line)
|
||||
|
||||
(defun eieio-speedbar-create (map-fn map-var menu-var modename fetcher)
|
||||
"Create a speedbar mode for displaying an object hierarchy.
|
||||
MAP-FN is the keymap generator function used for extra keys.
|
||||
MAP-VAR is the keymap variable used.
|
||||
MENU-VAR is the symbol containting an easymenu compatible menu part to use.
|
||||
MODENAME is a s tring used to identify this browser mode.
|
||||
FETCHER is a generic function used to fetch the base object list used when
|
||||
creating the speedbar display."
|
||||
(if (not (featurep 'speedbar))
|
||||
(add-hook 'speedbar-load-hook
|
||||
(list 'lambda nil
|
||||
(list 'eieio-speedbar-create-engine
|
||||
map-fn map-var menu-var modename fetcher)))
|
||||
(eieio-speedbar-create-engine map-fn map-var menu-var modename fetcher)))
|
||||
|
||||
(defun eieio-speedbar-create-engine (map-fn map-var menu-var modename fetcher)
|
||||
"Create a speedbar mode for displaying an object hierarchy.
|
||||
Called from `eieio-speedbar-create', or the speedbar load-hook.
|
||||
MAP-FN, MAP-VAR, MENU-VAR, MODENAME, and FETCHER are the same as
|
||||
`eieio-speedbar-create'."
|
||||
;; make sure the keymap exists
|
||||
(funcall map-fn)
|
||||
;; Add to the expansion list.
|
||||
(speedbar-add-expansion-list
|
||||
(list modename
|
||||
menu-var
|
||||
map-var
|
||||
(list 'lambda '(dir depth)
|
||||
(list 'eieio-speedbar-buttons 'dir 'depth
|
||||
(list 'quote fetcher)))))
|
||||
;; Set the special functions.
|
||||
(speedbar-add-mode-functions-list
|
||||
(list modename
|
||||
'(speedbar-item-info . eieio-speedbar-item-info)
|
||||
'(speedbar-line-directory . eieio-speedbar-line-path))))
|
||||
|
||||
(defun eieio-speedbar-buttons (dir-or-object depth fetcher)
|
||||
"Create buttons for the speedbar display.
|
||||
Start in directory DIR-OR-OBJECT. If it is an object, just display that
|
||||
objects subelements.
|
||||
Argument DEPTH specifies how far down we have already been displayed.
|
||||
If it is a directory, use FETCHER to fetch all objects associated with
|
||||
that path."
|
||||
(let ((objlst (cond ((eieio-object-p dir-or-object)
|
||||
(list dir-or-object))
|
||||
((stringp dir-or-object)
|
||||
(funcall fetcher dir-or-object))
|
||||
(t dir-or-object))))
|
||||
(if (not objlst)
|
||||
(speedbar-make-tag-line nil nil nil nil "Empty display" nil nil nil
|
||||
depth)
|
||||
;; Dump all objects into speedbar
|
||||
(while objlst
|
||||
(eieio-speedbar-make-tag-line (car objlst) depth)
|
||||
(setq objlst (cdr objlst))))))
|
||||
|
||||
|
||||
;;; DEFAULT SUPERCLASS baseline methods
|
||||
;;
|
||||
;; First, define methods onto the superclass so all classes
|
||||
;; will have some minor support.
|
||||
|
||||
(defmethod eieio-speedbar-description ((object eieio-default-superclass))
|
||||
"Return a string describing OBJECT."
|
||||
(object-name-string object))
|
||||
|
||||
(defmethod eieio-speedbar-derive-line-path ((object eieio-default-superclass))
|
||||
"Return the path which OBJECT has something to do with."
|
||||
nil)
|
||||
|
||||
(defmethod eieio-speedbar-object-buttonname ((object eieio-default-superclass))
|
||||
"Return a string to use as a speedbar button for OBJECT."
|
||||
(object-name-string object))
|
||||
|
||||
(defmethod eieio-speedbar-make-tag-line ((object eieio-default-superclass)
|
||||
depth)
|
||||
"Insert a tag line into speedbar at point for OBJECT.
|
||||
By default, all objects appear as simple TAGS with no need to inherit from
|
||||
the special `eieio-speedbar' classes. Child classes should redefine this
|
||||
method to create more accurate tag lines.
|
||||
Argument DEPTH is the depth at which the tag line is inserted."
|
||||
(speedbar-make-tag-line nil nil nil nil
|
||||
(eieio-speedbar-object-buttonname object)
|
||||
'eieio-speedbar-object-click
|
||||
object
|
||||
'speedbar-tag-face
|
||||
depth))
|
||||
|
||||
(defmethod eieio-speedbar-handle-click ((object eieio-default-superclass))
|
||||
"Handle a click action on OBJECT in speedbar.
|
||||
Any object can be represented as a tag in SPEEDBAR without special
|
||||
attributes. These default objects will be pulled up in a custom
|
||||
object edit buffer doing an in-place edit.
|
||||
|
||||
If your object represents some other item, override this method
|
||||
and take the apropriate action."
|
||||
(require 'eieio-custom)
|
||||
(speedbar-with-attached-buffer
|
||||
(eieio-customize-object object))
|
||||
(speedbar-maybee-jump-to-attached-frame))
|
||||
|
||||
|
||||
;;; Class definitions
|
||||
;;
|
||||
;; Now define a special speedbar class with some
|
||||
;; variables with :allocation class which can be attached into
|
||||
;; object hierarchies.
|
||||
;;
|
||||
;; These more complex types are for objects which wish to display
|
||||
;; lists of children buttons.
|
||||
|
||||
(defclass eieio-speedbar nil
|
||||
((buttontype :initform nil
|
||||
:type symbol
|
||||
:documentation
|
||||
"The type of expansion button used for objects of this class.
|
||||
Possible values are those symbols supported by the `exp-button-type' argument
|
||||
to `speedbar-make-tag-line'."
|
||||
:allocation :class)
|
||||
(buttonface :initform speedbar-tag-face
|
||||
:type (or symbol face)
|
||||
:documentation
|
||||
"The face used on the textual part of the button for this class.
|
||||
See `speedbar-make-tag-line' for details."
|
||||
:allocation :class)
|
||||
(expanded :initform nil
|
||||
:type boolean
|
||||
:documentation
|
||||
"State of an object being expanded in speedbar.")
|
||||
)
|
||||
"Class which provides basic speedbar support for child classes.
|
||||
Add one of thie child classes to this class to the parent list of a class."
|
||||
:method-invocation-order :depth-first
|
||||
:abstract t)
|
||||
|
||||
(defclass eieio-speedbar-directory-button (eieio-speedbar)
|
||||
((buttontype :initform angle)
|
||||
(buttonface :initform speedbar-directory-face))
|
||||
"Class providing support for objects which behave like a directory."
|
||||
:method-invocation-order :depth-first
|
||||
:abstract t)
|
||||
|
||||
(defclass eieio-speedbar-file-button (eieio-speedbar)
|
||||
((buttontype :initform bracket)
|
||||
(buttonface :initform speedbar-file-face))
|
||||
"Class providing support for objects which behave like a directory."
|
||||
:method-invocation-order :depth-first
|
||||
:abstract t)
|
||||
|
||||
|
||||
;;; Methods to eieio-speedbar-* which do not need to be overriden
|
||||
;;
|
||||
(defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar)
|
||||
depth)
|
||||
"Insert a tag line into speedbar at point for OBJECT.
|
||||
All objects a child of symbol `eieio-speedbar' can be created from this
|
||||
method. Override this if you need non-traditional tag lines.
|
||||
Argument DEPTH is the depth at which the tag line is inserted."
|
||||
(let ((children (eieio-speedbar-object-children object))
|
||||
(exp (oref object expanded)))
|
||||
(if (not children)
|
||||
(if (eq (oref object buttontype) 'expandtag)
|
||||
(speedbar-make-tag-line 'statictag
|
||||
? nil nil
|
||||
(eieio-speedbar-object-buttonname object)
|
||||
'eieio-speedbar-object-click
|
||||
object
|
||||
(oref object buttonface)
|
||||
depth)
|
||||
(speedbar-make-tag-line (oref object buttontype)
|
||||
? nil nil
|
||||
(eieio-speedbar-object-buttonname object)
|
||||
'eieio-speedbar-object-click
|
||||
object
|
||||
(oref object buttonface)
|
||||
depth))
|
||||
(speedbar-make-tag-line (oref object buttontype)
|
||||
(if exp ?- ?+)
|
||||
'eieio-speedbar-object-expand
|
||||
object
|
||||
(eieio-speedbar-object-buttonname object)
|
||||
'eieio-speedbar-object-click
|
||||
object
|
||||
(oref object buttonface)
|
||||
depth)
|
||||
(if exp
|
||||
(eieio-speedbar-expand object (1+ depth))))))
|
||||
|
||||
(defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth)
|
||||
"Base method for creating tag lines for non-object children."
|
||||
(error "You must implement `eieio-speedbar-child-make-tag-lines' for %s"
|
||||
(object-name object)))
|
||||
|
||||
(defmethod eieio-speedbar-expand ((object eieio-speedbar) depth)
|
||||
"Expand OBJECT at indentation DEPTH.
|
||||
Inserts a list of new tag lines representing expanded elements withing
|
||||
OBJECT."
|
||||
(let ((children (eieio-speedbar-object-children object)))
|
||||
(cond ((eieio-object-p (car children))
|
||||
(mapcar (lambda (car)
|
||||
(eieio-speedbar-make-tag-line car depth))
|
||||
children))
|
||||
(children (eieio-speedbar-child-make-tag-lines object depth)))))
|
||||
|
||||
|
||||
;;; Speedbar specific function callbacks.
|
||||
;;
|
||||
(defun eieio-speedbar-object-click (text token indent)
|
||||
"Handle a user click on TEXT representing object TOKEN.
|
||||
The object is at indentation level INDENT."
|
||||
(eieio-speedbar-handle-click token))
|
||||
|
||||
(defun eieio-speedbar-object-expand (text token indent)
|
||||
"Expand object represented by TEXT. TOKEN is the object.
|
||||
INDENT is the current indentation level."
|
||||
(cond ((string-match "+" text) ;we have to expand this file
|
||||
(speedbar-change-expand-button-char ?-)
|
||||
(oset token expanded t)
|
||||
(speedbar-with-writable
|
||||
(save-excursion
|
||||
(end-of-line) (forward-char 1)
|
||||
(eieio-speedbar-expand token (1+ indent)))))
|
||||
((string-match "-" text) ;we have to contract this node
|
||||
(speedbar-change-expand-button-char ?+)
|
||||
(oset token expanded nil)
|
||||
(speedbar-delete-subblock indent))
|
||||
(t (error "Ooops... not sure what to do")))
|
||||
(speedbar-center-buffer-smartly))
|
||||
|
||||
(defmethod eieio-speedbar-child-description ((obj eieio-speedbar))
|
||||
"Return a description for a child of OBJ which is not an object."
|
||||
(error "You must implement `eieio-speedbar-child-description' for %s"
|
||||
(object-name obj)))
|
||||
|
||||
(defun eieio-speedbar-item-info ()
|
||||
"Display info for the current line when in EDE display mode."
|
||||
;; Switch across the types of the tokens.
|
||||
(let ((tok (speedbar-line-token)))
|
||||
(cond ((eieio-object-p tok)
|
||||
(message (eieio-speedbar-description tok)))
|
||||
(t
|
||||
(let ((no (eieio-speedbar-find-nearest-object)))
|
||||
(if no
|
||||
(eieio-speedbar-child-description no)))))))
|
||||
|
||||
(defun eieio-speedbar-find-nearest-object (&optional depth)
|
||||
"Search backwards to the first line associated with an object.
|
||||
Optional argument DEPTH is the current depth of the search."
|
||||
(save-excursion
|
||||
(if (not depth)
|
||||
(progn
|
||||
(beginning-of-line)
|
||||
(when (looking-at "^\\([0-9]+\\):")
|
||||
(setq depth (string-to-number (match-string 1))))))
|
||||
(when depth
|
||||
(while (and (not (eieio-object-p (speedbar-line-token)))
|
||||
(> depth 0))
|
||||
(setq depth (1- depth))
|
||||
(re-search-backward (format "^%d:" depth) nil t))
|
||||
(speedbar-line-token))))
|
||||
|
||||
(defun eieio-speedbar-line-path (&optional depth)
|
||||
"If applicable, return the path to the file the cursor is on.
|
||||
Optional DEPTH is the depth we start at."
|
||||
(save-match-data
|
||||
(if (not depth)
|
||||
(progn
|
||||
(beginning-of-line)
|
||||
(looking-at "^\\([0-9]+\\):")
|
||||
(setq depth (string-to-number (match-string 1)))))
|
||||
;; This whole function is presently bogus. Make it better later.
|
||||
(let ((tok (eieio-speedbar-find-nearest-object depth)))
|
||||
(if (eieio-object-p tok)
|
||||
(eieio-speedbar-derive-line-path tok)
|
||||
default-directory))))
|
||||
|
||||
|
||||
;;; Methods to the eieio-speedbar-* classes which need to be overriden.
|
||||
;;
|
||||
(defmethod eieio-speedbar-object-children ((object eieio-speedbar))
|
||||
"Return a list of children to be displayed in SPEEDBAR.
|
||||
If the return value is a list of OBJECTs, then those objects are
|
||||
queried for details. If the return list is made of strings,
|
||||
then this object will be queried for the details needed
|
||||
to create a speedbar button."
|
||||
nil)
|
||||
|
||||
(provide 'eieio-speedbar)
|
||||
|
||||
;;; eieio-speedbar.el ends here
|
||||
2803
lisp/emacs-lisp/eieio.el
Normal file
2803
lisp/emacs-lisp/eieio.el
Normal file
File diff suppressed because it is too large
Load diff
Loading…
Add table
Add a link
Reference in a new issue