Mercurial > emacs
annotate lisp/cus-theme.el @ 88346:3be7f212f8bc
*** empty log message ***
author | Henrik Enberg <henrik.enberg@telia.com> |
---|---|
date | Fri, 27 Apr 2007 21:33:38 +0000 |
parents | d7ddb3e565de |
children |
rev | line source |
---|---|
48952 | 1 ;;; cus-theme.el -- custom theme creation user interface |
2 ;; | |
88155 | 3 ;; Copyright (C) 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. |
48952 | 4 ;; |
5 ;; Author: Alex Schroeder <alex@gnu.org> | |
6 ;; Maintainer: FSF | |
7 ;; Keywords: help, faces | |
8 | |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation; either version 2, or (at your option) | |
14 ;; any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
88155 | 23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
24 ;; Boston, MA 02110-1301, USA. | |
48952 | 25 |
26 ;;; Code: | |
27 | |
28 (require 'widget) | |
29 (require 'cus-edit) | |
30 | |
31 (eval-when-compile | |
32 (require 'wid-edit)) | |
33 | |
88155 | 34 (defvar custom-new-theme-mode-map |
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) | |
40 (define-key map [mouse-1] 'widget-move-and-invoke) | |
41 map) | |
42 "Keymap for `custom-new-theme-mode'.") | |
43 | |
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'." | |
48 (use-local-map custom-new-theme-mode-map) | |
49 (define-key custom-new-theme-mode-map [mouse-1] 'widget-move-and-invoke) | |
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) | |
53 (set (make-local-variable 'widget-mouse-face) custom-button-mouse) | |
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) ""))) | |
59 (put 'custom-new-theme-mode 'mode-class 'special) | |
60 | |
61 (defvar custom-theme-name nil) | |
62 (defvar custom-theme-variables nil) | |
63 (defvar custom-theme-faces nil) | |
64 (defvar custom-theme-description) | |
65 (defvar custom-theme-insert-variable-marker) | |
66 (defvar custom-theme-insert-face-marker) | |
67 | |
68 ;;;###autoload | |
69 (defun customize-create-theme () | |
48952 | 70 "Create a custom theme." |
71 (interactive) | |
88155 | 72 (switch-to-buffer (generate-new-buffer "*New Custom Theme*")) |
73 (let ((inhibit-read-only t)) | |
74 (erase-buffer)) | |
75 (custom-new-theme-mode) | |
48952 | 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) | |
88155 | 80 (make-local-variable 'custom-theme-insert-variable-marker) |
81 (make-local-variable 'custom-theme-insert-face-marker) | |
48952 | 82 (widget-insert "This buffer helps you write a custom theme elisp file. |
88155 | 83 This will help you share your customizations with other people. |
84 | |
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) | |
102 (when (y-or-n-p "Discard current changes?") | |
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") | |
111 | |
112 (widget-insert "\n\nTheme name: ") | |
48952 | 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 | |
49588
37645a051842
Trailing whitespace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
48952
diff
changeset
|
119 (widget-create 'text |
48952 | 120 :value (format-time-string "Created %Y-%m-%d."))) |
121 (widget-insert "\n") | |
122 (widget-create 'push-button | |
88155 | 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") | |
48952 | 130 (widget-create 'push-button |
88155 | 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") | |
48952 | 138 (widget-create 'push-button |
139 :notify (lambda (&rest ignore) | |
88155 | 140 (when (y-or-n-p "Discard current changes?") |
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") | |
48952 | 148 (widget-insert "\n") |
88155 | 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: ") | |
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) | |
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))))) | |
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) | |
48952 | 217 (widget-setup)) |
218 | |
88155 | 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))) | |
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) | |
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)))))) | |
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) | |
281 (widget-setup)) | |
282 | |
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) | |
293 (if (y-or-n-p "Discard current changes?") | |
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 | |
48952 | 315 (defun custom-theme-write (&rest ignore) |
88155 | 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))))) | |
48952 | 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." | |
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") | |
88155 | 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) | |
48952 | 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") | |
88155 | 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) | |
48952 | 405 (if (bolp) |
406 (princ " ")) | |
407 (princ ")") | |
408 (unless (looking-at "\n") | |
409 (princ "\n"))))) | |
410 | |
88155 | 411 ;;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344 |
48952 | 412 ;;; cus-theme.el ends here |