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