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