Mercurial > emacs

changeset 110896:0d6d71f9b91a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Interface improvements to cus-theme.el. * cus-edit.el (custom-face-widget-to-spec) (custom-face-get-current-spec, custom-face-state): New functions. (custom-face-set, custom-face-mark-to-save) (custom-face-value-create, custom-face-state-set): Use them. * cus-theme.el (custom-theme--listed-faces): New var. (customize-create-theme): Use *Custom Theme* as the buffer name. Set revert-buffer-function. Optional arg BUFFER. Insert all faces listed in custom-theme--listed-faces. (custom-theme-revert): New function. (custom-theme-add-variable, custom-theme-add-face): Insert at the bottom of the list. (custom-theme-write): Prompt for theme name if empty. (custom-theme-write-variables): Use dolist. (custom-theme-write-faces): Handle hidden (collapsed) widgets.
author Chong Yidong <cyd@stupidchicken.com>
date Sat, 09 Oct 2010 17:54:20 -0400
parents b803c876a460
children ddcc974a9f3d
files lisp/ChangeLog lisp/cus-edit.el lisp/cus-theme.el
diffstat 3 files changed, 235 insertions(+), 163 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Sat Oct 09 23:38:04 2010 +0200
+++ b/lisp/ChangeLog	Sat Oct 09 17:54:20 2010 -0400
@@ -1,3 +1,21 @@
+2010-10-09  Chong Yidong  <cyd@stupidchicken.com>
+
+	* cus-edit.el (custom-face-widget-to-spec)
+	(custom-face-get-current-spec, custom-face-state): New functions.
+	(custom-face-set, custom-face-mark-to-save)
+	(custom-face-value-create, custom-face-state-set): Use them.
+
+	* cus-theme.el (custom-theme--listed-faces): New var.
+	(customize-create-theme): Use *Custom Theme* as the buffer name.
+	Set revert-buffer-function.  Optional arg BUFFER.  Insert all
+	faces listed in custom-theme--listed-faces.
+	(custom-theme-revert): New function.
+	(custom-theme-add-variable, custom-theme-add-face): Insert at the
+	bottom of the list.
+	(custom-theme-write): Prompt for theme name if empty.
+	(custom-theme-write-variables): Use dolist.
+	(custom-theme-write-faces): Handle hidden (collapsed) widgets.
+
 2010-10-09  Alan Mackenzie  <acm@muc.de>
 
 	Enhance fontification of declarators to take account of the
--- a/lisp/cus-edit.el	Sat Oct 09 23:38:04 2010 +0200
+++ b/lisp/cus-edit.el	Sat Oct 09 17:54:20 2010 -0400
@@ -3379,6 +3379,30 @@
   "Return the customized SPEC in a form suitable for setting the face."
   (custom-filter-face-spec spec 3))
 
+(defun custom-face-widget-to-spec (widget)
+  "Return a face spec corresponding to WIDGET.
+WIDGET should be a `custom-face' widget."
+  (unless (eq (widget-type widget) 'custom-face)
+    (error "Invalid widget"))
+  (let ((child (car (widget-get widget :children))))
+    (custom-post-filter-face-spec
+     (if (eq (widget-type child) 'custom-face-edit)
+	 `((t ,(widget-value child)))
+       (widget-value child)))))
+
+(defun custom-face-get-current-spec (face)
+  (let ((spec (or (get face 'customized-face)
+		  (get face 'saved-face)
+		  (get face 'face-defface-spec)
+		  ;; Attempt to construct it.
+		  `((t ,(custom-face-attributes-get
+			 face (selected-frame)))))))
+    ;; If the user has changed this face in some other way,
+    ;; edit it as the user has specified it.
+    (if (not (face-spec-match-p face spec (selected-frame)))
+	(setq spec `((t ,(face-attr-construct face (selected-frame))))))
+    (custom-pre-filter-face-spec spec)))
+
 (defun custom-face-value-create (widget)
   "Create a list of the display specifications for WIDGET."
   (let* ((buttons (widget-get widget :buttons))
@@ -3464,21 +3488,10 @@
 	(unless (widget-get widget :custom-form)
 	  (widget-put widget :custom-form custom-face-default-form))
 
-	(let* ((spec (or (get symbol 'customized-face)
-			 (get symbol 'saved-face)
-			 (get symbol 'face-defface-spec)
-			 ;; Attempt to construct it.
-			 (list (list t (custom-face-attributes-get
-					symbol (selected-frame))))))
+	(let* ((spec (custom-face-get-current-spec symbol))
 	       (form (widget-get widget :custom-form))
 	       (indent (widget-get widget :indent))
 	       face-alist face-entry spec-default spec-match editor)
-	  ;; If the user has changed this face in some other way,
-	  ;; edit it as the user has specified it.
-	  (if (not (face-spec-match-p symbol spec (selected-frame)))
-	      (setq spec `((t ,(face-attr-construct symbol
-						    (selected-frame))))))
-	  (setq spec (custom-pre-filter-face-spec spec))
 
 	  ;; Find a display in SPEC matching the selected display.
 	  ;; This will use the usual face customization interface.
@@ -3570,43 +3583,43 @@
   (widget-put widget :custom-form 'lisp)
   (custom-redraw widget))
 
+(defun custom-face-state (face)
+  "Return the current state of the face FACE.
+This is one of `set', `saved', `changed', `themed', or `rogue'."
+  (let* ((comment (get face 'face-comment))
+	 (state
+	  (cond
+	   ((or (get face 'customized-face)
+		(get face 'customized-face-comment))
+	    (if (equal (get face 'customized-face-comment) comment)
+		'set
+	      'changed))
+	   ((or (get face 'saved-face)
+		(get face 'saved-face-comment))
+	    (if (equal (get face 'saved-face-comment) comment)
+		(cond
+		 ((eq 'user (caar (get face 'theme-face)))
+		  'saved)
+		 ((eq 'changed (caar (get face 'theme-face)))
+		  'changed)
+		 (t 'themed))
+	      'changed))
+	   ((get face 'face-defface-spec)
+	    (if (equal comment nil)
+		'standard
+	      'changed))
+	   (t 'rogue))))
+    ;; If the user called set-face-attribute to change the default for
+    ;; new frames, this face is "set outside of Customize".
+    (if (and (not (eq state 'rogue))
+	     (get face 'face-modified))
+	'changed
+      state)))
+
 (defun custom-face-state-set (widget)
   "Set the state of WIDGET."
-  (let* ((symbol (widget-value widget))
-	 (comment (get symbol 'face-comment))
-	 tmp temp
-	 (state
-	  (cond ((progn
-		   (setq tmp (get symbol 'customized-face))
-		   (setq temp (get symbol 'customized-face-comment))
-		   (or tmp temp))
-		 (if (equal temp comment)
-		     'set
-		   'changed))
-		((progn
-		   (setq tmp (get symbol 'saved-face))
-		   (setq temp (get symbol 'saved-face-comment))
-		   (or tmp temp))
-		 (if (equal temp comment)
-		     (cond
-		      ((eq 'user (caar (get symbol 'theme-face)))
-		       'saved)
-		      ((eq 'changed (caar (get symbol 'theme-face)))
-		       'changed)
-		      (t 'themed))
-		   'changed))
-		((get symbol 'face-defface-spec)
-		 (if (equal comment nil)
-		     'standard
-		   'changed))
-		(t
-		 'rogue))))
-    ;; If the user called set-face-attribute to change the default
-    ;; for new frames, this face is "set outside of Customize".
-    (if (and (not (eq state 'rogue))
-	     (get symbol 'face-modified))
-	(setq state 'changed))
-    (widget-put widget :custom-state state)))
+  (widget-put widget :custom-state
+	      (custom-face-state (widget-value widget))))
 
 (defun custom-face-action (widget &optional event)
   "Show the menu for `custom-face' WIDGET.
@@ -3626,11 +3639,7 @@
 (defun custom-face-set (widget)
   "Make the face attributes in WIDGET take effect."
   (let* ((symbol (widget-value widget))
-	 (child (car (widget-get widget :children)))
-	 (value (custom-post-filter-face-spec
-		 (if (eq (widget-type child) 'custom-face-edit)
-		     `((t ,(widget-value child)))
-		   (widget-value child))))
+	 (value  (custom-face-widget-to-spec widget))
 	 (comment-widget (widget-get widget :comment-widget))
 	 (comment (widget-value comment-widget)))
     (when (equal comment "")
@@ -3652,11 +3661,7 @@
 (defun custom-face-mark-to-save (widget)
   "Mark for saving the face edited by WIDGET."
   (let* ((symbol (widget-value widget))
-	 (child (car (widget-get widget :children)))
-	 (value (custom-post-filter-face-spec
-		 (if (eq (widget-type child) 'custom-face-edit)
-		     `((t ,(widget-value child)))
-		   (widget-value child))))
+	 (value  (custom-face-widget-to-spec widget))
 	 (comment-widget (widget-get widget :comment-widget))
 	 (comment (widget-value comment-widget)))
     (when (equal comment "")
--- a/lisp/cus-theme.el	Sat Oct 09 23:38:04 2010 +0200
+++ b/lisp/cus-theme.el	Sat Oct 09 17:54:20 2010 -0400
@@ -50,6 +50,7 @@
   (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)
+  (set (make-local-variable 'revert-buffer-function) 'custom-theme-revert)
   (when custom-raised-buttons
     (set (make-local-variable 'widget-push-button-prefix) "")
     (set (make-local-variable 'widget-push-button-suffix) "")
@@ -60,95 +61,118 @@
 (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)
+(defvar custom-theme-description nil)
+(defvar custom-theme-insert-variable-marker nil)
+(defvar custom-theme-insert-face-marker nil)
+
+(defvar custom-theme--listed-faces '(default fixed-pitch
+  variable-pitch escape-glyph minibuffer-prompt highlight region
+  shadow secondary-selection trailing-whitespace
+  font-lock-builtin-face font-lock-comment-delimiter-face
+  font-lock-comment-face font-lock-constant-face
+  font-lock-doc-face font-lock-function-name-face
+  font-lock-keyword-face font-lock-negation-char-face
+  font-lock-preprocessor-face font-lock-regexp-grouping-backslash
+  font-lock-regexp-grouping-construct font-lock-string-face
+  font-lock-type-face font-lock-variable-name-face
+  font-lock-warning-face button link link-visited fringe
+  header-line tooltip mode-line mode-line-buffer-id
+  mode-line-emphasis mode-line-highlight mode-line-inactive
+  isearch isearch-fail lazy-highlight match next-error
+  query-replace)
+  "Faces listed by default in the *Custom Theme* buffer.")
 
 ;;;###autoload
-(defun customize-create-theme ()
-  "Create a custom theme."
+(defun customize-create-theme (&optional buffer)
+  "Create a custom theme.
+BUFFER, if non-nil, should be a buffer to use."
   (interactive)
-  (switch-to-buffer (generate-new-buffer "*New Custom Theme*"))
+  (switch-to-buffer (or buffer (generate-new-buffer "*Custom Theme*")))
+  ;; Save current faces
   (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)
+  (set (make-local-variable 'custom-theme-faces) nil)
+  (set (make-local-variable 'custom-theme-variables) nil)
+  (set (make-local-variable 'custom-theme-description) "")
   (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.
+  (make-local-variable 'custom-theme-insert-variable-marker)
+  (make-local-variable 'custom-theme--listed-faces)
 
-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"
+		 :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"
+		 :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-create 'push-button :notify 'revert-buffer " Revert ")
 
-  (widget-insert "\n\nTheme name: ")
+  (widget-insert "\n\nTheme name : ")
   (setq custom-theme-name
-	(widget-create 'editable-field
-		       :size 10
-		       user-login-name))
-  (widget-insert "\n\nDocumentation:\n")
+	(widget-create 'editable-field))
+  (widget-insert "Description: ")
   (setq custom-theme-description
 	(widget-create 'text
 		       :value (format-time-string "Created %Y-%m-%d.")))
-  (widget-insert "\n")
+  (widget-insert "             ")
+  (widget-create 'push-button
+     		 :notify (function custom-theme-write)
+     		 " Save Theme ")
+  ;; Face widgets
+  (widget-insert "\n\n  Theme faces:\n")
+  (let (widget)
+    (dolist (face custom-theme--listed-faces)
+      (widget-insert "  ")
+      (setq widget (widget-create 'custom-face
+				  :documentation-shown t
+				  :tag (custom-unlispify-tag-name face)
+				  :value face
+				  :display-style 'concise
+				  :custom-state 'hidden
+				  :sample-indent 34))
+      (custom-magic-reset widget)
+      (push (cons face widget) custom-theme-faces)))
+  (insert " ")
+  (setq custom-theme-insert-face-marker (point-marker))
+  (insert " ")
+  (widget-create 'push-button
+		 :tag "Insert Additional Face"
+		 :help-echo "Add another face to this theme."
+		 :follow-link 'mouse-face
+		 :button-face 'custom-link
+		 :mouse-face 'highlight
+		 :pressed-face 'highlight
+		 :action (lambda (widget &optional event)
+			   (call-interactively 'custom-theme-add-face)))
+  (widget-insert "\n\n  Theme variables:\n ")
+  (setq custom-theme-insert-variable-marker (point-marker))
+  (widget-insert ?\s)
   (widget-create 'push-button
 		 :tag "Insert Variable"
 		 :help-echo "Add another variable to this theme."
+		 :follow-link 'mouse-face
+		 :button-face 'custom-link
+		 :mouse-face 'highlight
+		 :pressed-face 'highlight
 		 :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-insert ?\n)
   (widget-setup)
   (goto-char (point-min))
   (message ""))
 
+(defun custom-theme-revert (ignore-auto noconfirm)
+  (when (or noconfirm (y-or-n-p "Discard current changes? "))
+    (erase-buffer)
+    (customize-create-theme (current-buffer))))
+
 ;;; Theme variables
 
 (defun custom-theme-add-variable (symbol)
@@ -162,7 +186,7 @@
 	(t
 	 (save-excursion
 	   (goto-char custom-theme-insert-variable-marker)
-	   (widget-insert "\n")
+	   (widget-insert " ")
 	   (let ((widget (widget-create 'custom-variable
 					:tag (custom-unlispify-tag-name symbol)
 					:custom-level 0
@@ -171,6 +195,8 @@
 					:value symbol)))
 	     (push (cons symbol widget) custom-theme-variables)
 	     (custom-magic-reset widget))
+	   (widget-insert " ")
+	   (move-marker custom-theme-insert-variable-marker (point))
 	   (widget-setup)))))
 
 (defvar custom-theme-variable-menu
@@ -231,15 +257,19 @@
 	(t
 	 (save-excursion
 	   (goto-char custom-theme-insert-face-marker)
-	   (widget-insert "\n")
+	   (widget-insert " ")
 	   (let ((widget (widget-create 'custom-face
 					:tag (custom-unlispify-tag-name symbol)
 					:custom-level 0
 					:action 'custom-theme-face-action
 					:custom-state 'unknown
+					:display-style 'concise
+					:sample-indent 34
 					:value symbol)))
 	     (push (cons symbol widget) custom-theme-faces)
 	     (custom-magic-reset widget)
+	     (widget-insert " ")
+	     (move-marker custom-theme-insert-face-marker (point))
 	     (widget-setup))))))
 
 (defvar custom-theme-face-menu
@@ -288,9 +318,10 @@
 
 (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)))
+  (when (or (and (null custom-theme-variables)
+		 (null custom-theme-faces))
+	    (and (y-or-n-p "Discard current changes? ")
+		 (progn (revert-buffer) t)))
     (let ((theme (call-interactively 'custom-theme-merge-theme)))
       (unless (eq theme 'user)
 	(widget-value-set custom-theme-name (symbol-name theme)))
@@ -313,21 +344,26 @@
 
 (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))
+	 (vars  custom-theme-variables)
+	 (faces custom-theme-faces)
+	 filename)
+    (when (string-equal name "")
+      (setq name (read-from-minibuffer "Theme name: " (user-login-name)))
+      (widget-value-set custom-theme-name name))
     (cond ((or (string-equal name "")
-	      (string-equal name "user")
-	      (string-equal name "changed"))
+	       (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")))
+	   (error "Custom theme names should not contain spaces")))
+
+    (setq filename (expand-file-name (concat name "-theme.el")
+				     custom-theme-directory))
+    (and (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)
@@ -342,11 +378,13 @@
       (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)))))
+      (when (widget-get (cdr var) :children)
+	(widget-put (cdr var) :custom-state 'saved)
+	(custom-redraw-magic (cdr var))))
+    (dolist (face custom-theme-faces)
+      (when (widget-get (cdr face) :children)
+	(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.
@@ -357,22 +395,21 @@
       (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)
+      (dolist (spec vars)
+	(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 ")"))))
       (if (bolp)
 	  (princ " "))
       (princ ")")
@@ -388,19 +425,31 @@
       (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)
+      (dolist (spec faces)
+	(let* ((symbol (car spec))
+	       (widget (cdr spec))
+	       (child  (car-safe (widget-get widget :children)))
+	       (state  (if child
+			   (widget-get widget :custom-state)
+			 (custom-face-state symbol)))
+	       (value
+		(cond ((eq state 'standard)
+		       nil) ; do nothing
+		      (child
+		       (custom-face-widget-to-spec widget))
+		      (t
+		       ;; Widget is closed (hidden), but the face has
+		       ;; a non-standard value.  Try to extract that
+		       ;; value and save it.
+		       (custom-face-get-current-spec symbol)))))
+	  (when (and (facep symbol) value)
+	    (if (bolp)
+		(princ " '(")
+	      (princ "\n '("))
+	    (prin1 symbol)
+	    (princ " ")
+	    (prin1 value)
+	    (princ ")"))))
       (if (bolp)
 	  (princ " "))
       (princ ")")