* cus-theme.el: Rewrite the Custom New Theme Mode interface.

	(custom-new-theme-mode-map, custom-theme-insert-variable-marker)
	(custom-theme-insert-face-marker, custom-theme-variable-menu)
	(custom-theme-face-menu): New variables.
	(custom-theme-add-variable, custom-theme-variable-action)
	(custom-variable-reset-theme, custom-theme-delete-variable)
	(custom-face-reset-theme, custom-theme-face-action)
	(custom-theme-delete-face, custom-theme-merge-theme)
	(custom-theme-add-face, custom-theme-visit-theme): New functions.

2 files changed, 289 insertions, 76 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 8f01e68d616..53e59f3dca9 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,15 @@
+2006-01-02  Chong Yidong  <cyd@stupidchicken.com>
+
+        * cus-theme.el: Rewrite the Custom New Theme Mode interface.
+        (custom-new-theme-mode-map, custom-theme-insert-variable-marker)
+        (custom-theme-insert-face-marker, custom-theme-variable-menu)
+        (custom-theme-face-menu): New variables.
+        (custom-theme-add-variable, custom-theme-variable-action)
+        (custom-variable-reset-theme, custom-theme-delete-variable)
+        (custom-face-reset-theme, custom-theme-face-action)
+        (custom-theme-delete-face, custom-theme-merge-theme)
+        (custom-theme-add-face, custom-theme-visit-theme): New functions.
+
 2006-01-01  Chong Yidong  <cyd@stupidchicken.com>
 
         * custom.el: Move Custom Themes commentary to start of theme code.
diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el
index d7102fc11f7..0a421da925c 100644
--- a/lisp/cus-theme.el
+++ b/lisp/cus-theme.el
@@ -58,18 +58,18 @@ use by `customize-create-theme'."
     (set (make-local-variable 'widget-link-suffix) "")))
 (put 'custom-new-theme-mode 'mode-class 'special)
 
-(defvar custom-theme-name)
-(defvar custom-theme-variables)
-(defvar custom-theme-faces)
+(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)
-  (if (get-buffer "*New Custom Theme*")
-      (kill-buffer "*New Custom Theme*"))
-  (switch-to-buffer "*New Custom Theme*")
+  (switch-to-buffer (generate-new-buffer "*New Custom Theme*"))
   (let ((inhibit-read-only t))
     (erase-buffer))
   (custom-new-theme-mode)
@@ -77,17 +77,39 @@ use by `customize-create-theme'."
   (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.
 
-Just insert the names of all variables and faces you want the theme
-to include.  Then clicking mouse-2 or pressing RET on the [Done] button
-will write a theme file that sets all these variables and faces to their
-current global values.  It will write that file into the directory given
-by the variable `custom-theme-directory', usually \"~/.emacs.d/\".
+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")
 
-To undo all your edits to the buffer, use the [Reset] button.\n\n")
-  (widget-insert "Theme name: ")
+  (widget-insert "\n\nTheme name: ")
   (setq custom-theme-name
         (widget-create 'editable-field
                        :size 10
@@ -96,76 +118,254 @@ To undo all your edits to the buffer, use the [Reset] button.\n\n")
   (setq custom-theme-description
         (widget-create 'text
                        :value (format-time-string "Created %Y-%m-%d.")))
-  (widget-insert "\nVariables:\n\n")
-  (setq custom-theme-variables
-        (widget-create 'editable-list
-                       :entry-format "%i %d %v"
-                       'variable))
-  (widget-insert "\nFaces:\n\n")
-  (setq custom-theme-faces
-        (widget-create 'editable-list
-                       :entry-format "%i %d %v"
-                       'face))
   (widget-insert "\n")
   (widget-create 'push-button
-                 :notify (function custom-theme-write)
-                 "Done")
-  (widget-insert " ")
+                 :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
-                 :notify (lambda (&rest ignore)
-                           (customize-create-theme))
-                 "Reset")
-  (widget-insert " ")
+                 :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)
-                           (bury-buffer))
-                 "Bury Buffer")
+                           (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: ")
+  (save-excursion
+    (goto-char custom-theme-insert-variable-marker)
+    (if (assq symbol custom-theme-variables)
+        (message "%s is already in the theme" (symbol-name symbol))
+      (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)))
+  (save-excursion
+    (goto-char custom-theme-insert-face-marker)
+    (if (assq symbol custom-theme-faces)
+        (message "%s is already in the theme" (symbol-name symbol))
+      (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))
-        (doc (widget-value custom-theme-description))
-        (variables (widget-value custom-theme-variables))
-        (faces (widget-value custom-theme-faces)))
-    (switch-to-buffer (concat name "-theme.el"))
-    (emacs-lisp-mode)
-    (unless (file-exists-p custom-theme-directory)
-      (make-directory (file-name-as-directory custom-theme-directory) t))
-    (setq default-directory custom-theme-directory)
-    (setq buffer-file-name (expand-file-name (concat name "-theme.el")))
-    (let ((inhibit-read-only t))
-      (erase-buffer))
-    (insert "(deftheme " name)
-    (when doc
-      (newline)
-      (insert "  \"" doc "\""))
-    (insert  ")\n")
-    (custom-theme-write-variables name variables)
-    (custom-theme-write-faces name faces)
-    (insert "\n(provide-theme '" name ")\n")
-    (save-buffer)))
+  (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."
-  ;; Most code is stolen from `custom-save-variables'.
   (when vars
     (let ((standard-output (current-buffer)))
       (princ "\n(custom-theme-set-variables\n")
       (princ " '")
       (princ theme)
       (princ "\n")
-      (mapc (lambda (symbol)
-              (when (boundp symbol)
-                (unless (bolp)
-                  (princ "\n"))
-                (princ " '(")
-                (prin1 symbol)
-                (princ " ")
-                (prin1 (custom-quote (symbol-value symbol)))
-                (princ ")")))
-              vars)
+      (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 ")")
@@ -181,18 +381,19 @@ It includes all faces in list FACES."
       (princ " '")
       (princ theme)
       (princ "\n")
-      (mapc (lambda (symbol)
-              (when (facep symbol)
-                (unless (bolp)
-                  (princ "\n"))
-                (princ " '(")
-                (prin1 symbol)
-                (princ " ")
-                (prin1 (list (append '(t)
-                                     (custom-face-attributes-get
-                                      'font-lock-comment-face nil))))
-                (princ ")")))
-              faces)
+      (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 ")")