Mercurial > emacs
comparison lisp/emacs-lisp/eieio-custom.el @ 104431:a64f3429f0ac
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.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Sun, 30 Aug 2009 02:02:15 +0000 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
104430:b93dbe652ecd | 104431:a64f3429f0ac |
---|---|
1 ;;; eieio-custom.el -- eieio object customization | |
2 | |
3 ;;; Copyright (C) 1999, 2000, 2001, 2005, 2007, 2008, 2009 | |
4 ;;; Free Software Foundation, Inc. | |
5 | |
6 ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
7 ;; Version: 0.2 | |
8 ;; Keywords: OO, lisp | |
9 | |
10 ;; This file is part of GNU Emacs. | |
11 | |
12 ;; GNU Emacs is free software: you can redistribute it and/or modify | |
13 ;; it under the terms of the GNU General Public License as published by | |
14 ;; the Free Software Foundation, either version 3 of the License, or | |
15 ;; (at your option) any later version. | |
16 | |
17 ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 ;; GNU General Public License for more details. | |
21 | |
22 ;; You should have received a copy of the GNU General Public License | |
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
24 | |
25 ;;; Commentary: | |
26 ;; | |
27 ;; This contains support customization of eieio objects. Enabling | |
28 ;; your object to be customizable requires use of the slot attirbute | |
29 ;; `:custom'. | |
30 | |
31 (require 'eieio) | |
32 (require 'widget) | |
33 (require 'wid-edit) | |
34 (require 'custom) | |
35 | |
36 ;;; Compatibility | |
37 ;; | |
38 (eval-and-compile | |
39 (if (featurep 'xemacs) | |
40 (defalias 'eieio-overlay-lists (lambda () (list (extent-list)))) | |
41 (defalias 'eieio-overlay-lists 'overlay-lists) | |
42 ) | |
43 ) | |
44 ;;; Code: | |
45 (defclass eieio-widget-test-class nil | |
46 ((a-string :initarg :a-string | |
47 :initform "The moose is loose" | |
48 :custom string | |
49 :label "Amorphous String" | |
50 :group (default foo) | |
51 :documentation "A string for testing custom. | |
52 This is the next line of documentation.") | |
53 (listostuff :initarg :listostuff | |
54 :initform ("1" "2" "3") | |
55 :type list | |
56 :custom (repeat (string :tag "Stuff")) | |
57 :label "List of Strings" | |
58 :group foo | |
59 :documentation "A list of stuff.") | |
60 (uninitialized :initarg :uninitialized | |
61 :type string | |
62 :custom string | |
63 :documentation "This slot is not initialized. | |
64 Used to make sure that custom doesn't barf when it encounters one | |
65 of these.") | |
66 (a-number :initarg :a-number | |
67 :initform 2 | |
68 :custom integer | |
69 :documentation "A number of thingies.")) | |
70 "A class for testing the widget on.") | |
71 | |
72 (defcustom eieio-widget-test (eieio-widget-test-class "Foo") | |
73 "Test variable for editing an object." | |
74 :type 'object | |
75 :group 'eieio) | |
76 | |
77 (defface eieio-custom-slot-tag-face '((((class color) | |
78 (background dark)) | |
79 (:foreground "light blue")) | |
80 (((class color) | |
81 (background light)) | |
82 (:foreground "blue")) | |
83 (t (:italic t))) | |
84 "Face used for unpushable variable tags." | |
85 :group 'custom-faces) | |
86 | |
87 (defvar eieio-wo nil | |
88 "Buffer local variable in object customize buffers for the current widget.") | |
89 (defvar eieio-co nil | |
90 "Buffer local variable in object customize buffers for the current obj.") | |
91 (defvar eieio-cog nil | |
92 "Buffer local variable in object customize buffers for the current group.") | |
93 | |
94 (defvar eieio-custom-ignore-eieio-co nil | |
95 "When true, all customizable slots of the current object are updated. | |
96 Updates occur regardless of the current customization group.") | |
97 | |
98 (define-widget 'object-slot 'group | |
99 "Abstractly modify a single slot in an object." | |
100 :tag "Slot" | |
101 :format "%t %v%h\n" | |
102 :convert-widget 'widget-types-convert-widget | |
103 :value-create 'eieio-slot-value-create | |
104 :value-get 'eieio-slot-value-get | |
105 :value-delete 'widget-children-value-delete | |
106 :validate 'widget-children-validate | |
107 :match 'eieio-object-match ;; same | |
108 ) | |
109 | |
110 (defun eieio-slot-value-create (widget) | |
111 "Create the value of WIDGET." | |
112 (let ((chil nil) | |
113 ) | |
114 ; (setq chil (cons (widget-create-child-and-convert | |
115 ; widget 'visibility | |
116 ; :help-echo "Hide the value of this option." | |
117 ; :action 'eieio-custom-toggle-parent | |
118 ; t) | |
119 ; chil)) | |
120 (setq chil (cons | |
121 (widget-create-child-and-convert | |
122 widget (widget-get widget :childtype) | |
123 :tag "" | |
124 :value (widget-get widget :value)) | |
125 chil)) | |
126 (widget-put widget :children chil))) | |
127 | |
128 (defun eieio-slot-value-get (widget) | |
129 "Get the value of WIDGET." | |
130 (widget-value (car (widget-get widget :children)))) | |
131 | |
132 (defun eieio-custom-toggle-hide (widget) | |
133 "Toggle visibility of WIDGET." | |
134 (let ((vc (car (widget-get widget :children)))) | |
135 (cond ((eq (widget-get vc :eieio-custom-state) 'hidden) | |
136 (widget-put vc :eieio-custom-state 'visible) | |
137 (widget-put vc :value-face (widget-get vc :orig-face))) | |
138 (t | |
139 (widget-put vc :eieio-custom-state 'hidden) | |
140 (widget-put vc :orig-face (widget-get vc :value-face)) | |
141 (widget-put vc :value-face 'invisible) | |
142 )) | |
143 (widget-value-set vc (widget-value vc)))) | |
144 | |
145 (defun eieio-custom-toggle-parent (widget &rest ignore) | |
146 "Toggle visibility of parent of WIDGET. | |
147 Optional argument IGNORE is an extraneous parameter." | |
148 (eieio-custom-toggle-hide (widget-get widget :parent))) | |
149 | |
150 (define-widget 'object-edit 'group | |
151 "Abstractly modify a CLOS object." | |
152 :tag "Object" | |
153 :format "%v" | |
154 :convert-widget 'widget-types-convert-widget | |
155 :value-create 'eieio-object-value-create | |
156 :value-get 'eieio-object-value-get | |
157 :value-delete 'widget-children-value-delete | |
158 :validate 'widget-children-validate | |
159 :match 'eieio-object-match | |
160 :clone-object-children nil | |
161 ) | |
162 | |
163 (defun eieio-object-match (widget value) | |
164 "Match info for WIDGET against VALUE." | |
165 ;; Write me | |
166 t) | |
167 | |
168 (defun eieio-filter-slot-type (widget slottype) | |
169 "Filter WIDGETs SLOTTYPE." | |
170 (if (widget-get widget :clone-object-children) | |
171 slottype | |
172 (cond ((eq slottype 'object) | |
173 'object-edit) | |
174 ((and (listp slottype) | |
175 (eq (car slottype) 'object)) | |
176 (cons 'object-edit (cdr slottype))) | |
177 ((equal slottype '(repeat object)) | |
178 '(repeat object-edit)) | |
179 ((and (listp slottype) | |
180 (equal (car slottype) 'repeat) | |
181 (listp (car (cdr slottype))) | |
182 (equal (car (car (cdr slottype))) 'object)) | |
183 (list 'repeat | |
184 (cons 'object-edit | |
185 (cdr (car (cdr slottype)))))) | |
186 (t slottype)))) | |
187 | |
188 (defun eieio-object-value-create (widget) | |
189 "Create the value of WIDGET." | |
190 (if (not (widget-get widget :value)) | |
191 (widget-put widget | |
192 :value (cond ((widget-get widget :objecttype) | |
193 (funcall (class-constructor | |
194 (widget-get widget :objecttype)) | |
195 "Custom-new")) | |
196 ((widget-get widget :objectcreatefcn) | |
197 (funcall (widget-get widget :objectcreatefcn))) | |
198 (t (error "No create method specified"))))) | |
199 (let* ((chil nil) | |
200 (obj (widget-get widget :value)) | |
201 (master-group (widget-get widget :eieio-group)) | |
202 (cv (class-v (object-class-fast obj))) | |
203 (slots (aref cv class-public-a)) | |
204 (flabel (aref cv class-public-custom-label)) | |
205 (fgroup (aref cv class-public-custom-group)) | |
206 (fdoc (aref cv class-public-doc)) | |
207 (fcust (aref cv class-public-custom))) | |
208 ;; First line describes the object, but may not editable. | |
209 (if (widget-get widget :eieio-show-name) | |
210 (setq chil (cons (widget-create-child-and-convert | |
211 widget 'string :tag "Object " | |
212 :sample-face 'bold | |
213 (object-name-string obj)) | |
214 chil))) | |
215 ;; Display information about the group being shown | |
216 (when master-group | |
217 (let ((groups (class-option (object-class-fast obj) :custom-groups))) | |
218 (widget-insert "Groups:") | |
219 (while groups | |
220 (widget-insert " ") | |
221 (if (eq (car groups) master-group) | |
222 (widget-insert "*" (capitalize (symbol-name master-group)) "*") | |
223 (widget-create 'push-button | |
224 :thing (cons obj (car groups)) | |
225 :notify (lambda (widget &rest stuff) | |
226 (eieio-customize-object | |
227 (car (widget-get widget :thing)) | |
228 (cdr (widget-get widget :thing)))) | |
229 (capitalize (symbol-name (car groups))))) | |
230 (setq groups (cdr groups))) | |
231 (widget-insert "\n\n"))) | |
232 ;; Loop over all the slots, creating child widgets. | |
233 (while slots | |
234 ;; Output this slot if it has a customize flag associated with it. | |
235 (when (and (car fcust) | |
236 (or (not master-group) (member master-group (car fgroup))) | |
237 (slot-boundp obj (car slots))) | |
238 ;; In this case, this slot has a custom type. Create it's | |
239 ;; children widgets. | |
240 (let ((type (eieio-filter-slot-type widget (car fcust))) | |
241 (stuff nil)) | |
242 ;; This next bit is an evil hack to get some EDE functions | |
243 ;; working the way I like. | |
244 (if (and (listp type) | |
245 (setq stuff (member :slotofchoices type))) | |
246 (let ((choices (eieio-oref obj (car (cdr stuff)))) | |
247 (newtype nil)) | |
248 (while (not (eq (car type) :slotofchoices)) | |
249 (setq newtype (cons (car type) newtype) | |
250 type (cdr type))) | |
251 (while choices | |
252 (setq newtype (cons (list 'const (car choices)) | |
253 newtype) | |
254 choices (cdr choices))) | |
255 (setq type (nreverse newtype)))) | |
256 (setq chil (cons (widget-create-child-and-convert | |
257 widget 'object-slot | |
258 :childtype type | |
259 :sample-face 'eieio-custom-slot-tag-face | |
260 :tag | |
261 (concat | |
262 (make-string | |
263 (or (widget-get widget :indent) 0) | |
264 ? ) | |
265 (if (car flabel) | |
266 (car flabel) | |
267 (let ((s (symbol-name | |
268 (or | |
269 (class-slot-initarg | |
270 (object-class-fast obj) | |
271 (car slots)) | |
272 (car slots))))) | |
273 (capitalize | |
274 (if (string-match "^:" s) | |
275 (substring s (match-end 0)) | |
276 s))))) | |
277 :value (slot-value obj (car slots)) | |
278 :doc (if (car fdoc) (car fdoc) | |
279 "Slot not Documented.") | |
280 :eieio-custom-visibility 'visible | |
281 ) | |
282 chil)) | |
283 ) | |
284 ) | |
285 (setq slots (cdr slots) | |
286 fdoc (cdr fdoc) | |
287 fcust (cdr fcust) | |
288 flabel (cdr flabel) | |
289 fgroup (cdr fgroup))) | |
290 (widget-put widget :children (nreverse chil)) | |
291 )) | |
292 | |
293 (defun eieio-object-value-get (widget) | |
294 "Get the value of WIDGET." | |
295 (let* ((obj (widget-get widget :value)) | |
296 (master-group eieio-cog) | |
297 (cv (class-v (object-class-fast obj))) | |
298 (fgroup (aref cv class-public-custom-group)) | |
299 (wids (widget-get widget :children)) | |
300 (name (if (widget-get widget :eieio-show-name) | |
301 (car (widget-apply (car wids) :value-inline)) | |
302 nil)) | |
303 (chil (if (widget-get widget :eieio-show-name) | |
304 (nthcdr 1 wids) wids)) | |
305 (cv (class-v (object-class-fast obj))) | |
306 (slots (aref cv class-public-a)) | |
307 (fcust (aref cv class-public-custom))) | |
308 ;; If there are any prefix widgets, clear them. | |
309 ;; -- None yet | |
310 ;; Create a batch of initargs for each slot. | |
311 (while (and slots chil) | |
312 (if (and (car fcust) | |
313 (or eieio-custom-ignore-eieio-co | |
314 (not master-group) (member master-group (car fgroup))) | |
315 (slot-boundp obj (car slots))) | |
316 (progn | |
317 ;; Only customized slots have widgets | |
318 (let ((eieio-custom-ignore-eieio-co t)) | |
319 (eieio-oset obj (car slots) | |
320 (car (widget-apply (car chil) :value-inline)))) | |
321 (setq chil (cdr chil)))) | |
322 (setq slots (cdr slots) | |
323 fgroup (cdr fgroup) | |
324 fcust (cdr fcust))) | |
325 ;; Set any name updates on it. | |
326 (if name (aset obj object-name name)) | |
327 ;; This is the same object we had before. | |
328 obj)) | |
329 | |
330 (defmethod eieio-done-customizing ((obj eieio-default-superclass)) | |
331 "When a applying change to a widget, call this method. | |
332 This method is called by the default widget-edit commands. User made | |
333 commands should also call this method when applying changes. | |
334 Argument OBJ is the object that has been customized." | |
335 nil) | |
336 | |
337 (defun customize-object (obj &optional group) | |
338 "Customize OBJ in a custom buffer. | |
339 Optional argument GROUP is the sub-group of slots to display." | |
340 (eieio-customize-object obj group)) | |
341 | |
342 (defmethod eieio-customize-object ((obj eieio-default-superclass) | |
343 &optional group) | |
344 "Customize OBJ in a specialized custom buffer. | |
345 To override call the `eieio-custom-widget-insert' to just insert the | |
346 object widget. | |
347 Optional argument GROUP specifies a subgroup of slots to edit as a symbol. | |
348 These groups are specified with the `:group' slot flag." | |
349 ;; Insert check for multiple edits here. | |
350 (let* ((g (or group 'default))) | |
351 (switch-to-buffer (get-buffer-create | |
352 (concat "*CUSTOMIZE " | |
353 (object-name obj) " " | |
354 (symbol-name g) "*"))) | |
355 (toggle-read-only -1) | |
356 (kill-all-local-variables) | |
357 (erase-buffer) | |
358 (let ((all (eieio-overlay-lists))) | |
359 ;; Delete all the overlays. | |
360 (mapc 'delete-overlay (car all)) | |
361 (mapc 'delete-overlay (cdr all))) | |
362 ;; Add an apply reset option at the top of the buffer. | |
363 (eieio-custom-object-apply-reset obj) | |
364 (widget-insert "\n\n") | |
365 (widget-insert "Edit object " (object-name obj) "\n\n") | |
366 ;; Create the widget editing the object. | |
367 (make-local-variable 'eieio-wo) | |
368 (setq eieio-wo (eieio-custom-widget-insert obj :eieio-group g)) | |
369 ;;Now generate the apply buttons | |
370 (widget-insert "\n") | |
371 (eieio-custom-object-apply-reset obj) | |
372 ;; Now initialize the buffer | |
373 (use-local-map widget-keymap) | |
374 (widget-setup) | |
375 ;;(widget-minor-mode) | |
376 (goto-char (point-min)) | |
377 (widget-forward 3) | |
378 (make-local-variable 'eieio-co) | |
379 (setq eieio-co obj) | |
380 (make-local-variable 'eieio-cog) | |
381 (setq eieio-cog group))) | |
382 | |
383 (defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass)) | |
384 "Insert an Apply and Reset button into the object editor. | |
385 Argument OBJ os the object being customized." | |
386 (widget-create 'push-button | |
387 :notify (lambda (&rest ignore) | |
388 (widget-apply eieio-wo :value-get) | |
389 (eieio-done-customizing eieio-co) | |
390 (bury-buffer)) | |
391 "Accept") | |
392 (widget-insert " ") | |
393 (widget-create 'push-button | |
394 :notify (lambda (&rest ignore) | |
395 ;; I think the act of getting it sets | |
396 ;; it's value through the get function. | |
397 (message "Applying Changes...") | |
398 (widget-apply eieio-wo :value-get) | |
399 (eieio-done-customizing eieio-co) | |
400 (message "Applying Changes...Done.")) | |
401 "Apply") | |
402 (widget-insert " ") | |
403 (widget-create 'push-button | |
404 :notify (lambda (&rest ignore) | |
405 (message "Resetting.") | |
406 (eieio-customize-object eieio-co eieio-cog)) | |
407 "Reset") | |
408 (widget-insert " ") | |
409 (widget-create 'push-button | |
410 :notify (lambda (&rest ignore) | |
411 (bury-buffer)) | |
412 "Cancel")) | |
413 | |
414 (defmethod eieio-custom-widget-insert ((obj eieio-default-superclass) | |
415 &rest flags) | |
416 "Insert the widget used for editing object OBJ in the current buffer. | |
417 Arguments FLAGS are widget compatible flags. | |
418 Must return the created widget." | |
419 (apply 'widget-create 'object-edit :value obj flags)) | |
420 | |
421 (define-widget 'object 'object-edit | |
422 "Instance of a CLOS class." | |
423 :format "%{%t%}:\n%v" | |
424 :value-to-internal 'eieio-object-value-to-abstract | |
425 :value-to-external 'eieio-object-abstract-to-value | |
426 :clone-object-children t | |
427 ) | |
428 | |
429 (defun eieio-object-value-to-abstract (widget value) | |
430 "For WIDGET, convert VALUE to an abstract /safe/ representation." | |
431 (if (eieio-object-p value) value | |
432 (if (null value) value | |
433 nil))) | |
434 | |
435 (defun eieio-object-abstract-to-value (widget value) | |
436 "For WIDGET, convert VALUE from an abstract /safe/ representation." | |
437 value) | |
438 | |
439 | |
440 ;;; customization group functions | |
441 ;; | |
442 ;; These functions provide the ability to create dynamic menus to | |
443 ;; customize specific sections of an object. They do not hook directly | |
444 ;; into a filter, but can be used to create easymenu vectors. | |
445 (defmethod eieio-customize-object-group ((obj eieio-default-superclass)) | |
446 "Create a list of vectors for customizing sections of OBJ." | |
447 (mapcar (lambda (group) | |
448 (vector (concat "Group " (symbol-name group)) | |
449 (list 'customize-object obj (list 'quote group)) | |
450 t)) | |
451 (class-option (object-class-fast obj) :custom-groups))) | |
452 | |
453 (defvar eieio-read-custom-group-history nil | |
454 "History for the custom group reader.") | |
455 | |
456 (defmethod eieio-read-customization-group ((obj eieio-default-superclass)) | |
457 "Do a completing read on the name of a customization group in OBJ. | |
458 Return the symbol for the group, or nil" | |
459 (let ((g (class-option (object-class-fast obj) :custom-groups))) | |
460 (if (= (length g) 1) | |
461 (car g) | |
462 ;; Make the association list | |
463 (setq g (mapcar (lambda (g) (cons (symbol-name g) g)) g)) | |
464 (cdr (assoc | |
465 (completing-read (concat (oref obj name) " Custom Group: ") | |
466 g nil t nil 'eieio-read-custom-group-history) | |
467 g))))) | |
468 | |
469 (provide 'eieio-custom) | |
470 | |
471 ;;; eieio-custom.el ends here |