mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-14 09:39:42 +00:00
465 lines
15 KiB
EmacsLisp
465 lines
15 KiB
EmacsLisp
;;; eieio-custom.el -- eieio object customization
|
||
|
||
;; Copyright (C) 1999, 2000, 2001, 2005, 2007, 2008, 2009, 2010
|
||
;; 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 attribute
|
||
;; `: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 (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 its
|
||
;; 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 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 (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 is 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
|
||
;; its 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)
|
||
|
||
;; arch-tag: bc122762-a771-48d5-891b-7835b16dd924
|
||
;;; eieio-custom.el ends here
|