Mercurial > emacs

changeset 67982:a711a44049e2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
* 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.
author Chong Yidong <cyd@stupidchicken.com>
date Mon, 02 Jan 2006 22:02:11 +0000
parents 6e1f6ef9bc5f
children eea3a49a9d6c
files lisp/ChangeLog lisp/cus-theme.el
diffstat 2 files changed, 289 insertions(+), 76 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Mon Jan 02 18:10:16 2006 +0000
+++ b/lisp/ChangeLog	Mon Jan 02 22:02:11 2006 +0000
@@ -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.
--- a/lisp/cus-theme.el	Mon Jan 02 18:10:16 2006 +0000
+++ b/lisp/cus-theme.el	Mon Jan 02 22:02:11 2006 +0000
@@ -58,18 +58,18 @@
     (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 @@
   (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 @@
   (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 @@
       (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 ")")