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