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