[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, 2009, 2010 Free Software Foundation, Inc.
;;
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: FSF
;; Keywords: help, faces
;; Package: emacs

;; 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 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.

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