Commit | Line | Data |
---|---|---|
3656dac0 RS |
1 | ;;; cus-theme.el -- custom theme creation user interface |
2 | ;; | |
aaef169d | 3 | ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, |
114f9c96 | 4 | ;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
3656dac0 RS |
5 | ;; |
6 | ;; Author: Alex Schroeder <alex@gnu.org> | |
7 | ;; Maintainer: FSF | |
8 | ;; Keywords: help, faces | |
bd78fa1d | 9 | ;; Package: emacs |
3656dac0 RS |
10 | |
11 | ;; This file is part of GNU Emacs. | |
12 | ||
eb3fa2cf | 13 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
3656dac0 | 14 | ;; it under the terms of the GNU General Public License as published by |
eb3fa2cf GM |
15 | ;; the Free Software Foundation, either version 3 of the License, or |
16 | ;; (at your option) any later version. | |
3656dac0 RS |
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 | |
eb3fa2cf | 24 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
3656dac0 RS |
25 | |
26 | ;;; Code: | |
27 | ||
28 | (require 'widget) | |
29 | (require 'cus-edit) | |
30 | ||
31 | (eval-when-compile | |
32 | (require 'wid-edit)) | |
33 | ||
bdeaa675 | 34 | (defvar custom-new-theme-mode-map |
bdeaa675 CY |
35 | (let ((map (make-keymap))) |
36 | (set-keymap-parent map widget-keymap) | |
37 | (suppress-keymap map) | |
38 | (define-key map "n" 'widget-forward) | |
39 | (define-key map "p" 'widget-backward) | |
bdeaa675 CY |
40 | map) |
41 | "Keymap for `custom-new-theme-mode'.") | |
42 | ||
077ad61c LT |
43 | (define-derived-mode custom-new-theme-mode nil "New-Theme" |
44 | "Major mode for the buffer created by `customize-create-theme'. | |
45 | Do not call this mode function yourself. It is only meant for internal | |
46 | use by `customize-create-theme'." | |
bdeaa675 CY |
47 | (use-local-map custom-new-theme-mode-map) |
48 | (define-key custom-new-theme-mode-map [mouse-1] 'widget-move-and-invoke) | |
8314bdb8 CY |
49 | (set (make-local-variable 'widget-documentation-face) 'custom-documentation) |
50 | (set (make-local-variable 'widget-button-face) custom-button) | |
51 | (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed) | |
85a5eb0e | 52 | (set (make-local-variable 'widget-mouse-face) custom-button-mouse) |
76c16af8 | 53 | (set (make-local-variable 'revert-buffer-function) 'custom-theme-revert) |
8314bdb8 CY |
54 | (when custom-raised-buttons |
55 | (set (make-local-variable 'widget-push-button-prefix) "") | |
56 | (set (make-local-variable 'widget-push-button-suffix) "") | |
57 | (set (make-local-variable 'widget-link-prefix) "") | |
58 | (set (make-local-variable 'widget-link-suffix) ""))) | |
077ad61c LT |
59 | (put 'custom-new-theme-mode 'mode-class 'special) |
60 | ||
d0f1e2f8 CY |
61 | (defvar custom-theme-name nil) |
62 | (defvar custom-theme-variables nil) | |
63 | (defvar custom-theme-faces nil) | |
76c16af8 CY |
64 | (defvar custom-theme-description nil) |
65 | (defvar custom-theme-insert-variable-marker nil) | |
66 | (defvar custom-theme-insert-face-marker nil) | |
67 | ||
68 | (defvar custom-theme--listed-faces '(default fixed-pitch | |
69 | variable-pitch escape-glyph minibuffer-prompt highlight region | |
70 | shadow secondary-selection trailing-whitespace | |
71 | font-lock-builtin-face font-lock-comment-delimiter-face | |
72 | font-lock-comment-face font-lock-constant-face | |
73 | font-lock-doc-face font-lock-function-name-face | |
74 | font-lock-keyword-face font-lock-negation-char-face | |
75 | font-lock-preprocessor-face font-lock-regexp-grouping-backslash | |
76 | font-lock-regexp-grouping-construct font-lock-string-face | |
77 | font-lock-type-face font-lock-variable-name-face | |
78 | font-lock-warning-face button link link-visited fringe | |
79 | header-line tooltip mode-line mode-line-buffer-id | |
80 | mode-line-emphasis mode-line-highlight mode-line-inactive | |
81 | isearch isearch-fail lazy-highlight match next-error | |
82 | query-replace) | |
83 | "Faces listed by default in the *Custom Theme* buffer.") | |
077ad61c | 84 | |
87e391a9 | 85 | ;;;###autoload |
76c16af8 CY |
86 | (defun customize-create-theme (&optional buffer) |
87 | "Create a custom theme. | |
88 | BUFFER, if non-nil, should be a buffer to use." | |
3656dac0 | 89 | (interactive) |
76c16af8 CY |
90 | (switch-to-buffer (or buffer (generate-new-buffer "*Custom Theme*"))) |
91 | ;; Save current faces | |
077ad61c LT |
92 | (let ((inhibit-read-only t)) |
93 | (erase-buffer)) | |
94 | (custom-new-theme-mode) | |
3656dac0 | 95 | (make-local-variable 'custom-theme-name) |
76c16af8 CY |
96 | (set (make-local-variable 'custom-theme-faces) nil) |
97 | (set (make-local-variable 'custom-theme-variables) nil) | |
98 | (set (make-local-variable 'custom-theme-description) "") | |
d0f1e2f8 | 99 | (make-local-variable 'custom-theme-insert-face-marker) |
76c16af8 CY |
100 | (make-local-variable 'custom-theme-insert-variable-marker) |
101 | (make-local-variable 'custom-theme--listed-faces) | |
077ad61c | 102 | |
d0f1e2f8 | 103 | (widget-create 'push-button |
76c16af8 | 104 | :tag " Visit Theme " |
d0f1e2f8 CY |
105 | :help-echo "Insert the settings of a pre-defined theme." |
106 | :action (lambda (widget &optional event) | |
107 | (call-interactively 'custom-theme-visit-theme))) | |
108 | (widget-insert " ") | |
109 | (widget-create 'push-button | |
76c16af8 | 110 | :tag " Merge Theme " |
d0f1e2f8 CY |
111 | :help-echo "Merge in the settings of a pre-defined theme." |
112 | :action (lambda (widget &optional event) | |
113 | (call-interactively 'custom-theme-merge-theme))) | |
114 | (widget-insert " ") | |
76c16af8 | 115 | (widget-create 'push-button :notify 'revert-buffer " Revert ") |
077ad61c | 116 | |
76c16af8 | 117 | (widget-insert "\n\nTheme name : ") |
3656dac0 | 118 | (setq custom-theme-name |
76c16af8 CY |
119 | (widget-create 'editable-field)) |
120 | (widget-insert "Description: ") | |
3656dac0 | 121 | (setq custom-theme-description |
71296446 | 122 | (widget-create 'text |
3656dac0 | 123 | :value (format-time-string "Created %Y-%m-%d."))) |
76c16af8 | 124 | (widget-insert " ") |
3656dac0 | 125 | (widget-create 'push-button |
76c16af8 CY |
126 | :notify (function custom-theme-write) |
127 | " Save Theme ") | |
128 | ;; Face widgets | |
129 | (widget-insert "\n\n Theme faces:\n") | |
130 | (let (widget) | |
131 | (dolist (face custom-theme--listed-faces) | |
132 | (widget-insert " ") | |
133 | (setq widget (widget-create 'custom-face | |
134 | :documentation-shown t | |
135 | :tag (custom-unlispify-tag-name face) | |
136 | :value face | |
137 | :display-style 'concise | |
138 | :custom-state 'hidden | |
139 | :sample-indent 34)) | |
140 | (custom-magic-reset widget) | |
141 | (push (cons face widget) custom-theme-faces))) | |
142 | (insert " ") | |
143 | (setq custom-theme-insert-face-marker (point-marker)) | |
144 | (insert " ") | |
3656dac0 | 145 | (widget-create 'push-button |
76c16af8 | 146 | :tag "Insert Additional Face" |
d0f1e2f8 | 147 | :help-echo "Add another face to this theme." |
76c16af8 CY |
148 | :follow-link 'mouse-face |
149 | :button-face 'custom-link | |
150 | :mouse-face 'highlight | |
151 | :pressed-face 'highlight | |
d0f1e2f8 CY |
152 | :action (lambda (widget &optional event) |
153 | (call-interactively 'custom-theme-add-face))) | |
76c16af8 CY |
154 | (widget-insert "\n\n Theme variables:\n ") |
155 | (setq custom-theme-insert-variable-marker (point-marker)) | |
156 | (widget-insert ?\s) | |
d0f1e2f8 | 157 | (widget-create 'push-button |
76c16af8 CY |
158 | :tag "Insert Variable" |
159 | :help-echo "Add another variable to this theme." | |
160 | :follow-link 'mouse-face | |
161 | :button-face 'custom-link | |
162 | :mouse-face 'highlight | |
163 | :pressed-face 'highlight | |
164 | :action (lambda (widget &optional event) | |
165 | (call-interactively 'custom-theme-add-variable))) | |
166 | (widget-insert ?\n) | |
d0f1e2f8 CY |
167 | (widget-setup) |
168 | (goto-char (point-min)) | |
169 | (message "")) | |
170 | ||
76c16af8 CY |
171 | (defun custom-theme-revert (ignore-auto noconfirm) |
172 | (when (or noconfirm (y-or-n-p "Discard current changes? ")) | |
173 | (erase-buffer) | |
174 | (customize-create-theme (current-buffer)))) | |
175 | ||
d0f1e2f8 CY |
176 | ;;; Theme variables |
177 | ||
178 | (defun custom-theme-add-variable (symbol) | |
179 | (interactive "vVariable name: ") | |
f354d944 CY |
180 | (cond ((assq symbol custom-theme-variables) |
181 | (message "%s is already in the theme" (symbol-name symbol))) | |
182 | ((not (boundp symbol)) | |
183 | (message "%s is not defined as a variable" (symbol-name symbol))) | |
184 | ((eq symbol 'custom-enabled-themes) | |
185 | (message "Custom theme cannot contain `custom-enabled-themes'")) | |
186 | (t | |
187 | (save-excursion | |
188 | (goto-char custom-theme-insert-variable-marker) | |
76c16af8 | 189 | (widget-insert " ") |
4c92479f CY |
190 | (let ((widget (widget-create 'custom-variable |
191 | :tag (custom-unlispify-tag-name symbol) | |
192 | :custom-level 0 | |
193 | :action 'custom-theme-variable-action | |
194 | :custom-state 'unknown | |
195 | :value symbol))) | |
196 | (push (cons symbol widget) custom-theme-variables) | |
197 | (custom-magic-reset widget)) | |
76c16af8 CY |
198 | (widget-insert " ") |
199 | (move-marker custom-theme-insert-variable-marker (point)) | |
4c92479f | 200 | (widget-setup))))) |
d0f1e2f8 CY |
201 | |
202 | (defvar custom-theme-variable-menu | |
203 | `(("Reset to Current" custom-redraw | |
204 | (lambda (widget) | |
205 | (and (boundp (widget-value widget)) | |
206 | (memq (widget-get widget :custom-state) | |
207 | '(themed modified changed))))) | |
208 | ("Reset to Theme Value" custom-variable-reset-theme | |
209 | (lambda (widget) | |
210 | (let ((theme (intern (widget-value custom-theme-name))) | |
211 | (symbol (widget-value widget)) | |
212 | found) | |
213 | (and (custom-theme-p theme) | |
214 | (dolist (setting (get theme 'theme-settings) found) | |
215 | (if (and (eq (cadr setting) symbol) | |
216 | (eq (car setting) 'theme-value)) | |
217 | (setq found t))))))) | |
218 | ("---" ignore ignore) | |
219 | ("Delete" custom-theme-delete-variable nil)) | |
220 | "Alist of actions for the `custom-variable' widget in Custom Theme Mode. | |
221 | See the documentation for `custom-variable'.") | |
222 | ||
223 | (defun custom-theme-variable-action (widget &optional event) | |
224 | "Show the Custom Theme Mode menu for a `custom-variable' widget. | |
225 | Optional EVENT is the location for the menu." | |
226 | (let ((custom-variable-menu custom-theme-variable-menu)) | |
227 | (custom-variable-action widget event))) | |
228 | ||
229 | (defun custom-variable-reset-theme (widget) | |
230 | "Reset WIDGET to its value for the currently edited theme." | |
231 | (let ((theme (intern (widget-value custom-theme-name))) | |
232 | (symbol (widget-value widget)) | |
233 | found) | |
234 | (dolist (setting (get theme 'theme-settings)) | |
235 | (if (and (eq (cadr setting) symbol) | |
236 | (eq (car setting) 'theme-value)) | |
237 | (setq found setting))) | |
238 | (widget-value-set (car (widget-get widget :children)) | |
239 | (nth 3 found))) | |
240 | (widget-put widget :custom-state 'themed) | |
241 | (custom-redraw-magic widget) | |
242 | (widget-setup)) | |
243 | ||
244 | (defun custom-theme-delete-variable (widget) | |
245 | (setq custom-theme-variables | |
246 | (assq-delete-all (widget-value widget) custom-theme-variables)) | |
247 | (widget-delete widget)) | |
248 | ||
249 | ;;; Theme faces | |
250 | ||
251 | (defun custom-theme-add-face (symbol) | |
252 | (interactive (list (read-face-name "Face name" nil nil))) | |
f354d944 CY |
253 | (cond ((assq symbol custom-theme-faces) |
254 | (message "%s is already in the theme" (symbol-name symbol))) | |
255 | ((not (facep symbol)) | |
256 | (message "%s is not defined as a face" (symbol-name symbol))) | |
257 | (t | |
258 | (save-excursion | |
259 | (goto-char custom-theme-insert-face-marker) | |
76c16af8 | 260 | (widget-insert " ") |
4c92479f CY |
261 | (let ((widget (widget-create 'custom-face |
262 | :tag (custom-unlispify-tag-name symbol) | |
263 | :custom-level 0 | |
264 | :action 'custom-theme-face-action | |
265 | :custom-state 'unknown | |
76c16af8 CY |
266 | :display-style 'concise |
267 | :sample-indent 34 | |
4c92479f CY |
268 | :value symbol))) |
269 | (push (cons symbol widget) custom-theme-faces) | |
270 | (custom-magic-reset widget) | |
76c16af8 CY |
271 | (widget-insert " ") |
272 | (move-marker custom-theme-insert-face-marker (point)) | |
4c92479f | 273 | (widget-setup)))))) |
d0f1e2f8 CY |
274 | |
275 | (defvar custom-theme-face-menu | |
276 | `(("Reset to Theme Value" custom-face-reset-theme | |
277 | (lambda (widget) | |
278 | (let ((theme (intern (widget-value custom-theme-name))) | |
279 | (symbol (widget-value widget)) | |
280 | found) | |
281 | (and (custom-theme-p theme) | |
282 | (dolist (setting (get theme 'theme-settings) found) | |
283 | (if (and (eq (cadr setting) symbol) | |
284 | (eq (car setting) 'theme-face)) | |
285 | (setq found t))))))) | |
286 | ("---" ignore ignore) | |
287 | ("Delete" custom-theme-delete-face nil)) | |
288 | "Alist of actions for the `custom-variable' widget in Custom Theme Mode. | |
289 | See the documentation for `custom-variable'.") | |
290 | ||
291 | (defun custom-theme-face-action (widget &optional event) | |
292 | "Show the Custom Theme Mode menu for a `custom-face' widget. | |
293 | Optional EVENT is the location for the menu." | |
294 | (let ((custom-face-menu custom-theme-face-menu)) | |
295 | (custom-face-action widget event))) | |
296 | ||
297 | (defun custom-face-reset-theme (widget) | |
298 | "Reset WIDGET to its value for the currently edited theme." | |
299 | (let ((theme (intern (widget-value custom-theme-name))) | |
300 | (symbol (widget-value widget)) | |
301 | found) | |
302 | (dolist (setting (get theme 'theme-settings)) | |
303 | (if (and (eq (cadr setting) symbol) | |
304 | (eq (car setting) 'theme-face)) | |
305 | (setq found setting))) | |
306 | (widget-value-set (car (widget-get widget :children)) | |
307 | (nth 3 found))) | |
308 | (widget-put widget :custom-state 'themed) | |
309 | (custom-redraw-magic widget) | |
3656dac0 RS |
310 | (widget-setup)) |
311 | ||
d0f1e2f8 CY |
312 | (defun custom-theme-delete-face (widget) |
313 | (setq custom-theme-faces | |
314 | (assq-delete-all (widget-value widget) custom-theme-faces)) | |
315 | (widget-delete widget)) | |
316 | ||
317 | ;;; Reading and writing | |
318 | ||
319 | (defun custom-theme-visit-theme () | |
320 | (interactive) | |
76c16af8 CY |
321 | (when (or (and (null custom-theme-variables) |
322 | (null custom-theme-faces)) | |
323 | (and (y-or-n-p "Discard current changes? ") | |
324 | (progn (revert-buffer) t))) | |
d0f1e2f8 CY |
325 | (let ((theme (call-interactively 'custom-theme-merge-theme))) |
326 | (unless (eq theme 'user) | |
327 | (widget-value-set custom-theme-name (symbol-name theme))) | |
328 | (widget-value-set custom-theme-description | |
329 | (or (get theme 'theme-documentation) | |
330 | (format-time-string "Created %Y-%m-%d."))) | |
331 | (widget-setup)))) | |
332 | ||
333 | (defun custom-theme-merge-theme (theme) | |
334 | (interactive "SCustom theme name: ") | |
335 | (unless (eq theme 'user) | |
336 | (load-theme 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) | |
343 | theme) | |
344 | ||
3656dac0 | 345 | (defun custom-theme-write (&rest ignore) |
d0f1e2f8 | 346 | (let* ((name (widget-value custom-theme-name)) |
d0f1e2f8 | 347 | (doc (widget-value custom-theme-description)) |
76c16af8 CY |
348 | (vars custom-theme-variables) |
349 | (faces custom-theme-faces) | |
350 | filename) | |
351 | (when (string-equal name "") | |
352 | (setq name (read-from-minibuffer "Theme name: " (user-login-name))) | |
353 | (widget-value-set custom-theme-name name)) | |
d0f1e2f8 | 354 | (cond ((or (string-equal name "") |
76c16af8 CY |
355 | (string-equal name "user") |
356 | (string-equal name "changed")) | |
d0f1e2f8 CY |
357 | (error "Custom themes cannot be named `%s'" name)) |
358 | ((string-match " " name) | |
76c16af8 CY |
359 | (error "Custom theme names should not contain spaces"))) |
360 | ||
361 | (setq filename (expand-file-name (concat name "-theme.el") | |
362 | custom-theme-directory)) | |
363 | (and (file-exists-p filename) | |
364 | (not (y-or-n-p (format "File %s exists. Overwrite? " filename))) | |
365 | (error "Aborted")) | |
366 | ||
d0f1e2f8 CY |
367 | (with-temp-buffer |
368 | (emacs-lisp-mode) | |
369 | (unless (file-exists-p custom-theme-directory) | |
370 | (make-directory (file-name-as-directory custom-theme-directory) t)) | |
371 | (setq buffer-file-name filename) | |
372 | (erase-buffer) | |
373 | (insert "(deftheme " name) | |
374 | (if doc (insert "\n \"" doc "\"")) | |
375 | (insert ")\n") | |
376 | (custom-theme-write-variables name vars) | |
377 | (custom-theme-write-faces name faces) | |
378 | (insert "\n(provide-theme '" name ")\n") | |
379 | (save-buffer)) | |
380 | (dolist (var vars) | |
76c16af8 CY |
381 | (when (widget-get (cdr var) :children) |
382 | (widget-put (cdr var) :custom-state 'saved) | |
383 | (custom-redraw-magic (cdr var)))) | |
384 | (dolist (face custom-theme-faces) | |
385 | (when (widget-get (cdr face) :children) | |
386 | (widget-put (cdr face) :custom-state 'saved) | |
387 | (custom-redraw-magic (cdr face)))))) | |
3656dac0 RS |
388 | |
389 | (defun custom-theme-write-variables (theme vars) | |
390 | "Write a `custom-theme-set-variables' command for THEME. | |
391 | It includes all variables in list VARS." | |
3656dac0 RS |
392 | (when vars |
393 | (let ((standard-output (current-buffer))) | |
394 | (princ "\n(custom-theme-set-variables\n") | |
395 | (princ " '") | |
396 | (princ theme) | |
397 | (princ "\n") | |
76c16af8 CY |
398 | (dolist (spec vars) |
399 | (let* ((symbol (car spec)) | |
400 | (child (car-safe (widget-get (cdr spec) :children))) | |
401 | (value (if child | |
402 | (widget-value child) | |
403 | ;; For hidden widgets, use the standard value | |
404 | (get symbol 'standard-value)))) | |
405 | (when (boundp symbol) | |
406 | (unless (bolp) | |
407 | (princ "\n")) | |
408 | (princ " '(") | |
409 | (prin1 symbol) | |
410 | (princ " ") | |
411 | (prin1 (custom-quote value)) | |
412 | (princ ")")))) | |
3656dac0 RS |
413 | (if (bolp) |
414 | (princ " ")) | |
415 | (princ ")") | |
416 | (unless (looking-at "\n") | |
417 | (princ "\n"))))) | |
418 | ||
419 | (defun custom-theme-write-faces (theme faces) | |
420 | "Write a `custom-theme-set-faces' command for THEME. | |
421 | It includes all faces in list FACES." | |
422 | (when faces | |
423 | (let ((standard-output (current-buffer))) | |
424 | (princ "\n(custom-theme-set-faces\n") | |
425 | (princ " '") | |
426 | (princ theme) | |
427 | (princ "\n") | |
76c16af8 CY |
428 | (dolist (spec faces) |
429 | (let* ((symbol (car spec)) | |
430 | (widget (cdr spec)) | |
431 | (child (car-safe (widget-get widget :children))) | |
432 | (state (if child | |
433 | (widget-get widget :custom-state) | |
434 | (custom-face-state symbol))) | |
435 | (value | |
436 | (cond ((eq state 'standard) | |
437 | nil) ; do nothing | |
438 | (child | |
439 | (custom-face-widget-to-spec widget)) | |
440 | (t | |
441 | ;; Widget is closed (hidden), but the face has | |
442 | ;; a non-standard value. Try to extract that | |
443 | ;; value and save it. | |
444 | (custom-face-get-current-spec symbol))))) | |
445 | (when (and (facep symbol) value) | |
446 | (if (bolp) | |
447 | (princ " '(") | |
448 | (princ "\n '(")) | |
449 | (prin1 symbol) | |
450 | (princ " ") | |
451 | (prin1 value) | |
452 | (princ ")")))) | |
3656dac0 RS |
453 | (if (bolp) |
454 | (princ " ")) | |
455 | (princ ")") | |
456 | (unless (looking-at "\n") | |
457 | (princ "\n"))))) | |
458 | ||
cbee283d | 459 | ;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344 |
3656dac0 | 460 | ;;; cus-theme.el ends here |