Commit | Line | Data |
---|---|---|
3656dac0 RS |
1 | ;;; cus-theme.el -- custom theme creation user interface |
2 | ;; | |
ba318903 | 3 | ;; Copyright (C) 2001-2014 Free Software Foundation, Inc. |
3656dac0 RS |
4 | ;; |
5 | ;; Author: Alex Schroeder <alex@gnu.org> | |
34dc21db | 6 | ;; Maintainer: emacs-devel@gnu.org |
3656dac0 | 7 | ;; Keywords: help, faces |
bd78fa1d | 8 | ;; Package: emacs |
3656dac0 RS |
9 | |
10 | ;; This file is part of GNU Emacs. | |
11 | ||
eb3fa2cf | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
3656dac0 | 13 | ;; it under the terms of the GNU General Public License as published by |
eb3fa2cf GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
3656dac0 RS |
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 | |
eb3fa2cf | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
3656dac0 RS |
24 | |
25 | ;;; Code: | |
26 | ||
27 | (require 'widget) | |
28 | (require 'cus-edit) | |
29 | ||
30 | (eval-when-compile | |
31 | (require 'wid-edit)) | |
32 | ||
bdeaa675 | 33 | (defvar custom-new-theme-mode-map |
bdeaa675 | 34 | (let ((map (make-keymap))) |
8f942537 CY |
35 | (set-keymap-parent map (make-composed-keymap widget-keymap |
36 | special-mode-map)) | |
bdeaa675 | 37 | (suppress-keymap map) |
6b09b5d1 | 38 | (define-key map "\C-x\C-s" 'custom-theme-write) |
8f942537 | 39 | (define-key map "q" 'Custom-buffer-done) |
bdeaa675 CY |
40 | (define-key map "n" 'widget-forward) |
41 | (define-key map "p" 'widget-backward) | |
bdeaa675 CY |
42 | map) |
43 | "Keymap for `custom-new-theme-mode'.") | |
44 | ||
647bc502 | 45 | (define-derived-mode custom-new-theme-mode nil "Custom-Theme" |
6b09b5d1 CY |
46 | "Major mode for editing Custom themes. |
47 | Do not call this mode function yourself. It is meant for internal use." | |
bdeaa675 | 48 | (use-local-map custom-new-theme-mode-map) |
6b09b5d1 CY |
49 | (custom--initialize-widget-variables) |
50 | (set (make-local-variable 'revert-buffer-function) 'custom-theme-revert)) | |
077ad61c LT |
51 | (put 'custom-new-theme-mode 'mode-class 'special) |
52 | ||
d0f1e2f8 | 53 | (defvar custom-theme-name nil) |
29a4c45b | 54 | ;; Each element has the form (VAR CHECKBOX-WIDGET VAR-WIDGET) |
d0f1e2f8 | 55 | (defvar custom-theme-variables nil) |
29a4c45b | 56 | ;; Each element has the form (FACE CHECKBOX-WIDGET FACE-WIDGET) |
d0f1e2f8 | 57 | (defvar custom-theme-faces nil) |
76c16af8 | 58 | (defvar custom-theme-description nil) |
29a4c45b | 59 | (defvar custom-theme--migrate-settings nil) |
76c16af8 CY |
60 | (defvar custom-theme-insert-variable-marker nil) |
61 | (defvar custom-theme-insert-face-marker nil) | |
62 | ||
2919746c | 63 | (defvar custom-theme--listed-faces '(default cursor fixed-pitch |
76c16af8 CY |
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.") | |
077ad61c | 79 | |
6b09b5d1 CY |
80 | (defvar custom-theme--save-name) |
81 | ||
87e391a9 | 82 | ;;;###autoload |
6b09b5d1 CY |
83 | (defun customize-create-theme (&optional theme buffer) |
84 | "Create or edit a custom theme. | |
29a4c45b | 85 | THEME, if non-nil, should be an existing theme to edit. If THEME |
4125cb8b CY |
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. | |
da16abfc CY |
89 | BUFFER, if non-nil, should be a buffer to use; the default is |
90 | named *Custom Theme*." | |
3656dac0 | 91 | (interactive) |
6b09b5d1 | 92 | (switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*"))) |
077ad61c | 93 | (let ((inhibit-read-only t)) |
da16abfc CY |
94 | (erase-buffer) |
95 | (dolist (ov (overlays-in (point-min) (point-max))) | |
96 | (delete-overlay ov))) | |
077ad61c | 97 | (custom-new-theme-mode) |
3656dac0 | 98 | (make-local-variable 'custom-theme-name) |
6b09b5d1 | 99 | (set (make-local-variable 'custom-theme--save-name) theme) |
76c16af8 CY |
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) "") | |
29a4c45b | 103 | (set (make-local-variable 'custom-theme--migrate-settings) nil) |
d0f1e2f8 | 104 | (make-local-variable 'custom-theme-insert-face-marker) |
76c16af8 CY |
105 | (make-local-variable 'custom-theme-insert-variable-marker) |
106 | (make-local-variable 'custom-theme--listed-faces) | |
4359915b CY |
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))) | |
077ad61c | 110 | |
29a4c45b CY |
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")) | |
115 | ||
d0f1e2f8 | 116 | (widget-create 'push-button |
76c16af8 | 117 | :tag " Visit Theme " |
d0f1e2f8 | 118 | :help-echo "Insert the settings of a pre-defined theme." |
06b60517 | 119 | :action (lambda (_widget &optional _event) |
d0f1e2f8 CY |
120 | (call-interactively 'custom-theme-visit-theme))) |
121 | (widget-insert " ") | |
122 | (widget-create 'push-button | |
76c16af8 | 123 | :tag " Merge Theme " |
d0f1e2f8 | 124 | :help-echo "Merge in the settings of a pre-defined theme." |
06b60517 | 125 | :action (lambda (_widget &optional _event) |
d0f1e2f8 CY |
126 | (call-interactively 'custom-theme-merge-theme))) |
127 | (widget-insert " ") | |
29a4c45b CY |
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))) | |
077ad61c | 132 | |
76c16af8 | 133 | (widget-insert "\n\nTheme name : ") |
3656dac0 | 134 | (setq custom-theme-name |
6b09b5d1 | 135 | (widget-create 'editable-field |
29a4c45b CY |
136 | :value (if (and theme (not (eq theme 'user))) |
137 | (symbol-name theme) | |
138 | ""))) | |
76c16af8 | 139 | (widget-insert "Description: ") |
3656dac0 | 140 | (setq custom-theme-description |
71296446 | 141 | (widget-create 'text |
3656dac0 | 142 | :value (format-time-string "Created %Y-%m-%d."))) |
3656dac0 | 143 | (widget-create 'push-button |
76c16af8 CY |
144 | :notify (function custom-theme-write) |
145 | " Save Theme ") | |
29a4c45b CY |
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))))) | |
392f875a | 156 | (widget-insert (propertize " Remove saved theme settings from Custom save file." |
29a4c45b | 157 | 'face '(variable-pitch (:height 0.9))))) |
da16abfc CY |
158 | |
159 | (let (vars values faces face-specs) | |
160 | ||
161 | ;; Load the theme settings. | |
162 | (when theme | |
29a4c45b | 163 | (unless (eq theme 'user) |
658d8eb8 | 164 | (load-theme theme nil t)) |
da16abfc CY |
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)))) | |
171 | ||
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 | |
06b60517 | 189 | :action (lambda (_widget &optional _event) |
da16abfc CY |
190 | (call-interactively 'custom-theme-add-face))) |
191 | ||
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 | |
29a4c45b CY |
196 | (if (eq (car vars) 'custom-enabled-themes) |
197 | (progn (pop vars) (pop values)) | |
4359915b | 198 | (custom-theme-add-var-1 (pop vars) (eval (pop values)))))) |
da16abfc CY |
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 | |
06b60517 | 208 | :action (lambda (_widget &optional _event) |
da16abfc CY |
209 | (call-interactively 'custom-theme-add-variable))) |
210 | (widget-insert ?\n) | |
211 | (widget-setup) | |
212 | (goto-char (point-min)) | |
213 | (message ""))) | |
d0f1e2f8 | 214 | |
06b60517 | 215 | (defun custom-theme-revert (_ignore-auto noconfirm) |
4125cb8b CY |
216 | "Revert the current *Custom Theme* buffer. |
217 | This is the `revert-buffer-function' for `custom-new-theme-mode'." | |
76c16af8 | 218 | (when (or noconfirm (y-or-n-p "Discard current changes? ")) |
6b09b5d1 | 219 | (customize-create-theme custom-theme--save-name (current-buffer)))) |
76c16af8 | 220 | |
d0f1e2f8 CY |
221 | ;;; Theme variables |
222 | ||
da16abfc CY |
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)))) | |
29a4c45b CY |
230 | (let ((entry (assq var custom-theme-variables))) |
231 | (cond ((null entry) | |
da16abfc CY |
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. | |
239 | (t | |
29a4c45b CY |
240 | (widget-value-set (nth 1 entry) t) |
241 | (let ((widget (nth 2 entry))) | |
da16abfc CY |
242 | (widget-put widget :shown-value (list value)) |
243 | (custom-redraw widget)))))) | |
244 | ||
245 | (defun custom-theme-add-var-1 (symbol val) | |
246 | (widget-insert " ") | |
29a4c45b CY |
247 | (push (list symbol |
248 | (prog1 (widget-create 'checkbox | |
249 | :value t | |
250 | :help-echo "Enable/disable this variable.") | |
251 | (widget-insert " ")) | |
da16abfc CY |
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 | |
647bc502 | 259 | :custom-style 'simple)) |
da16abfc CY |
260 | custom-theme-variables) |
261 | (widget-insert " ")) | |
d0f1e2f8 CY |
262 | |
263 | ;;; Theme faces | |
264 | ||
da16abfc CY |
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." | |
011cddd6 | 268 | (interactive (list (read-face-name "Face name" (face-at-point t)))) |
da16abfc CY |
269 | (unless (or (facep face) spec) |
270 | (error "`%s' has no face definition" face)) | |
29a4c45b CY |
271 | (let ((entry (assq face custom-theme-faces))) |
272 | (cond ((null entry) | |
da16abfc CY |
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) | |
76c16af8 | 277 | (move-marker custom-theme-insert-face-marker (point)) |
da16abfc CY |
278 | (widget-setup))) |
279 | ;; Otherwise, if SPEC is supplied, alter that face widget. | |
280 | (spec | |
29a4c45b CY |
281 | (widget-value-set (nth 1 entry) t) |
282 | (let ((widget (nth 2 entry))) | |
da16abfc CY |
283 | (widget-put widget :shown-value spec) |
284 | (custom-redraw widget))) | |
285 | ((called-interactively-p 'interactive) | |
286 | (error "`%s' is already present" face))))) | |
287 | ||
288 | (defun custom-theme-add-face-1 (symbol spec) | |
289 | (widget-insert " ") | |
29a4c45b CY |
290 | (push (list symbol |
291 | (prog1 | |
292 | (widget-create 'checkbox | |
293 | :value t | |
294 | :help-echo "Enable/disable this face.") | |
295 | (widget-insert " ")) | |
da16abfc CY |
296 | (widget-create 'custom-face |
297 | :tag (custom-unlispify-tag-name symbol) | |
298 | :documentation-shown t | |
299 | :value symbol | |
300 | :custom-state 'hidden | |
647bc502 | 301 | :custom-style 'simple |
da16abfc | 302 | :shown-value spec |
da16abfc CY |
303 | :sample-indent 34)) |
304 | custom-theme-faces) | |
305 | (widget-insert " ")) | |
d0f1e2f8 CY |
306 | |
307 | ;;; Reading and writing | |
308 | ||
4359915b | 309 | ;;;###autoload |
da16abfc | 310 | (defun custom-theme-visit-theme (theme) |
4359915b | 311 | "Set up a Custom buffer to edit custom theme THEME." |
da16abfc CY |
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)))) | |
d0f1e2f8 CY |
324 | |
325 | (defun custom-theme-merge-theme (theme) | |
da16abfc | 326 | "Merge the custom theme THEME's settings into the current buffer." |
6b09b5d1 CY |
327 | (interactive |
328 | (list | |
329 | (intern (completing-read "Merge custom theme: " | |
330 | (mapcar 'symbol-name | |
331 | (custom-available-themes)))))) | |
da16abfc CY |
332 | (unless (eq theme 'user) |
333 | (unless (custom-theme-name-valid-p theme) | |
334 | (error "Invalid theme name `%s'" theme)) | |
658d8eb8 | 335 | (load-theme theme nil t)) |
da16abfc | 336 | (let ((settings (reverse (get theme 'theme-settings)))) |
d0f1e2f8 | 337 | (dolist (setting settings) |
04482335 CY |
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))))) | |
d0f1e2f8 CY |
348 | theme) |
349 | ||
06b60517 JB |
350 | ;; From cus-edit.el |
351 | (defvar custom-reset-standard-faces-list) | |
352 | (defvar custom-reset-standard-variables-list) | |
353 | ||
354 | (defun custom-theme-write (&rest _ignore) | |
da16abfc | 355 | "Write the current custom theme to its theme file." |
6b09b5d1 | 356 | (interactive) |
d0f1e2f8 | 357 | (let* ((name (widget-value custom-theme-name)) |
29a4c45b CY |
358 | (doc (widget-value custom-theme-description)) |
359 | (vars custom-theme-variables) | |
76c16af8 CY |
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)) | |
6b09b5d1 CY |
365 | (unless (custom-theme-name-valid-p (intern name)) |
366 | (error "Custom themes cannot be named `%s'" name)) | |
76c16af8 CY |
367 | |
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")) | |
373 | ||
d0f1e2f8 CY |
374 | (with-temp-buffer |
375 | (emacs-lisp-mode) | |
782b5e8d | 376 | (unless (file-directory-p custom-theme-directory) |
d0f1e2f8 CY |
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") | |
29a4c45b CY |
383 | (custom-theme-write-variables name (reverse vars)) |
384 | (custom-theme-write-faces name (reverse faces)) | |
d0f1e2f8 CY |
385 | (insert "\n(provide-theme '" name ")\n") |
386 | (save-buffer)) | |
29a4c45b CY |
387 | (message "Theme written to %s" filename) |
388 | ||
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)))))) | |
3656dac0 RS |
403 | |
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." | |
3656dac0 RS |
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") | |
76c16af8 | 413 | (dolist (spec vars) |
29a4c45b CY |
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 ")"))))) | |
3656dac0 RS |
430 | (if (bolp) |
431 | (princ " ")) | |
432 | (princ ")") | |
433 | (unless (looking-at "\n") | |
434 | (princ "\n"))))) | |
435 | ||
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") | |
76c16af8 | 445 | (dolist (spec faces) |
dd470960 | 446 | ;; Insert the face iff the checkbox widget is checked. |
29a4c45b CY |
447 | (when (widget-get (nth 1 spec) :value) |
448 | (let* ((symbol (nth 0 spec)) | |
449 | (widget (nth 2 spec)) | |
450 | (value | |
dd470960 CY |
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))))) | |
29a4c45b CY |
457 | (when (and (facep symbol) value) |
458 | (princ (if (bolp) " '(" "\n '(")) | |
459 | (prin1 symbol) | |
460 | (princ " ") | |
461 | (prin1 value) | |
462 | (princ ")"))))) | |
da16abfc | 463 | (if (bolp) (princ " ")) |
3656dac0 RS |
464 | (princ ")") |
465 | (unless (looking-at "\n") | |
466 | (princ "\n"))))) | |
467 | ||
6b09b5d1 CY |
468 | \f |
469 | ;;; Describing Custom themes. | |
470 | ||
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)))) | |
486 | ||
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") | |
782b5e8d | 491 | (custom-theme--load-path) |
2919746c CY |
492 | '("" "c"))) |
493 | doc) | |
6b09b5d1 CY |
494 | (when fn |
495 | (princ " in `") | |
496 | (help-insert-xref-button (file-name-nondirectory fn) | |
497 | 'help-theme-def fn) | |
498 | (princ "'")) | |
2919746c | 499 | (princ ".\n") |
c5dd5a51 | 500 | (if (custom-theme-p theme) |
2919746c | 501 | (progn |
c5dd5a51 CY |
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))))))) | |
2919746c CY |
518 | (princ "\n\nDocumentation:\n") |
519 | (princ (if (stringp doc) | |
520 | doc | |
521 | "No documentation available."))) | |
6b09b5d1 CY |
522 | (princ "\n\nYou can ") |
523 | (help-insert-xref-button "customize" 'help-theme-edit theme) | |
524 | (princ " this theme.")) | |
525 | ||
526 | \f | |
527 | ;;; Theme chooser | |
528 | ||
529 | (defvar custom--listed-themes) | |
530 | ||
531 | (defcustom custom-theme-allow-multiple-selections nil | |
532 | "Whether to allow multi-selections in the *Custom Themes* buffer." | |
2bed3f04 | 533 | :version "24.1" |
6b09b5d1 CY |
534 | :type 'boolean |
535 | :group 'custom-buffer) | |
536 | ||
537 | (defvar custom-theme-choose-mode-map | |
538 | (let ((map (make-keymap))) | |
b9696605 CY |
539 | (set-keymap-parent map (make-composed-keymap widget-keymap |
540 | special-mode-map)) | |
6b09b5d1 CY |
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'.") | |
548 | ||
b9696605 | 549 | (define-derived-mode custom-theme-choose-mode special-mode "Themes" |
6b09b5d1 CY |
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) | |
06b60517 | 555 | (lambda (_ignore-auto noconfirm) |
6b09b5d1 CY |
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) | |
559 | ||
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) | |
b2948a87 | 566 | (switch-to-buffer (get-buffer-create (or buffer "*Custom Themes*"))) |
6b09b5d1 CY |
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)) | |
575 | ||
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 `")) | |
782b5e8d | 581 | (widget-create 'link :value "custom-theme-load-path" |
6b09b5d1 CY |
582 | :button-face 'custom-link |
583 | :mouse-face 'highlight | |
584 | :pressed-face 'highlight | |
782b5e8d | 585 | :help-echo "Describe `custom-theme-load-path'." |
6b09b5d1 CY |
586 | :keymap custom-mode-link-map |
587 | :follow-link 'mouse-face | |
06b60517 | 588 | :action (lambda (_widget &rest _ignore) |
782b5e8d | 589 | (describe-variable 'custom-theme-load-path))) |
6b09b5d1 | 590 | (widget-insert "'.\n\n") |
da16abfc CY |
591 | |
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))) | |
29a4c45b CY |
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 | |
06b60517 | 611 | :action (lambda (_widget &rest _ignore) |
29a4c45b CY |
612 | (customize-create-theme 'user))) |
613 | (widget-insert ".\n\n"))) | |
da16abfc | 614 | |
6b09b5d1 CY |
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) | |
c5dd5a51 | 623 | (widget-insert (propertize " Select more than one theme at a time" |
6b09b5d1 CY |
624 | 'face '(variable-pitch (:height 0.9)))) |
625 | ||
626 | (widget-insert "\n\nAvailable Custom Themes:\n") | |
c5dd5a51 CY |
627 | (let ((help-echo "mouse-2: Enable this theme for this session") |
628 | widget) | |
6b09b5d1 CY |
629 | (dolist (theme (custom-available-themes)) |
630 | (setq widget (widget-create 'checkbox | |
631 | :value (custom-theme-enabled-p theme) | |
632 | :theme-name theme | |
c5dd5a51 | 633 | :help-echo help-echo |
6b09b5d1 CY |
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) | |
c5dd5a51 CY |
640 | :action 'widget-parent-action |
641 | :help-echo help-echo) | |
642 | (widget-insert " -- " | |
643 | (propertize (custom-theme-summary theme) | |
644 | 'face 'shadow) | |
645 | ?\n))) | |
6b09b5d1 CY |
646 | (goto-char (point-min)) |
647 | (widget-setup)) | |
648 | ||
c5dd5a51 CY |
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)))) | |
672 | ||
6b09b5d1 CY |
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. | |
928f4e73 CY |
677 | (progn |
678 | (disable-theme this-theme) | |
679 | (widget-toggle-action widget event)) | |
6b09b5d1 CY |
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)))) | |
928f4e73 CY |
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))))) | |
6b09b5d1 CY |
697 | |
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))))) | |
704 | ||
06b60517 | 705 | (defun custom-theme-save (&rest _ignore) |
6b09b5d1 CY |
706 | (interactive) |
707 | (customize-save-variable 'custom-enabled-themes custom-enabled-themes) | |
708 | (message "Custom themes saved for future sessions.")) | |
709 | ||
710 | (defun custom-theme-selections-toggle (widget &optional event) | |
711 | (when (widget-value widget) | |
712 | ;; Deactivate multiple-selections. | |
29a4c45b CY |
713 | (if (< 1 (length (delq nil (mapcar (lambda (x) (widget-value (cdr x))) |
714 | custom--listed-themes)))) | |
6b09b5d1 CY |
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))) | |
718 | ||
4359915b CY |
719 | (provide 'cus-theme) |
720 | ||
3656dac0 | 721 | ;;; cus-theme.el ends here |