]> code.delx.au - gnu-emacs/blob - lisp/cus-theme.el
df05a30738cb51db6515ced150840d7b00334dfe
[gnu-emacs] / lisp / cus-theme.el
1 ;;; cus-theme.el -- custom theme creation user interface
2 ;;
3 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
5 ;;
6 ;; Author: Alex Schroeder <alex@gnu.org>
7 ;; Maintainer: FSF
8 ;; Keywords: help, faces
9 ;; Package: emacs
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 ;;; Code:
27
28 (require 'widget)
29 (require 'cus-edit)
30
31 (eval-when-compile
32 (require 'wid-edit))
33
34 (defvar custom-new-theme-mode-map
35 (let ((map (make-keymap)))
36 (set-keymap-parent map widget-keymap)
37 (suppress-keymap map)
38 (define-key map "\C-x\C-s" 'custom-theme-write)
39 (define-key map "n" 'widget-forward)
40 (define-key map "p" 'widget-backward)
41 map)
42 "Keymap for `custom-new-theme-mode'.")
43
44 (define-derived-mode custom-new-theme-mode nil "Custom-Theme"
45 "Major mode for editing Custom themes.
46 Do not call this mode function yourself. It is meant for internal use."
47 (use-local-map custom-new-theme-mode-map)
48 (custom--initialize-widget-variables)
49 (set (make-local-variable 'revert-buffer-function) 'custom-theme-revert))
50 (put 'custom-new-theme-mode 'mode-class 'special)
51
52 (defvar custom-theme-name nil)
53 ;; Each element has the form (VAR CHECKBOX-WIDGET VAR-WIDGET)
54 (defvar custom-theme-variables nil)
55 ;; Each element has the form (FACE CHECKBOX-WIDGET FACE-WIDGET)
56 (defvar custom-theme-faces nil)
57 (defvar custom-theme-description nil)
58 (defvar custom-theme--migrate-settings nil)
59 (defvar custom-theme-insert-variable-marker nil)
60 (defvar custom-theme-insert-face-marker nil)
61
62 (defvar custom-theme--listed-faces '(default cursor fixed-pitch
63 variable-pitch escape-glyph minibuffer-prompt highlight region
64 shadow secondary-selection trailing-whitespace
65 font-lock-builtin-face font-lock-comment-delimiter-face
66 font-lock-comment-face font-lock-constant-face
67 font-lock-doc-face font-lock-function-name-face
68 font-lock-keyword-face font-lock-negation-char-face
69 font-lock-preprocessor-face font-lock-regexp-grouping-backslash
70 font-lock-regexp-grouping-construct font-lock-string-face
71 font-lock-type-face font-lock-variable-name-face
72 font-lock-warning-face button link link-visited fringe
73 header-line tooltip mode-line mode-line-buffer-id
74 mode-line-emphasis mode-line-highlight mode-line-inactive
75 isearch isearch-fail lazy-highlight match next-error
76 query-replace)
77 "Faces listed by default in the *Custom Theme* buffer.")
78
79 (defvar custom-theme--save-name)
80
81 ;;;###autoload
82 (defun customize-create-theme (&optional theme buffer)
83 "Create or edit a custom theme.
84 THEME, if non-nil, should be an existing theme to edit. If THEME
85 is `user', provide an option to remove these as custom settings.
86 BUFFER, if non-nil, should be a buffer to use; the default is
87 named *Custom Theme*."
88 (interactive)
89 (switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*")))
90 (let ((inhibit-read-only t))
91 (erase-buffer)
92 (dolist (ov (overlays-in (point-min) (point-max)))
93 (delete-overlay ov)))
94 (custom-new-theme-mode)
95 (make-local-variable 'custom-theme-name)
96 (set (make-local-variable 'custom-theme--save-name) theme)
97 (set (make-local-variable 'custom-theme-faces) nil)
98 (set (make-local-variable 'custom-theme-variables) nil)
99 (set (make-local-variable 'custom-theme-description) "")
100 (set (make-local-variable 'custom-theme--migrate-settings) nil)
101 (make-local-variable 'custom-theme-insert-face-marker)
102 (make-local-variable 'custom-theme-insert-variable-marker)
103 (make-local-variable 'custom-theme--listed-faces)
104
105 (if (eq theme 'user)
106 (widget-insert "This buffer contains all the Custom settings you have made.
107 You can convert them into a new custom theme, and optionally
108 remove them from your saved Custom file.\n\n"))
109
110 (widget-create 'push-button
111 :tag " Visit Theme "
112 :help-echo "Insert the settings of a pre-defined theme."
113 :action (lambda (widget &optional event)
114 (call-interactively 'custom-theme-visit-theme)))
115 (widget-insert " ")
116 (widget-create 'push-button
117 :tag " Merge Theme "
118 :help-echo "Merge in the settings of a pre-defined theme."
119 :action (lambda (widget &optional event)
120 (call-interactively 'custom-theme-merge-theme)))
121 (widget-insert " ")
122 (widget-create 'push-button
123 :tag " Revert "
124 :help-echo "Revert this buffer to its original state."
125 :action (lambda (&rest ignored) (revert-buffer)))
126
127 (widget-insert "\n\nTheme name : ")
128 (setq custom-theme-name
129 (widget-create 'editable-field
130 :value (if (and theme (not (eq theme 'user)))
131 (symbol-name theme)
132 "")))
133 (widget-insert "Description: ")
134 (setq custom-theme-description
135 (widget-create 'text
136 :value (format-time-string "Created %Y-%m-%d.")))
137 (widget-create 'push-button
138 :notify (function custom-theme-write)
139 " Save Theme ")
140 (when (eq theme 'user)
141 (setq custom-theme--migrate-settings t)
142 (widget-insert " ")
143 (widget-create 'checkbox
144 :value custom-theme--migrate-settings
145 :action (lambda (widget &optional event)
146 (when (widget-value widget)
147 (widget-toggle-action widget event)
148 (setq custom-theme--migrate-settings
149 (widget-value widget)))))
150 (widget-insert (propertize " Remove saved theme settings from Custom save file."
151 'face '(variable-pitch (:height 0.9)))))
152
153 (let (vars values faces face-specs)
154
155 ;; Load the theme settings.
156 (when theme
157 (unless (eq theme 'user)
158 (load-theme theme t))
159 (dolist (setting (get theme 'theme-settings))
160 (if (eq (car setting) 'theme-value)
161 (progn (push (nth 1 setting) vars)
162 (push (nth 3 setting) values))
163 (push (nth 1 setting) faces)
164 (push (nth 3 setting) face-specs))))
165
166 ;; If THEME is non-nil, insert all of that theme's faces.
167 ;; Otherwise, insert those in `custom-theme--listed-faces'.
168 (widget-insert "\n\n Theme faces:\n ")
169 (if theme
170 (while faces
171 (custom-theme-add-face-1 (pop faces) (pop face-specs)))
172 (dolist (face custom-theme--listed-faces)
173 (custom-theme-add-face-1 face nil)))
174 (setq custom-theme-insert-face-marker (point-marker))
175 (widget-insert " ")
176 (widget-create 'push-button
177 :tag "Insert Additional Face"
178 :help-echo "Add another face to this theme."
179 :follow-link 'mouse-face
180 :button-face 'custom-link
181 :mouse-face 'highlight
182 :pressed-face 'highlight
183 :action (lambda (widget &optional event)
184 (call-interactively 'custom-theme-add-face)))
185
186 ;; If THEME is non-nil, insert all of that theme's variables.
187 (widget-insert "\n\n Theme variables:\n ")
188 (if theme
189 (while vars
190 (if (eq (car vars) 'custom-enabled-themes)
191 (progn (pop vars) (pop values))
192 (custom-theme-add-var-1 (pop vars) (pop values)))))
193 (setq custom-theme-insert-variable-marker (point-marker))
194 (widget-insert " ")
195 (widget-create 'push-button
196 :tag "Insert Variable"
197 :help-echo "Add another variable to this theme."
198 :follow-link 'mouse-face
199 :button-face 'custom-link
200 :mouse-face 'highlight
201 :pressed-face 'highlight
202 :action (lambda (widget &optional event)
203 (call-interactively 'custom-theme-add-variable)))
204 (widget-insert ?\n)
205 (widget-setup)
206 (goto-char (point-min))
207 (message "")))
208
209 (defun custom-theme-revert (ignore-auto noconfirm)
210 (when (or noconfirm (y-or-n-p "Discard current changes? "))
211 (customize-create-theme custom-theme--save-name (current-buffer))))
212
213 ;;; Theme variables
214
215 (defun custom-theme-add-variable (var value)
216 "Add a widget for VAR (a symbol) to the *New Custom Theme* buffer.
217 VALUE should be a value to which to set the widget; when called
218 interactively, this defaults to the current value of VAR."
219 (interactive
220 (let ((v (read-variable "Variable name: ")))
221 (list v (symbol-value v))))
222 (let ((entry (assq var custom-theme-variables)))
223 (cond ((null entry)
224 ;; If VAR is not yet in the buffer, add it.
225 (save-excursion
226 (goto-char custom-theme-insert-variable-marker)
227 (custom-theme-add-var-1 var value)
228 (move-marker custom-theme-insert-variable-marker (point))
229 (widget-setup)))
230 ;; Otherwise, alter that var widget.
231 (t
232 (widget-value-set (nth 1 entry) t)
233 (let ((widget (nth 2 entry)))
234 (widget-put widget :shown-value (list value))
235 (custom-redraw widget))))))
236
237 (defun custom-theme-add-var-1 (symbol val)
238 (widget-insert " ")
239 (push (list symbol
240 (prog1 (widget-create 'checkbox
241 :value t
242 :help-echo "Enable/disable this variable.")
243 (widget-insert " "))
244 (widget-create 'custom-variable
245 :tag (custom-unlispify-tag-name symbol)
246 :value symbol
247 :shown-value (list val)
248 :notify 'ignore
249 :custom-level 0
250 :custom-state 'hidden
251 :custom-style 'simple))
252 custom-theme-variables)
253 (widget-insert " "))
254
255 ;;; Theme faces
256
257 (defun custom-theme-add-face (face &optional spec)
258 "Add a widget for FACE (a symbol) to the *New Custom Theme* buffer.
259 SPEC, if non-nil, should be a face spec to which to set the widget."
260 (interactive (list (read-face-name "Face name" nil nil) nil))
261 (unless (or (facep face) spec)
262 (error "`%s' has no face definition" face))
263 (let ((entry (assq face custom-theme-faces)))
264 (cond ((null entry)
265 ;; If FACE is not yet in the buffer, add it.
266 (save-excursion
267 (goto-char custom-theme-insert-face-marker)
268 (custom-theme-add-face-1 face spec)
269 (move-marker custom-theme-insert-face-marker (point))
270 (widget-setup)))
271 ;; Otherwise, if SPEC is supplied, alter that face widget.
272 (spec
273 (widget-value-set (nth 1 entry) t)
274 (let ((widget (nth 2 entry)))
275 (widget-put widget :shown-value spec)
276 (custom-redraw widget)))
277 ((called-interactively-p 'interactive)
278 (error "`%s' is already present" face)))))
279
280 (defun custom-theme-add-face-1 (symbol spec)
281 (widget-insert " ")
282 (push (list symbol
283 (prog1
284 (widget-create 'checkbox
285 :value t
286 :help-echo "Enable/disable this face.")
287 (widget-insert " "))
288 (widget-create 'custom-face
289 :tag (custom-unlispify-tag-name symbol)
290 :documentation-shown t
291 :value symbol
292 :custom-state 'hidden
293 :custom-style 'simple
294 :shown-value spec
295 :sample-indent 34))
296 custom-theme-faces)
297 (widget-insert " "))
298
299 ;;; Reading and writing
300
301 (defun custom-theme-visit-theme (theme)
302 "Load the custom theme THEME's settings into the current buffer."
303 (interactive
304 (list
305 (intern (completing-read "Find custom theme: "
306 (mapcar 'symbol-name
307 (custom-available-themes))))))
308 (unless (custom-theme-name-valid-p theme)
309 (error "No valid theme named `%s'" theme))
310 (cond ((not (eq major-mode 'custom-new-theme-mode))
311 (customize-create-theme theme))
312 ((y-or-n-p "Discard current changes? ")
313 (setq custom-theme--save-name theme)
314 (custom-theme-revert nil t))))
315
316 (defun custom-theme-merge-theme (theme)
317 "Merge the custom theme THEME's settings into the current buffer."
318 (interactive
319 (list
320 (intern (completing-read "Merge custom theme: "
321 (mapcar 'symbol-name
322 (custom-available-themes))))))
323 (unless (eq theme 'user)
324 (unless (custom-theme-name-valid-p theme)
325 (error "Invalid theme name `%s'" theme))
326 (load-theme theme t))
327 (let ((settings (reverse (get theme 'theme-settings))))
328 (dolist (setting settings)
329 (funcall (if (eq (car setting) 'theme-value)
330 'custom-theme-add-variable
331 'custom-theme-add-face)
332 (nth 1 setting)
333 (nth 3 setting))))
334 theme)
335
336 (defun custom-theme-write (&rest ignore)
337 "Write the current custom theme to its theme file."
338 (interactive)
339 (let* ((name (widget-value custom-theme-name))
340 (doc (widget-value custom-theme-description))
341 (vars custom-theme-variables)
342 (faces custom-theme-faces)
343 filename)
344 (when (string-equal name "")
345 (setq name (read-from-minibuffer "Theme name: " (user-login-name)))
346 (widget-value-set custom-theme-name name))
347 (unless (custom-theme-name-valid-p (intern name))
348 (error "Custom themes cannot be named `%s'" name))
349
350 (setq filename (expand-file-name (concat name "-theme.el")
351 custom-theme-directory))
352 (and (file-exists-p filename)
353 (not (y-or-n-p (format "File %s exists. Overwrite? " filename)))
354 (error "Aborted"))
355
356 (with-temp-buffer
357 (emacs-lisp-mode)
358 (unless (file-directory-p custom-theme-directory)
359 (make-directory (file-name-as-directory custom-theme-directory) t))
360 (setq buffer-file-name filename)
361 (erase-buffer)
362 (insert "(deftheme " name)
363 (if doc (insert "\n \"" doc "\""))
364 (insert ")\n")
365 (custom-theme-write-variables name (reverse vars))
366 (custom-theme-write-faces name (reverse faces))
367 (insert "\n(provide-theme '" name ")\n")
368 (save-buffer))
369 (message "Theme written to %s" filename)
370
371 (when custom-theme--migrate-settings
372 ;; Remove these settings from the Custom file.
373 (let ((custom-reset-standard-variables-list '(t))
374 (custom-reset-standard-faces-list '(t)))
375 (dolist (var vars)
376 (when (and (not (eq (car var) 'custom-enabled-themes))
377 (widget-get (nth 1 var) :value))
378 (widget-apply (nth 2 var) :custom-mark-to-reset-standard)))
379 (dolist (face faces)
380 (when (widget-get (nth 1 face) :value)
381 (widget-apply (nth 2 face) :custom-mark-to-reset-standard)))
382 (custom-save-all))
383 (let ((custom-theme-load-path (list 'custom-theme-directory)))
384 (load-theme (intern name))))))
385
386 (defun custom-theme-write-variables (theme vars)
387 "Write a `custom-theme-set-variables' command for THEME.
388 It includes all variables in list VARS."
389 (when vars
390 (let ((standard-output (current-buffer)))
391 (princ "\n(custom-theme-set-variables\n")
392 (princ " '")
393 (princ theme)
394 (princ "\n")
395 (dolist (spec vars)
396 (when (widget-get (nth 1 spec) :value)
397 (let* ((symbol (nth 0 spec))
398 (widget (nth 2 spec))
399 (child (car-safe (widget-get widget :children)))
400 (value (if child
401 (widget-value child)
402 ;; Child is null if the widget is closed (hidden).
403 (car (widget-get widget :shown-value)))))
404 (when (boundp symbol)
405 (unless (bolp)
406 (princ "\n"))
407 (princ " '(")
408 (prin1 symbol)
409 (princ " ")
410 (prin1 (custom-quote value))
411 (princ ")")))))
412 (if (bolp)
413 (princ " "))
414 (princ ")")
415 (unless (looking-at "\n")
416 (princ "\n")))))
417
418 (defun custom-theme-write-faces (theme faces)
419 "Write a `custom-theme-set-faces' command for THEME.
420 It includes all faces in list FACES."
421 (when faces
422 (let ((standard-output (current-buffer)))
423 (princ "\n(custom-theme-set-faces\n")
424 (princ " '")
425 (princ theme)
426 (princ "\n")
427 (dolist (spec faces)
428 (when (widget-get (nth 1 spec) :value)
429 (let* ((symbol (nth 0 spec))
430 (widget (nth 2 spec))
431 (value
432 (if (car-safe (widget-get widget :children))
433 (custom-face-widget-to-spec widget)
434 ;; Child is null if the widget is closed (hidden).
435 (widget-get widget :shown-value))))
436 (when (and (facep symbol) value)
437 (princ (if (bolp) " '(" "\n '("))
438 (prin1 symbol)
439 (princ " ")
440 (prin1 value)
441 (princ ")")))))
442 (if (bolp) (princ " "))
443 (princ ")")
444 (unless (looking-at "\n")
445 (princ "\n")))))
446
447 \f
448 ;;; Describing Custom themes.
449
450 ;;;###autoload
451 (defun describe-theme (theme)
452 "Display a description of the Custom theme THEME (a symbol)."
453 (interactive
454 (list
455 (intern (completing-read "Describe custom theme: "
456 (mapcar 'symbol-name
457 (custom-available-themes))))))
458 (unless (custom-theme-name-valid-p theme)
459 (error "Invalid theme name `%s'" theme))
460 (help-setup-xref (list 'describe-theme theme)
461 (called-interactively-p 'interactive))
462 (with-help-window (help-buffer)
463 (with-current-buffer standard-output
464 (describe-theme-1 theme))))
465
466 (defun describe-theme-1 (theme)
467 (prin1 theme)
468 (princ " is a custom theme")
469 (let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
470 (custom-theme--load-path)
471 '("" "c")))
472 doc)
473 (when fn
474 (princ " in `")
475 (help-insert-xref-button (file-name-nondirectory fn)
476 'help-theme-def fn)
477 (princ "'"))
478 (princ ".\n")
479 (if (not (memq theme custom-known-themes))
480 (progn
481 (princ "It is not loaded.")
482 ;; Attempt to grab the theme documentation
483 (when fn
484 (with-temp-buffer
485 (insert-file-contents fn)
486 (let ((sexp (let ((read-circle nil))
487 (condition-case nil
488 (read (current-buffer))
489 (end-of-file nil)))))
490 (and sexp (listp sexp)
491 (eq (car sexp) 'deftheme)
492 (setq doc (nth 2 sexp)))))))
493 (if (custom-theme-enabled-p theme)
494 (princ "It is loaded and enabled.")
495 (princ "It is loaded but disabled."))
496 (setq doc (get theme 'theme-documentation)))
497
498 (princ "\n\nDocumentation:\n")
499 (princ (if (stringp doc)
500 doc
501 "No documentation available.")))
502 (princ "\n\nYou can ")
503 (help-insert-xref-button "customize" 'help-theme-edit theme)
504 (princ " this theme."))
505
506 \f
507 ;;; Theme chooser
508
509 (defvar custom--listed-themes)
510
511 (defcustom custom-theme-allow-multiple-selections nil
512 "Whether to allow multi-selections in the *Custom Themes* buffer."
513 :type 'boolean
514 :group 'custom-buffer)
515
516 (defvar custom-theme-choose-mode-map
517 (let ((map (make-keymap)))
518 (set-keymap-parent map widget-keymap)
519 (suppress-keymap map)
520 (define-key map "\C-x\C-s" 'custom-theme-save)
521 (define-key map "n" 'widget-forward)
522 (define-key map "p" 'widget-backward)
523 (define-key map "?" 'custom-describe-theme)
524 map)
525 "Keymap for `custom-theme-choose-mode'.")
526
527 (define-derived-mode custom-theme-choose-mode nil "Themes"
528 "Major mode for selecting Custom themes.
529 Do not call this mode function yourself. It is meant for internal use."
530 (use-local-map custom-theme-choose-mode-map)
531 (custom--initialize-widget-variables)
532 (set (make-local-variable 'revert-buffer-function)
533 (lambda (ignore-auto noconfirm)
534 (when (or noconfirm (y-or-n-p "Discard current choices? "))
535 (customize-themes (current-buffer))))))
536 (put 'custom-theme-choose-mode 'mode-class 'special)
537
538 ;;;###autoload
539 (defun customize-themes (&optional buffer)
540 "Display a selectable list of Custom themes.
541 When called from Lisp, BUFFER should be the buffer to use; if
542 omitted, a buffer named *Custom Themes* is used."
543 (interactive)
544 (switch-to-buffer (get-buffer-create (or buffer "*Custom Themes*")))
545 (let ((inhibit-read-only t))
546 (erase-buffer))
547 (custom-theme-choose-mode)
548 (set (make-local-variable 'custom--listed-themes) nil)
549 (make-local-variable 'custom-theme-allow-multiple-selections)
550 (and (null custom-theme-allow-multiple-selections)
551 (> (length custom-enabled-themes) 1)
552 (setq custom-theme-allow-multiple-selections t))
553
554 (widget-insert
555 (substitute-command-keys
556 "Type RET or click to enable/disable listed custom themes.
557 Type \\[custom-describe-theme] to describe the theme at point.
558 Theme files are named *-theme.el in `"))
559 (widget-create 'link :value "custom-theme-load-path"
560 :button-face 'custom-link
561 :mouse-face 'highlight
562 :pressed-face 'highlight
563 :help-echo "Describe `custom-theme-load-path'."
564 :keymap custom-mode-link-map
565 :follow-link 'mouse-face
566 :action (lambda (widget &rest ignore)
567 (describe-variable 'custom-theme-load-path)))
568 (widget-insert "'.\n\n")
569
570 ;; If the user has made customizations, display a warning and
571 ;; provide buttons to disable or convert them.
572 (let ((user-settings (get 'user 'theme-settings)))
573 (unless (or (null user-settings)
574 (and (null (cdr user-settings))
575 (eq (caar user-settings) 'theme-value)
576 (eq (cadr (car user-settings)) 'custom-enabled-themes)))
577 (widget-insert
578 (propertize
579 " Note: Your custom settings take precedence over theme settings.
580 To migrate your settings into a theme, click "
581 'face 'font-lock-warning-face))
582 (widget-create 'link :value "here"
583 :button-face 'custom-link
584 :mouse-face 'highlight
585 :pressed-face 'highlight
586 :help-echo "Migrate."
587 :keymap custom-mode-link-map
588 :follow-link 'mouse-face
589 :action (lambda (widget &rest ignore)
590 (customize-create-theme 'user)))
591 (widget-insert ".\n\n")))
592
593 (widget-create 'push-button
594 :tag " Save Theme Settings "
595 :help-echo "Save the selected themes for future sessions."
596 :action 'custom-theme-save)
597 (widget-insert ?\n)
598 (widget-create 'checkbox
599 :value custom-theme-allow-multiple-selections
600 :action 'custom-theme-selections-toggle)
601 (widget-insert (propertize " Allow more than one theme at a time"
602 'face '(variable-pitch (:height 0.9))))
603
604 (widget-insert "\n\nAvailable Custom Themes:\n")
605 (let (widget)
606 (dolist (theme (custom-available-themes))
607 (setq widget (widget-create 'checkbox
608 :value (custom-theme-enabled-p theme)
609 :theme-name theme
610 :action 'custom-theme-checkbox-toggle))
611 (push (cons theme widget) custom--listed-themes)
612 (widget-create-child-and-convert widget 'push-button
613 :button-face-get 'ignore
614 :mouse-face-get 'ignore
615 :value (format " %s" theme)
616 :action 'widget-parent-action)
617 (widget-insert ?\n)))
618 (goto-char (point-min))
619 (widget-setup))
620
621 (defun custom-theme-checkbox-toggle (widget &optional event)
622 (let ((this-theme (widget-get widget :theme-name)))
623 (if (widget-value widget)
624 ;; Disable the theme.
625 (disable-theme this-theme)
626 ;; Enable the theme.
627 (unless custom-theme-allow-multiple-selections
628 ;; If only one theme is allowed, disable all other themes and
629 ;; uncheck their boxes.
630 (dolist (theme custom-enabled-themes)
631 (and (not (eq theme this-theme))
632 (assq theme custom--listed-themes)
633 (disable-theme theme)))
634 (dolist (theme custom--listed-themes)
635 (unless (eq (car theme) this-theme)
636 (widget-value-set (cdr theme) nil)
637 (widget-apply (cdr theme) :notify (cdr theme) event))))
638 (load-theme this-theme)))
639 ;; Mark `custom-enabled-themes' as "set for current session".
640 (put 'custom-enabled-themes 'customized-value
641 (list (custom-quote custom-enabled-themes)))
642 ;; Check/uncheck the widget.
643 (widget-toggle-action widget event))
644
645 (defun custom-describe-theme ()
646 "Describe the Custom theme on the current line."
647 (interactive)
648 (let ((widget (widget-at (line-beginning-position))))
649 (and widget
650 (describe-theme (widget-get widget :theme-name)))))
651
652 (defun custom-theme-save (&rest ignore)
653 (interactive)
654 (customize-save-variable 'custom-enabled-themes custom-enabled-themes)
655 (message "Custom themes saved for future sessions."))
656
657 (defun custom-theme-selections-toggle (widget &optional event)
658 (when (widget-value widget)
659 ;; Deactivate multiple-selections.
660 (if (< 1 (length (delq nil (mapcar (lambda (x) (widget-value (cdr x)))
661 custom--listed-themes))))
662 (error "More than one theme is currently selected")))
663 (widget-toggle-action widget event)
664 (setq custom-theme-allow-multiple-selections (widget-value widget)))
665
666 ;;; cus-theme.el ends here