1 ;;; cus-theme.el -- custom theme creation user interface
3 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
4 ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Alex Schroeder <alex@gnu.org>
8 ;; Keywords: help, faces
11 ;; This file is part of GNU Emacs.
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.
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.
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/>.
34 (defvar custom-new-theme-mode-map
35 (let ((map (make-keymap)))
36 (set-keymap-parent map widget-keymap
)
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
)
42 "Keymap for `custom-new-theme-mode'.")
44 (define-derived-mode custom-new-theme-mode nil
"Cus-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
)
52 (defvar custom-theme-name nil
)
53 (defvar custom-theme-variables nil
)
54 (defvar custom-theme-faces nil
)
55 (defvar custom-theme-description nil
)
56 (defvar custom-theme-insert-variable-marker nil
)
57 (defvar custom-theme-insert-face-marker nil
)
59 (defvar custom-theme--listed-faces
'(default cursor fixed-pitch
60 variable-pitch escape-glyph minibuffer-prompt highlight region
61 shadow secondary-selection trailing-whitespace
62 font-lock-builtin-face font-lock-comment-delimiter-face
63 font-lock-comment-face font-lock-constant-face
64 font-lock-doc-face font-lock-function-name-face
65 font-lock-keyword-face font-lock-negation-char-face
66 font-lock-preprocessor-face font-lock-regexp-grouping-backslash
67 font-lock-regexp-grouping-construct font-lock-string-face
68 font-lock-type-face font-lock-variable-name-face
69 font-lock-warning-face button link link-visited fringe
70 header-line tooltip mode-line mode-line-buffer-id
71 mode-line-emphasis mode-line-highlight mode-line-inactive
72 isearch isearch-fail lazy-highlight match next-error
74 "Faces listed by default in the *Custom Theme* buffer.")
76 (defvar custom-theme--save-name
)
79 (defun customize-create-theme (&optional theme buffer
)
80 "Create or edit a custom theme.
81 THEME, if non-nil, should be an existing theme to edit.
82 BUFFER, if non-nil, should be a buffer to use."
84 (switch-to-buffer (get-buffer-create (or buffer
"*Custom Theme*")))
86 (let ((inhibit-read-only t
))
88 (custom-new-theme-mode)
89 (make-local-variable 'custom-theme-name
)
90 (set (make-local-variable 'custom-theme--save-name
) theme
)
91 (set (make-local-variable 'custom-theme-faces
) nil
)
92 (set (make-local-variable 'custom-theme-variables
) nil
)
93 (set (make-local-variable 'custom-theme-description
) "")
94 (make-local-variable 'custom-theme-insert-face-marker
)
95 (make-local-variable 'custom-theme-insert-variable-marker
)
96 (make-local-variable 'custom-theme--listed-faces
)
98 (widget-create 'push-button
100 :help-echo
"Insert the settings of a pre-defined theme."
101 :action
(lambda (widget &optional event
)
102 (call-interactively 'custom-theme-visit-theme
)))
104 (widget-create 'push-button
106 :help-echo
"Merge in the settings of a pre-defined theme."
107 :action
(lambda (widget &optional event
)
108 (call-interactively 'custom-theme-merge-theme
)))
110 (widget-create 'push-button
:notify
'revert-buffer
" Revert ")
112 (widget-insert "\n\nTheme name : ")
113 (setq custom-theme-name
114 (widget-create 'editable-field
115 :value
(if theme
(symbol-name theme
) "")))
116 (widget-insert "Description: ")
117 (setq custom-theme-description
119 :value
(format-time-string "Created %Y-%m-%d.")))
121 (widget-create 'push-button
122 :notify
(function custom-theme-write
)
125 (widget-insert "\n\n Theme faces:\n")
127 (dolist (face custom-theme--listed-faces
)
129 (setq widget
(widget-create 'custom-face
130 :documentation-shown t
131 :tag
(custom-unlispify-tag-name face
)
133 :display-style
'concise
134 :custom-state
'hidden
136 (custom-magic-reset widget
)
137 (push (cons face widget
) custom-theme-faces
)))
139 (setq custom-theme-insert-face-marker
(point-marker))
141 (widget-create 'push-button
142 :tag
"Insert Additional Face"
143 :help-echo
"Add another face to this theme."
144 :follow-link
'mouse-face
145 :button-face
'custom-link
146 :mouse-face
'highlight
147 :pressed-face
'highlight
148 :action
(lambda (widget &optional event
)
149 (call-interactively 'custom-theme-add-face
)))
150 (widget-insert "\n\n Theme variables:\n ")
151 (setq custom-theme-insert-variable-marker
(point-marker))
153 (widget-create 'push-button
154 :tag
"Insert Variable"
155 :help-echo
"Add another variable to this theme."
156 :follow-link
'mouse-face
157 :button-face
'custom-link
158 :mouse-face
'highlight
159 :pressed-face
'highlight
160 :action
(lambda (widget &optional event
)
161 (call-interactively 'custom-theme-add-variable
)))
164 (custom-theme-merge-theme theme
))
166 (goto-char (point-min))
169 (defun custom-theme-revert (ignore-auto noconfirm
)
170 (when (or noconfirm
(y-or-n-p "Discard current changes? "))
171 (customize-create-theme custom-theme--save-name
(current-buffer))))
175 (defun custom-theme-add-variable (symbol)
176 (interactive "vVariable name: ")
177 (cond ((assq symbol custom-theme-variables
)
178 (message "%s is already in the theme" (symbol-name symbol
)))
179 ((not (boundp symbol
))
180 (message "%s is not defined as a variable" (symbol-name symbol
)))
181 ((eq symbol
'custom-enabled-themes
)
182 (message "Custom theme cannot contain `custom-enabled-themes'"))
185 (goto-char custom-theme-insert-variable-marker
)
187 (let ((widget (widget-create 'custom-variable
188 :tag
(custom-unlispify-tag-name symbol
)
190 :action
'custom-theme-variable-action
191 :custom-state
'unknown
193 (push (cons symbol widget
) custom-theme-variables
)
194 (custom-magic-reset widget
))
196 (move-marker custom-theme-insert-variable-marker
(point))
199 (defvar custom-theme-variable-menu
200 `(("Reset to Current" custom-redraw
202 (and (boundp (widget-value widget
))
203 (memq (widget-get widget
:custom-state
)
204 '(themed modified changed
)))))
205 ("Reset to Theme Value" custom-variable-reset-theme
207 (let ((theme (intern (widget-value custom-theme-name
)))
208 (symbol (widget-value widget
))
210 (and (custom-theme-p theme
)
211 (dolist (setting (get theme
'theme-settings
) found
)
212 (if (and (eq (cadr setting
) symbol
)
213 (eq (car setting
) 'theme-value
))
215 ("---" ignore ignore
)
216 ("Delete" custom-theme-delete-variable nil
))
217 "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
218 See the documentation for `custom-variable'.")
220 (defun custom-theme-variable-action (widget &optional event
)
221 "Show the Custom Theme Mode menu for a `custom-variable' widget.
222 Optional EVENT is the location for the menu."
223 (let ((custom-variable-menu custom-theme-variable-menu
))
224 (custom-variable-action widget event
)))
226 (defun custom-variable-reset-theme (widget)
227 "Reset WIDGET to its value for the currently edited theme."
228 (let ((theme (intern (widget-value custom-theme-name
)))
229 (symbol (widget-value widget
))
231 (dolist (setting (get theme
'theme-settings
))
232 (if (and (eq (cadr setting
) symbol
)
233 (eq (car setting
) 'theme-value
))
234 (setq found setting
)))
235 (widget-value-set (car (widget-get widget
:children
))
237 (widget-put widget
:custom-state
'themed
)
238 (custom-redraw-magic widget
)
241 (defun custom-theme-delete-variable (widget)
242 (setq custom-theme-variables
243 (assq-delete-all (widget-value widget
) custom-theme-variables
))
244 (widget-delete widget
))
248 (defun custom-theme-add-face (symbol)
249 (interactive (list (read-face-name "Face name" nil nil
)))
250 (cond ((assq symbol custom-theme-faces
)
251 (message "%s is already in the theme" (symbol-name symbol
)))
252 ((not (facep symbol
))
253 (message "%s is not defined as a face" (symbol-name symbol
)))
256 (goto-char custom-theme-insert-face-marker
)
258 (let ((widget (widget-create 'custom-face
259 :tag
(custom-unlispify-tag-name symbol
)
261 :action
'custom-theme-face-action
262 :custom-state
'unknown
263 :display-style
'concise
266 (push (cons symbol widget
) custom-theme-faces
)
267 (custom-magic-reset widget
)
269 (move-marker custom-theme-insert-face-marker
(point))
272 (defvar custom-theme-face-menu
273 `(("Reset to Theme Value" custom-face-reset-theme
275 (let ((theme (intern (widget-value custom-theme-name
)))
276 (symbol (widget-value widget
))
278 (and (custom-theme-p theme
)
279 (dolist (setting (get theme
'theme-settings
) found
)
280 (if (and (eq (cadr setting
) symbol
)
281 (eq (car setting
) 'theme-face
))
283 ("---" ignore ignore
)
284 ("Delete" custom-theme-delete-face nil
))
285 "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
286 See the documentation for `custom-variable'.")
288 (defun custom-theme-face-action (widget &optional event
)
289 "Show the Custom Theme Mode menu for a `custom-face' widget.
290 Optional EVENT is the location for the menu."
291 (let ((custom-face-menu custom-theme-face-menu
))
292 (custom-face-action widget event
)))
294 (defun custom-face-reset-theme (widget)
295 "Reset WIDGET to its value for the currently edited theme."
296 (let ((theme (intern (widget-value custom-theme-name
)))
297 (symbol (widget-value widget
))
299 (dolist (setting (get theme
'theme-settings
))
300 (if (and (eq (cadr setting
) symbol
)
301 (eq (car setting
) 'theme-face
))
302 (setq found setting
)))
303 (widget-value-set (car (widget-get widget
:children
))
305 (widget-put widget
:custom-state
'themed
)
306 (custom-redraw-magic widget
)
309 (defun custom-theme-delete-face (widget)
310 (setq custom-theme-faces
311 (assq-delete-all (widget-value widget
) custom-theme-faces
))
312 (widget-delete widget
))
314 ;;; Reading and writing
316 (defun custom-theme-visit-theme ()
318 (when (and (y-or-n-p "Discard current changes? ")
319 (progn (revert-buffer) t
))
320 (let ((theme (call-interactively 'custom-theme-merge-theme
)))
321 (unless (eq theme
'user
)
322 (widget-value-set custom-theme-name
(symbol-name theme
)))
323 (widget-value-set custom-theme-description
324 (or (get theme
'theme-documentation
)
325 (format-time-string "Created %Y-%m-%d.")))
328 (defun custom-theme-merge-theme (theme)
331 (intern (completing-read "Merge custom theme: "
333 (custom-available-themes))))))
334 (unless (custom-theme-name-valid-p theme
)
335 (error "Invalid theme name `%s'" theme
))
337 (let ((settings (get theme
'theme-settings
)))
338 (dolist (setting settings
)
339 (if (eq (car setting
) 'theme-value
)
340 (custom-theme-add-variable (cadr setting
))
341 (custom-theme-add-face (cadr setting
)))))
342 (disable-theme theme
)
345 (defun custom-theme-write (&rest ignore
)
347 (let* ((name (widget-value custom-theme-name
))
348 (doc (widget-value custom-theme-description
))
349 (vars custom-theme-variables
)
350 (faces custom-theme-faces
)
352 (when (string-equal name
"")
353 (setq name
(read-from-minibuffer "Theme name: " (user-login-name)))
354 (widget-value-set custom-theme-name name
))
355 (unless (custom-theme-name-valid-p (intern name
))
356 (error "Custom themes cannot be named `%s'" name
))
358 (setq filename
(expand-file-name (concat name
"-theme.el")
359 custom-theme-directory
))
360 (and (file-exists-p filename
)
361 (not (y-or-n-p (format "File %s exists. Overwrite? " filename
)))
366 (unless (file-exists-p custom-theme-directory
)
367 (make-directory (file-name-as-directory custom-theme-directory
) t
))
368 (setq buffer-file-name filename
)
370 (insert "(deftheme " name
)
371 (if doc
(insert "\n \"" doc
"\""))
373 (custom-theme-write-variables name vars
)
374 (custom-theme-write-faces name faces
)
375 (insert "\n(provide-theme '" name
")\n")
378 (when (widget-get (cdr var
) :children
)
379 (widget-put (cdr var
) :custom-state
'saved
)
380 (custom-redraw-magic (cdr var
))))
381 (dolist (face custom-theme-faces
)
382 (when (widget-get (cdr face
) :children
)
383 (widget-put (cdr face
) :custom-state
'saved
)
384 (custom-redraw-magic (cdr face
))))
385 (message "Theme written to %s" filename
)))
387 (defun custom-theme-write-variables (theme vars
)
388 "Write a `custom-theme-set-variables' command for THEME.
389 It includes all variables in list VARS."
391 (let ((standard-output (current-buffer)))
392 (princ "\n(custom-theme-set-variables\n")
397 (let* ((symbol (car spec
))
398 (child (car-safe (widget-get (cdr spec
) :children
)))
401 ;; For hidden widgets, use the standard value
402 (get symbol
'standard-value
))))
403 (when (boundp symbol
)
409 (prin1 (custom-quote value
))
414 (unless (looking-at "\n")
417 (defun custom-theme-write-faces (theme faces
)
418 "Write a `custom-theme-set-faces' command for THEME.
419 It includes all faces in list FACES."
421 (let ((standard-output (current-buffer)))
422 (princ "\n(custom-theme-set-faces\n")
427 (let* ((symbol (car spec
))
429 (child (car-safe (widget-get widget
:children
)))
431 (widget-get widget
:custom-state
)
432 (custom-face-state symbol
)))
434 (cond ((eq state
'standard
)
437 (custom-face-widget-to-spec widget
))
439 ;; Widget is closed (hidden), but the face has
440 ;; a non-standard value. Try to extract that
441 ;; value and save it.
442 (custom-face-get-current-spec symbol
)))))
443 (when (and (facep symbol
) value
)
454 (unless (looking-at "\n")
458 ;;; Describing Custom themes.
461 (defun describe-theme (theme)
462 "Display a description of the Custom theme THEME (a symbol)."
465 (intern (completing-read "Describe custom theme: "
467 (custom-available-themes))))))
468 (unless (custom-theme-name-valid-p theme
)
469 (error "Invalid theme name `%s'" theme
))
470 (help-setup-xref (list 'describe-theme theme
)
471 (called-interactively-p 'interactive
))
472 (with-help-window (help-buffer)
473 (with-current-buffer standard-output
474 (describe-theme-1 theme
))))
476 (defun describe-theme-1 (theme)
478 (princ " is a custom theme")
479 (let ((fn (locate-file (concat (symbol-name theme
) "-theme.el")
480 (cons custom-theme-directory load-path
)
485 (help-insert-xref-button (file-name-nondirectory fn
)
489 (if (not (memq theme custom-known-themes
))
491 (princ "It is not loaded.")
492 ;; Attempt to grab the theme documentation
495 (insert-file-contents fn
)
496 (let ((sexp (let ((read-circle nil
))
498 (read (current-buffer))
499 (end-of-file nil
)))))
500 (and sexp
(listp sexp
)
501 (eq (car sexp
) 'deftheme
)
502 (setq doc
(nth 2 sexp
)))))))
503 (if (custom-theme-enabled-p theme
)
504 (princ "It is loaded and enabled.")
505 (princ "It is loaded but disabled."))
506 (setq doc
(get theme
'theme-documentation
)))
508 (princ "\n\nDocumentation:\n")
509 (princ (if (stringp doc
)
511 "No documentation available.")))
512 (princ "\n\nYou can ")
513 (help-insert-xref-button "customize" 'help-theme-edit theme
)
514 (princ " this theme."))
519 (defvar custom--listed-themes
)
521 (defcustom custom-theme-allow-multiple-selections nil
522 "Whether to allow multi-selections in the *Custom Themes* buffer."
524 :group
'custom-buffer
)
526 (defvar custom-theme-choose-mode-map
527 (let ((map (make-keymap)))
528 (set-keymap-parent map widget-keymap
)
529 (suppress-keymap map
)
530 (define-key map
"\C-x\C-s" 'custom-theme-save
)
531 (define-key map
"n" 'widget-forward
)
532 (define-key map
"p" 'widget-backward
)
533 (define-key map
"?" 'custom-describe-theme
)
535 "Keymap for `custom-theme-choose-mode'.")
537 (define-derived-mode custom-theme-choose-mode nil
"Cus-Theme"
538 "Major mode for selecting Custom themes.
539 Do not call this mode function yourself. It is meant for internal use."
540 (use-local-map custom-theme-choose-mode-map
)
541 (custom--initialize-widget-variables)
542 (set (make-local-variable 'revert-buffer-function
)
543 (lambda (ignore-auto noconfirm
)
544 (when (or noconfirm
(y-or-n-p "Discard current choices? "))
545 (customize-themes (current-buffer))))))
546 (put 'custom-theme-choose-mode
'mode-class
'special
)
549 (defun customize-themes (&optional buffer
)
550 "Display a selectable list of Custom themes.
551 When called from Lisp, BUFFER should be the buffer to use; if
552 omitted, a buffer named *Custom Themes* is used."
554 (pop-to-buffer (get-buffer-create (or buffer
"*Custom Themes*")))
555 (let ((inhibit-read-only t
))
557 (custom-theme-choose-mode)
558 (set (make-local-variable 'custom--listed-themes
) nil
)
559 (make-local-variable 'custom-theme-allow-multiple-selections
)
560 (and (null custom-theme-allow-multiple-selections
)
561 (> (length custom-enabled-themes
) 1)
562 (setq custom-theme-allow-multiple-selections t
))
565 (substitute-command-keys
566 "Type RET or click to enable/disable listed custom themes.
567 Type \\[custom-describe-theme] to describe the theme at point.
568 Theme files are named *-theme.el in `"))
569 (when (stringp custom-theme-directory
)
570 (widget-create 'link
:value custom-theme-directory
571 :button-face
'custom-link
572 :mouse-face
'highlight
573 :pressed-face
'highlight
574 :help-echo
"Describe `custom-theme-directory'."
575 :keymap custom-mode-link-map
576 :follow-link
'mouse-face
577 :action
(lambda (widget &rest ignore
)
578 (describe-variable 'custom-theme-directory
)))
579 (widget-insert "' or `"))
580 (widget-create 'link
:value
"load-path"
581 :button-face
'custom-link
582 :mouse-face
'highlight
583 :pressed-face
'highlight
584 :help-echo
"Describe `load-path'."
585 :keymap custom-mode-link-map
586 :follow-link
'mouse-face
587 :action
(lambda (widget &rest ignore
)
588 (describe-variable 'load-path
)))
589 (widget-insert "'.\n\n")
590 (widget-create 'push-button
591 :tag
" Save Theme Settings "
592 :help-echo
"Save the selected themes for future sessions."
593 :action
'custom-theme-save
)
595 (widget-create 'checkbox
596 :value custom-theme-allow-multiple-selections
597 :action
'custom-theme-selections-toggle
)
598 (widget-insert (propertize " Allow more than one theme at a time"
599 'face
'(variable-pitch (:height
0.9))))
601 (widget-insert "\n\nAvailable Custom Themes:\n")
603 (dolist (theme (custom-available-themes))
604 (setq widget
(widget-create 'checkbox
605 :value
(custom-theme-enabled-p theme
)
607 :action
'custom-theme-checkbox-toggle
))
608 (push (cons theme widget
) custom--listed-themes
)
609 (widget-create-child-and-convert widget
'push-button
610 :button-face-get
'ignore
611 :mouse-face-get
'ignore
612 :value
(format " %s" theme
)
613 :action
'widget-parent-action
)
614 (widget-insert ?
\n)))
615 (goto-char (point-min))
618 (defun custom-theme-checkbox-toggle (widget &optional event
)
619 (let ((this-theme (widget-get widget
:theme-name
)))
620 (if (widget-value widget
)
621 ;; Disable the theme.
622 (disable-theme this-theme
)
624 (unless custom-theme-allow-multiple-selections
625 ;; If only one theme is allowed, disable all other themes and
626 ;; uncheck their boxes.
627 (dolist (theme custom-enabled-themes
)
628 (and (not (eq theme this-theme
))
629 (assq theme custom--listed-themes
)
630 (disable-theme theme
)))
631 (dolist (theme custom--listed-themes
)
632 (unless (eq (car theme
) this-theme
)
633 (widget-value-set (cdr theme
) nil
)
634 (widget-apply (cdr theme
) :notify
(cdr theme
) event
))))
635 (load-theme this-theme
)))
636 ;; Mark `custom-enabled-themes' as "set for current session".
637 (put 'custom-enabled-themes
'customized-value
638 (list (custom-quote custom-enabled-themes
)))
639 ;; Check/uncheck the widget.
640 (widget-toggle-action widget event
))
642 (defun custom-describe-theme ()
643 "Describe the Custom theme on the current line."
645 (let ((widget (widget-at (line-beginning-position))))
647 (describe-theme (widget-get widget
:theme-name
)))))
649 (defun custom-theme-save (&rest ignore
)
651 (customize-save-variable 'custom-enabled-themes custom-enabled-themes
)
652 (message "Custom themes saved for future sessions."))
654 (defun custom-theme-selections-toggle (widget &optional event
)
655 (when (widget-value widget
)
656 ;; Deactivate multiple-selections.
657 (if (> (length (delq nil
(mapcar (lambda (x) (widget-value (cdr x
)))
658 custom--listed-themes
)))
660 (error "More than one theme is currently selected")))
661 (widget-toggle-action widget event
)
662 (setq custom-theme-allow-multiple-selections
(widget-value widget
)))
664 ;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
665 ;;; cus-theme.el ends here