[bpt/emacs.git] / lisp / cus-theme.el

;;; cus-theme.el -- custom theme creation user interface
;;
;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
;;   2006, 2007, 2008 Free Software Foundation, Inc.
;;
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: FSF
;; Keywords: help, faces

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Code:

(require 'widget)
(require 'cus-edit)

(eval-when-compile
  (require 'wid-edit))

(defvar custom-new-theme-mode-map
  (let ((map (make-keymap)))
    (set-keymap-parent map widget-keymap)
    (suppress-keymap map)
    (define-key map "n" 'widget-forward)
    (define-key map "p" 'widget-backward)
    map)
  "Keymap for `custom-new-theme-mode'.")

(define-derived-mode custom-new-theme-mode nil "New-Theme"
  "Major mode for the buffer created by `customize-create-theme'.
Do not call this mode function yourself.  It is only meant for internal
use by `customize-create-theme'."
  (use-local-map custom-new-theme-mode-map)
  (define-key custom-new-theme-mode-map [mouse-1] 'widget-move-and-invoke)
  (set (make-local-variable 'widget-documentation-face) 'custom-documentation)
  (set (make-local-variable 'widget-button-face) custom-button)
  (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
  (set (make-local-variable 'widget-mouse-face) custom-button-mouse)
  (when custom-raised-buttons
    (set (make-local-variable 'widget-push-button-prefix) "")
    (set (make-local-variable 'widget-push-button-suffix) "")
    (set (make-local-variable 'widget-link-prefix) "")
    (set (make-local-variable 'widget-link-suffix) "")))
(put 'custom-new-theme-mode 'mode-class 'special)

(defvar custom-theme-name nil)
(defvar custom-theme-variables nil)
(defvar custom-theme-faces nil)
(defvar custom-theme-description)
(defvar custom-theme-insert-variable-marker)
(defvar custom-theme-insert-face-marker)

;;;###autoload
(defun customize-create-theme ()
  "Create a custom theme."
  (interactive)
  (switch-to-buffer (generate-new-buffer "*New Custom Theme*"))
  (let ((inhibit-read-only t))
    (erase-buffer))
  (custom-new-theme-mode)
  (make-local-variable 'custom-theme-name)
  (make-local-variable 'custom-theme-variables)
  (make-local-variable 'custom-theme-faces)
  (make-local-variable 'custom-theme-description)
  (make-local-variable 'custom-theme-insert-variable-marker)
  (make-local-variable 'custom-theme-insert-face-marker)
  (widget-insert "This buffer helps you write a custom theme elisp file.
This will help you share your customizations with other people.

Insert the names of all variables and faces you want the theme to include.
Invoke \"Save Theme\" to save the theme.  The theme file will be saved to
the directory " custom-theme-directory "\n\n")
  (widget-create 'push-button
		 :tag "Visit Theme"
		 :help-echo "Insert the settings of a pre-defined theme."
		 :action (lambda (widget &optional event)
			   (call-interactively 'custom-theme-visit-theme)))
  (widget-insert "  ")
  (widget-create 'push-button
		 :tag "Merge Theme"
		 :help-echo "Merge in the settings of a pre-defined theme."
		 :action (lambda (widget &optional event)
			   (call-interactively 'custom-theme-merge-theme)))
  (widget-insert "  ")
  (widget-create 'push-button
     		 :notify (lambda (&rest ignore)
			   (when (y-or-n-p "Discard current changes? ")
			     (kill-buffer (current-buffer))
			     (customize-create-theme)))
     		 "Reset Buffer")
  (widget-insert "  ")
  (widget-create 'push-button
     		 :notify (function custom-theme-write)
     		 "Save Theme")
  (widget-insert "\n")

  (widget-insert "\n\nTheme name: ")
  (setq custom-theme-name
	(widget-create 'editable-field
		       :size 10
		       user-login-name))
  (widget-insert "\n\nDocumentation:\n")
  (setq custom-theme-description
	(widget-create 'text
		       :value (format-time-string "Created %Y-%m-%d.")))
  (widget-insert "\n")
  (widget-create 'push-button
		 :tag "Insert Variable"
		 :help-echo "Add another variable to this theme."
		 :action (lambda (widget &optional event)
			   (call-interactively 'custom-theme-add-variable)))
  (widget-insert "\n")
  (setq custom-theme-insert-variable-marker (point-marker))
  (widget-insert "\n")
  (widget-create 'push-button
		 :tag "Insert Face"
		 :help-echo "Add another face to this theme."
		 :action (lambda (widget &optional event)
			   (call-interactively 'custom-theme-add-face)))
  (widget-insert "\n")
  (setq custom-theme-insert-face-marker (point-marker))
  (widget-insert "\n")
  (widget-create 'push-button
     		 :notify (lambda (&rest ignore)
			   (when (y-or-n-p "Discard current changes? ")
			     (kill-buffer (current-buffer))
			     (customize-create-theme)))
     		 "Reset Buffer")
  (widget-insert "  ")
  (widget-create 'push-button
     		 :notify (function custom-theme-write)
     		 "Save Theme")
  (widget-insert "\n")
  (widget-setup)
  (goto-char (point-min))
  (message ""))

;;; Theme variables

(defun custom-theme-add-variable (symbol)
  (interactive "vVariable name: ")
  (cond ((assq symbol custom-theme-variables)
	 (message "%s is already in the theme" (symbol-name symbol)))
	((not (boundp symbol))
	 (message "%s is not defined as a variable" (symbol-name symbol)))
	((eq symbol 'custom-enabled-themes)
	 (message "Custom theme cannot contain `custom-enabled-themes'"))
	(t
	 (save-excursion
	   (goto-char custom-theme-insert-variable-marker)
	   (widget-insert "\n")
	   (let ((widget (widget-create 'custom-variable
					:tag (custom-unlispify-tag-name symbol)
					:custom-level 0
					:action 'custom-theme-variable-action
					:custom-state 'unknown
					:value symbol)))
	     (push (cons symbol widget) custom-theme-variables)
	     (custom-magic-reset widget))
	   (widget-setup)))))

(defvar custom-theme-variable-menu
  `(("Reset to Current" custom-redraw
     (lambda (widget)
       (and (boundp (widget-value widget))
	    (memq (widget-get widget :custom-state)
		  '(themed modified changed)))))
    ("Reset to Theme Value" custom-variable-reset-theme
     (lambda (widget)
       (let ((theme  (intern (widget-value custom-theme-name)))
	     (symbol (widget-value widget))
	     found)
	 (and (custom-theme-p theme)
	      (dolist (setting (get theme 'theme-settings) found)
	 	(if (and (eq (cadr setting) symbol)
	 		 (eq (car  setting) 'theme-value))
	 	    (setq found t)))))))
    ("---" ignore ignore)
    ("Delete" custom-theme-delete-variable nil))
  "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
See the documentation for `custom-variable'.")

(defun custom-theme-variable-action (widget &optional event)
  "Show the Custom Theme Mode menu for a `custom-variable' widget.
Optional EVENT is the location for the menu."
  (let ((custom-variable-menu custom-theme-variable-menu))
    (custom-variable-action widget event)))

(defun custom-variable-reset-theme (widget)
  "Reset WIDGET to its value for the currently edited theme."
  (let ((theme  (intern (widget-value custom-theme-name)))
	(symbol (widget-value widget))
	found)
    (dolist (setting (get theme 'theme-settings))
      (if (and (eq (cadr setting) symbol)
	       (eq (car  setting) 'theme-value))
	  (setq found setting)))
    (widget-value-set (car (widget-get widget :children))
		      (nth 3 found)))
  (widget-put widget :custom-state 'themed)
  (custom-redraw-magic widget)
  (widget-setup))

(defun custom-theme-delete-variable (widget)
  (setq custom-theme-variables
	(assq-delete-all (widget-value widget) custom-theme-variables))
  (widget-delete widget))

;;; Theme faces

(defun custom-theme-add-face (symbol)
  (interactive (list (read-face-name "Face name" nil nil)))
  (cond ((assq symbol custom-theme-faces)
	 (message "%s is already in the theme" (symbol-name symbol)))
	((not (facep symbol))
	 (message "%s is not defined as a face" (symbol-name symbol)))
	(t
	 (save-excursion
	   (goto-char custom-theme-insert-face-marker)
	   (widget-insert "\n")
	   (let ((widget (widget-create 'custom-face
					:tag (custom-unlispify-tag-name symbol)
					:custom-level 0
					:action 'custom-theme-face-action
					:custom-state 'unknown
					:value symbol)))
	     (push (cons symbol widget) custom-theme-faces)
	     (custom-magic-reset widget)
	     (widget-setup))))))

(defvar custom-theme-face-menu
  `(("Reset to Theme Value" custom-face-reset-theme
     (lambda (widget)
       (let ((theme  (intern (widget-value custom-theme-name)))
	     (symbol (widget-value widget))
	     found)
	 (and (custom-theme-p theme)
	      (dolist (setting (get theme 'theme-settings) found)
	 	(if (and (eq (cadr setting) symbol)
	 		 (eq (car  setting) 'theme-face))
	 	    (setq found t)))))))
    ("---" ignore ignore)
    ("Delete" custom-theme-delete-face nil))
  "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
See the documentation for `custom-variable'.")

(defun custom-theme-face-action (widget &optional event)
  "Show the Custom Theme Mode menu for a `custom-face' widget.
Optional EVENT is the location for the menu."
  (let ((custom-face-menu custom-theme-face-menu))
    (custom-face-action widget event)))

(defun custom-face-reset-theme (widget)
  "Reset WIDGET to its value for the currently edited theme."
  (let ((theme  (intern (widget-value custom-theme-name)))
	(symbol (widget-value widget))
	found)
    (dolist (setting (get theme 'theme-settings))
      (if (and (eq (cadr setting) symbol)
	       (eq (car  setting) 'theme-face))
	  (setq found setting)))
    (widget-value-set (car (widget-get widget :children))
		      (nth 3 found)))
  (widget-put widget :custom-state 'themed)
  (custom-redraw-magic widget)
  (widget-setup))

(defun custom-theme-delete-face (widget)
  (setq custom-theme-faces
	(assq-delete-all (widget-value widget) custom-theme-faces))
  (widget-delete widget))

;;; Reading and writing

(defun custom-theme-visit-theme ()
  (interactive)
  (when (or (null custom-theme-variables)
	    (if (y-or-n-p "Discard current changes? ")
		(progn (customize-create-theme) t)))
    (let ((theme (call-interactively 'custom-theme-merge-theme)))
      (unless (eq theme 'user)
	(widget-value-set custom-theme-name (symbol-name theme)))
      (widget-value-set custom-theme-description
			(or (get theme 'theme-documentation)
			    (format-time-string "Created %Y-%m-%d.")))
      (widget-setup))))

(defun custom-theme-merge-theme (theme)
  (interactive "SCustom theme name: ")
  (unless (eq theme 'user)
    (load-theme theme))
  (let ((settings (get theme 'theme-settings)))
    (dolist (setting settings)
      (if (eq (car setting) 'theme-value)
	  (custom-theme-add-variable (cadr setting))
	(custom-theme-add-face (cadr setting)))))
  (disable-theme theme)
  theme)

(defun custom-theme-write (&rest ignore)
  (let* ((name (widget-value custom-theme-name))
	 (filename (expand-file-name (concat name "-theme.el")
				     custom-theme-directory))
	 (doc (widget-value custom-theme-description))
	 (vars custom-theme-variables)
	 (faces custom-theme-faces))
    (cond ((or (string-equal name "")
	      (string-equal name "user")
	      (string-equal name "changed"))
	   (error "Custom themes cannot be named `%s'" name))
	  ((string-match " " name)
	   (error "Custom theme names should not contain spaces"))
	  ((if (file-exists-p filename)
	       (not (y-or-n-p
		     (format "File %s exists.  Overwrite? " filename))))
	   (error "Aborted")))
    (with-temp-buffer
      (emacs-lisp-mode)
      (unless (file-exists-p custom-theme-directory)
	(make-directory (file-name-as-directory custom-theme-directory) t))
      (setq buffer-file-name filename)
      (erase-buffer)
      (insert "(deftheme " name)
      (if doc (insert "\n  \"" doc "\""))
      (insert  ")\n")
      (custom-theme-write-variables name vars)
      (custom-theme-write-faces name faces)
      (insert "\n(provide-theme '" name ")\n")
      (save-buffer))
    (dolist (var vars)
      (widget-put (cdr var) :custom-state 'saved)
      (custom-redraw-magic (cdr var)))
    (dolist (face faces)
      (widget-put (cdr face) :custom-state 'saved)
      (custom-redraw-magic (cdr face)))))

(defun custom-theme-write-variables (theme vars)
  "Write a `custom-theme-set-variables' command for THEME.
It includes all variables in list VARS."
  (when vars
    (let ((standard-output (current-buffer)))
      (princ "\n(custom-theme-set-variables\n")
      (princ " '")
      (princ theme)
      (princ "\n")
      (mapc (lambda (spec)
	      (let* ((symbol (car spec))
		     (child (car-safe (widget-get (cdr spec) :children)))
		     (value (if child
				(widget-value child)
			      ;; For hidden widgets, use the standard value
			      (get symbol 'standard-value))))
		(when (boundp symbol)
		  (unless (bolp)
		    (princ "\n"))
		  (princ " '(")
		  (prin1 symbol)
		  (princ " ")
		  (prin1 (custom-quote value))
		  (princ ")"))))
	    vars)
      (if (bolp)
	  (princ " "))
      (princ ")")
      (unless (looking-at "\n")
	(princ "\n")))))

(defun custom-theme-write-faces (theme faces)
  "Write a `custom-theme-set-faces' command for THEME.
It includes all faces in list FACES."
  (when faces
    (let ((standard-output (current-buffer)))
      (princ "\n(custom-theme-set-faces\n")
      (princ " '")
      (princ theme)
      (princ "\n")
      (mapc (lambda (spec)
	      (let* ((symbol (car spec))
		     (child (car-safe (widget-get (cdr spec) :children)))
		     (value (if child (widget-value child))))
		(when (and (facep symbol) child)
		  (unless (bolp)
		    (princ "\n"))
		  (princ " '(")
		  (prin1 symbol)
		  (princ " ")
		  (prin1 value)
		  (princ ")"))))
	    faces)
      (if (bolp)
	  (princ " "))
      (princ ")")
      (unless (looking-at "\n")
	(princ "\n")))))

;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
;;; cus-theme.el ends here
Commit	Line	Data
3656dac0 RS	1	;;; cus-theme.el -- custom theme creation user interface
3656dac0 RS	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,
086add15 LK	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)
bdeaa675 CY	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)
077ad61c LT	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)
d0f1e2f8 CY	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."
3656dac0 RS	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)
d0f1e2f8 CY	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.
077ad61c LT	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")
3656dac0 RS	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
3656dac0 RS	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))
3656dac0 RS	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
cbee283d	411	;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
3656dac0	412	;;; cus-theme.el ends here