Mercurial > emacs
view lisp/emacs-lisp/eieio-custom.el @ 105371:0769a73f1d18
* image-mode.el (image-toggle-display):
* emacs-lisp/elp.el (elp-instrument-function):
* emacs-lisp/advice.el (ad-make-advised-definition):
* emacs-lisp/easy-mmode.el (define-minor-mode):
* net/browse-url.el (browse-url-maybe-new-window):
* progmodes/sh-script.el (sh-learn-buffer-indent):
Pass new argument 'any to `called-interactively-p'.
author | Juanma Barranquero <lekktu@gmail.com> |
---|---|
date | Fri, 02 Oct 2009 00:02:02 +0000 |
parents | e18b53ee74a9 |
children | 7f4c7f5c0eba |
line wrap: on
line source
;;; 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 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 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 (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