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