Commit | Line | Data |
---|---|---|
3656dac0 RS |
1 | ;;; cus-theme.el -- custom theme creation user interface |
2 | ;; | |
aaef169d | 3 | ;; Copyright (C) 2001, 2002, 2003, 2004, 2005, |
409cc4a3 | 4 | ;; 2006, 2007, 2008 Free Software Foundation, Inc. |
3656dac0 RS |
5 | ;; |
6 | ;; Author: Alex Schroeder <alex@gnu.org> | |
7 | ;; Maintainer: FSF | |
8 | ;; Keywords: help, faces | |
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 CY |
34 | (let ((map (make-keymap))) |
35 | (set-keymap-parent map widget-keymap) | |
36 | (suppress-keymap map) | |
37 | (define-key map "n" 'widget-forward) | |
38 | (define-key map "p" 'widget-backward) | |
bdeaa675 CY |
39 | map) |
40 | "Keymap for `custom-new-theme-mode'.") | |
41 | ||
077ad61c LT |
42 | (define-derived-mode custom-new-theme-mode nil "New-Theme" |
43 | "Major mode for the buffer created by `customize-create-theme'. | |
44 | Do not call this mode function yourself. It is only meant for internal | |
45 | use by `customize-create-theme'." | |
bdeaa675 CY |
46 | (use-local-map custom-new-theme-mode-map) |
47 | (define-key custom-new-theme-mode-map [mouse-1] 'widget-move-and-invoke) | |
8314bdb8 CY |
48 | (set (make-local-variable 'widget-documentation-face) 'custom-documentation) |
49 | (set (make-local-variable 'widget-button-face) custom-button) | |
50 | (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed) | |
85a5eb0e | 51 | (set (make-local-variable 'widget-mouse-face) custom-button-mouse) |
8314bdb8 CY |
52 | (when custom-raised-buttons |
53 | (set (make-local-variable 'widget-push-button-prefix) "") | |
54 | (set (make-local-variable 'widget-push-button-suffix) "") | |
55 | (set (make-local-variable 'widget-link-prefix) "") | |
56 | (set (make-local-variable 'widget-link-suffix) ""))) | |
077ad61c LT |
57 | (put 'custom-new-theme-mode 'mode-class 'special) |
58 | ||
d0f1e2f8 CY |
59 | (defvar custom-theme-name nil) |
60 | (defvar custom-theme-variables nil) | |
61 | (defvar custom-theme-faces nil) | |
077ad61c | 62 | (defvar custom-theme-description) |
d0f1e2f8 CY |
63 | (defvar custom-theme-insert-variable-marker) |
64 | (defvar custom-theme-insert-face-marker) | |
077ad61c | 65 | |
87e391a9 | 66 | ;;;###autoload |
f560e69c | 67 | (defun customize-create-theme () |
3656dac0 RS |
68 | "Create a custom theme." |
69 | (interactive) | |
d0f1e2f8 | 70 | (switch-to-buffer (generate-new-buffer "*New Custom Theme*")) |
077ad61c LT |
71 | (let ((inhibit-read-only t)) |
72 | (erase-buffer)) | |
73 | (custom-new-theme-mode) | |
3656dac0 RS |
74 | (make-local-variable 'custom-theme-name) |
75 | (make-local-variable 'custom-theme-variables) | |
76 | (make-local-variable 'custom-theme-faces) | |
77 | (make-local-variable 'custom-theme-description) | |
d0f1e2f8 CY |
78 | (make-local-variable 'custom-theme-insert-variable-marker) |
79 | (make-local-variable 'custom-theme-insert-face-marker) | |
3656dac0 | 80 | (widget-insert "This buffer helps you write a custom theme elisp file. |
077ad61c LT |
81 | This will help you share your customizations with other people. |
82 | ||
d0f1e2f8 CY |
83 | Insert the names of all variables and faces you want the theme to include. |
84 | Invoke \"Save Theme\" to save the theme. The theme file will be saved to | |
85 | the directory " custom-theme-directory "\n\n") | |
86 | (widget-create 'push-button | |
87 | :tag "Visit Theme" | |
88 | :help-echo "Insert the settings of a pre-defined theme." | |
89 | :action (lambda (widget &optional event) | |
90 | (call-interactively 'custom-theme-visit-theme))) | |
91 | (widget-insert " ") | |
92 | (widget-create 'push-button | |
93 | :tag "Merge Theme" | |
94 | :help-echo "Merge in the settings of a pre-defined theme." | |
95 | :action (lambda (widget &optional event) | |
96 | (call-interactively 'custom-theme-merge-theme))) | |
97 | (widget-insert " ") | |
98 | (widget-create 'push-button | |
99 | :notify (lambda (&rest ignore) | |
e1a2960c | 100 | (when (y-or-n-p "Discard current changes? ") |
d0f1e2f8 CY |
101 | (kill-buffer (current-buffer)) |
102 | (customize-create-theme))) | |
103 | "Reset Buffer") | |
104 | (widget-insert " ") | |
105 | (widget-create 'push-button | |
106 | :notify (function custom-theme-write) | |
107 | "Save Theme") | |
108 | (widget-insert "\n") | |
077ad61c | 109 | |
d0f1e2f8 | 110 | (widget-insert "\n\nTheme name: ") |
3656dac0 RS |
111 | (setq custom-theme-name |
112 | (widget-create 'editable-field | |
113 | :size 10 | |
114 | user-login-name)) | |
115 | (widget-insert "\n\nDocumentation:\n") | |
116 | (setq custom-theme-description | |
71296446 | 117 | (widget-create 'text |
3656dac0 | 118 | :value (format-time-string "Created %Y-%m-%d."))) |
3656dac0 RS |
119 | (widget-insert "\n") |
120 | (widget-create 'push-button | |
d0f1e2f8 CY |
121 | :tag "Insert Variable" |
122 | :help-echo "Add another variable to this theme." | |
123 | :action (lambda (widget &optional event) | |
124 | (call-interactively 'custom-theme-add-variable))) | |
125 | (widget-insert "\n") | |
126 | (setq custom-theme-insert-variable-marker (point-marker)) | |
127 | (widget-insert "\n") | |
3656dac0 | 128 | (widget-create 'push-button |
d0f1e2f8 CY |
129 | :tag "Insert Face" |
130 | :help-echo "Add another face to this theme." | |
131 | :action (lambda (widget &optional event) | |
132 | (call-interactively 'custom-theme-add-face))) | |
133 | (widget-insert "\n") | |
134 | (setq custom-theme-insert-face-marker (point-marker)) | |
135 | (widget-insert "\n") | |
3656dac0 RS |
136 | (widget-create 'push-button |
137 | :notify (lambda (&rest ignore) | |
e1a2960c | 138 | (when (y-or-n-p "Discard current changes? ") |
d0f1e2f8 CY |
139 | (kill-buffer (current-buffer)) |
140 | (customize-create-theme))) | |
141 | "Reset Buffer") | |
142 | (widget-insert " ") | |
143 | (widget-create 'push-button | |
144 | :notify (function custom-theme-write) | |
145 | "Save Theme") | |
3656dac0 | 146 | (widget-insert "\n") |
d0f1e2f8 CY |
147 | (widget-setup) |
148 | (goto-char (point-min)) | |
149 | (message "")) | |
150 | ||
151 | ;;; Theme variables | |
152 | ||
153 | (defun custom-theme-add-variable (symbol) | |
154 | (interactive "vVariable name: ") | |
f354d944 CY |
155 | (cond ((assq symbol custom-theme-variables) |
156 | (message "%s is already in the theme" (symbol-name symbol))) | |
157 | ((not (boundp symbol)) | |
158 | (message "%s is not defined as a variable" (symbol-name symbol))) | |
159 | ((eq symbol 'custom-enabled-themes) | |
160 | (message "Custom theme cannot contain `custom-enabled-themes'")) | |
161 | (t | |
162 | (save-excursion | |
163 | (goto-char custom-theme-insert-variable-marker) | |
4c92479f CY |
164 | (widget-insert "\n") |
165 | (let ((widget (widget-create 'custom-variable | |
166 | :tag (custom-unlispify-tag-name symbol) | |
167 | :custom-level 0 | |
168 | :action 'custom-theme-variable-action | |
169 | :custom-state 'unknown | |
170 | :value symbol))) | |
171 | (push (cons symbol widget) custom-theme-variables) | |
172 | (custom-magic-reset widget)) | |
173 | (widget-setup))))) | |
d0f1e2f8 CY |
174 | |
175 | (defvar custom-theme-variable-menu | |
176 | `(("Reset to Current" custom-redraw | |
177 | (lambda (widget) | |
178 | (and (boundp (widget-value widget)) | |
179 | (memq (widget-get widget :custom-state) | |
180 | '(themed modified changed))))) | |
181 | ("Reset to Theme Value" custom-variable-reset-theme | |
182 | (lambda (widget) | |
183 | (let ((theme (intern (widget-value custom-theme-name))) | |
184 | (symbol (widget-value widget)) | |
185 | found) | |
186 | (and (custom-theme-p theme) | |
187 | (dolist (setting (get theme 'theme-settings) found) | |
188 | (if (and (eq (cadr setting) symbol) | |
189 | (eq (car setting) 'theme-value)) | |
190 | (setq found t))))))) | |
191 | ("---" ignore ignore) | |
192 | ("Delete" custom-theme-delete-variable nil)) | |
193 | "Alist of actions for the `custom-variable' widget in Custom Theme Mode. | |
194 | See the documentation for `custom-variable'.") | |
195 | ||
196 | (defun custom-theme-variable-action (widget &optional event) | |
197 | "Show the Custom Theme Mode menu for a `custom-variable' widget. | |
198 | Optional EVENT is the location for the menu." | |
199 | (let ((custom-variable-menu custom-theme-variable-menu)) | |
200 | (custom-variable-action widget event))) | |
201 | ||
202 | (defun custom-variable-reset-theme (widget) | |
203 | "Reset WIDGET to its value for the currently edited theme." | |
204 | (let ((theme (intern (widget-value custom-theme-name))) | |
205 | (symbol (widget-value widget)) | |
206 | found) | |
207 | (dolist (setting (get theme 'theme-settings)) | |
208 | (if (and (eq (cadr setting) symbol) | |
209 | (eq (car setting) 'theme-value)) | |
210 | (setq found setting))) | |
211 | (widget-value-set (car (widget-get widget :children)) | |
212 | (nth 3 found))) | |
213 | (widget-put widget :custom-state 'themed) | |
214 | (custom-redraw-magic widget) | |
215 | (widget-setup)) | |
216 | ||
217 | (defun custom-theme-delete-variable (widget) | |
218 | (setq custom-theme-variables | |
219 | (assq-delete-all (widget-value widget) custom-theme-variables)) | |
220 | (widget-delete widget)) | |
221 | ||
222 | ;;; Theme faces | |
223 | ||
224 | (defun custom-theme-add-face (symbol) | |
225 | (interactive (list (read-face-name "Face name" nil nil))) | |
f354d944 CY |
226 | (cond ((assq symbol custom-theme-faces) |
227 | (message "%s is already in the theme" (symbol-name symbol))) | |
228 | ((not (facep symbol)) | |
229 | (message "%s is not defined as a face" (symbol-name symbol))) | |
230 | (t | |
231 | (save-excursion | |
232 | (goto-char custom-theme-insert-face-marker) | |
4c92479f CY |
233 | (widget-insert "\n") |
234 | (let ((widget (widget-create 'custom-face | |
235 | :tag (custom-unlispify-tag-name symbol) | |
236 | :custom-level 0 | |
237 | :action 'custom-theme-face-action | |
238 | :custom-state 'unknown | |
239 | :value symbol))) | |
240 | (push (cons symbol widget) custom-theme-faces) | |
241 | (custom-magic-reset widget) | |
242 | (widget-setup)))))) | |
d0f1e2f8 CY |
243 | |
244 | (defvar custom-theme-face-menu | |
245 | `(("Reset to Theme Value" custom-face-reset-theme | |
246 | (lambda (widget) | |
247 | (let ((theme (intern (widget-value custom-theme-name))) | |
248 | (symbol (widget-value widget)) | |
249 | found) | |
250 | (and (custom-theme-p theme) | |
251 | (dolist (setting (get theme 'theme-settings) found) | |
252 | (if (and (eq (cadr setting) symbol) | |
253 | (eq (car setting) 'theme-face)) | |
254 | (setq found t))))))) | |
255 | ("---" ignore ignore) | |
256 | ("Delete" custom-theme-delete-face nil)) | |
257 | "Alist of actions for the `custom-variable' widget in Custom Theme Mode. | |
258 | See the documentation for `custom-variable'.") | |
259 | ||
260 | (defun custom-theme-face-action (widget &optional event) | |
261 | "Show the Custom Theme Mode menu for a `custom-face' widget. | |
262 | Optional EVENT is the location for the menu." | |
263 | (let ((custom-face-menu custom-theme-face-menu)) | |
264 | (custom-face-action widget event))) | |
265 | ||
266 | (defun custom-face-reset-theme (widget) | |
267 | "Reset WIDGET to its value for the currently edited theme." | |
268 | (let ((theme (intern (widget-value custom-theme-name))) | |
269 | (symbol (widget-value widget)) | |
270 | found) | |
271 | (dolist (setting (get theme 'theme-settings)) | |
272 | (if (and (eq (cadr setting) symbol) | |
273 | (eq (car setting) 'theme-face)) | |
274 | (setq found setting))) | |
275 | (widget-value-set (car (widget-get widget :children)) | |
276 | (nth 3 found))) | |
277 | (widget-put widget :custom-state 'themed) | |
278 | (custom-redraw-magic widget) | |
3656dac0 RS |
279 | (widget-setup)) |
280 | ||
d0f1e2f8 CY |
281 | (defun custom-theme-delete-face (widget) |
282 | (setq custom-theme-faces | |
283 | (assq-delete-all (widget-value widget) custom-theme-faces)) | |
284 | (widget-delete widget)) | |
285 | ||
286 | ;;; Reading and writing | |
287 | ||
288 | (defun custom-theme-visit-theme () | |
289 | (interactive) | |
290 | (when (or (null custom-theme-variables) | |
e1a2960c | 291 | (if (y-or-n-p "Discard current changes? ") |
d0f1e2f8 CY |
292 | (progn (customize-create-theme) t))) |
293 | (let ((theme (call-interactively 'custom-theme-merge-theme))) | |
294 | (unless (eq theme 'user) | |
295 | (widget-value-set custom-theme-name (symbol-name theme))) | |
296 | (widget-value-set custom-theme-description | |
297 | (or (get theme 'theme-documentation) | |
298 | (format-time-string "Created %Y-%m-%d."))) | |
299 | (widget-setup)))) | |
300 | ||
301 | (defun custom-theme-merge-theme (theme) | |
302 | (interactive "SCustom theme name: ") | |
303 | (unless (eq theme 'user) | |
304 | (load-theme theme)) | |
305 | (let ((settings (get theme 'theme-settings))) | |
306 | (dolist (setting settings) | |
307 | (if (eq (car setting) 'theme-value) | |
308 | (custom-theme-add-variable (cadr setting)) | |
309 | (custom-theme-add-face (cadr setting))))) | |
310 | (disable-theme theme) | |
311 | theme) | |
312 | ||
3656dac0 | 313 | (defun custom-theme-write (&rest ignore) |
d0f1e2f8 CY |
314 | (let* ((name (widget-value custom-theme-name)) |
315 | (filename (expand-file-name (concat name "-theme.el") | |
316 | custom-theme-directory)) | |
317 | (doc (widget-value custom-theme-description)) | |
318 | (vars custom-theme-variables) | |
319 | (faces custom-theme-faces)) | |
320 | (cond ((or (string-equal name "") | |
321 | (string-equal name "user") | |
322 | (string-equal name "changed")) | |
323 | (error "Custom themes cannot be named `%s'" name)) | |
324 | ((string-match " " name) | |
325 | (error "Custom theme names should not contain spaces")) | |
326 | ((if (file-exists-p filename) | |
327 | (not (y-or-n-p | |
328 | (format "File %s exists. Overwrite? " filename)))) | |
329 | (error "Aborted"))) | |
330 | (with-temp-buffer | |
331 | (emacs-lisp-mode) | |
332 | (unless (file-exists-p custom-theme-directory) | |
333 | (make-directory (file-name-as-directory custom-theme-directory) t)) | |
334 | (setq buffer-file-name filename) | |
335 | (erase-buffer) | |
336 | (insert "(deftheme " name) | |
337 | (if doc (insert "\n \"" doc "\"")) | |
338 | (insert ")\n") | |
339 | (custom-theme-write-variables name vars) | |
340 | (custom-theme-write-faces name faces) | |
341 | (insert "\n(provide-theme '" name ")\n") | |
342 | (save-buffer)) | |
343 | (dolist (var vars) | |
344 | (widget-put (cdr var) :custom-state 'saved) | |
345 | (custom-redraw-magic (cdr var))) | |
346 | (dolist (face faces) | |
347 | (widget-put (cdr face) :custom-state 'saved) | |
348 | (custom-redraw-magic (cdr face))))) | |
3656dac0 RS |
349 | |
350 | (defun custom-theme-write-variables (theme vars) | |
351 | "Write a `custom-theme-set-variables' command for THEME. | |
352 | It includes all variables in list VARS." | |
3656dac0 RS |
353 | (when vars |
354 | (let ((standard-output (current-buffer))) | |
355 | (princ "\n(custom-theme-set-variables\n") | |
356 | (princ " '") | |
357 | (princ theme) | |
358 | (princ "\n") | |
d0f1e2f8 CY |
359 | (mapc (lambda (spec) |
360 | (let* ((symbol (car spec)) | |
361 | (child (car-safe (widget-get (cdr spec) :children))) | |
362 | (value (if child | |
363 | (widget-value child) | |
364 | ;; For hidden widgets, use the standard value | |
365 | (get symbol 'standard-value)))) | |
366 | (when (boundp symbol) | |
367 | (unless (bolp) | |
368 | (princ "\n")) | |
369 | (princ " '(") | |
370 | (prin1 symbol) | |
371 | (princ " ") | |
372 | (prin1 (custom-quote value)) | |
373 | (princ ")")))) | |
374 | vars) | |
3656dac0 RS |
375 | (if (bolp) |
376 | (princ " ")) | |
377 | (princ ")") | |
378 | (unless (looking-at "\n") | |
379 | (princ "\n"))))) | |
380 | ||
381 | (defun custom-theme-write-faces (theme faces) | |
382 | "Write a `custom-theme-set-faces' command for THEME. | |
383 | It includes all faces in list FACES." | |
384 | (when faces | |
385 | (let ((standard-output (current-buffer))) | |
386 | (princ "\n(custom-theme-set-faces\n") | |
387 | (princ " '") | |
388 | (princ theme) | |
389 | (princ "\n") | |
d0f1e2f8 CY |
390 | (mapc (lambda (spec) |
391 | (let* ((symbol (car spec)) | |
392 | (child (car-safe (widget-get (cdr spec) :children))) | |
393 | (value (if child (widget-value child)))) | |
394 | (when (and (facep symbol) child) | |
395 | (unless (bolp) | |
396 | (princ "\n")) | |
397 | (princ " '(") | |
398 | (prin1 symbol) | |
399 | (princ " ") | |
400 | (prin1 value) | |
401 | (princ ")")))) | |
402 | faces) | |
3656dac0 RS |
403 | (if (bolp) |
404 | (princ " ")) | |
405 | (princ ")") | |
406 | (unless (looking-at "\n") | |
407 | (princ "\n"))))) | |
408 | ||
cbee283d | 409 | ;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344 |
3656dac0 | 410 | ;;; cus-theme.el ends here |