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