diff lisp/cus-theme.el @ 110938:17bbe431e616

New interface for choosing Custom themes. * lisp/cus-edit.el (custom--initialize-widget-variables): New function. (Custom-mode): Use it. * lisp/cus-face.el (custom-theme-set-faces): Remove dead code. Obey custom--inhibit-theme-enable. * lisp/cus-theme.el (describe-theme, customize-themes) (custom-theme-save): New commands. (custom-new-theme-mode-map): Bind C-x C-s. (custom-new-theme-mode): Use custom--initialize-widget-variables. (customize-create-theme): New optional arg THEME. (custom-theme-revert): Use it. (custom-theme-visit-theme): Remove dead code. (custom-theme-merge-theme): Use custom-available-themes. (custom-theme-write): Make interactive. (custom-theme-write): Use custom-theme-name-valid-p. (describe-theme-1, custom-theme-choose-revert) (custom-theme-checkbox-toggle, custom-theme-selections-toggle): New funs. (custom-theme-allow-multiple-selections): New option. (custom-theme-choose-mode): New major mode. * lisp/custom.el (custom-theme-set-variables): Remove dead code. Obey custom--inhibit-theme-enable. (custom--inhibit-theme-enable): New var. (provide-theme): Obey it. (load-theme): Replace load with manual read/eval, in order to check for correctness. Use custom-theme-name-valid-p. (custom-theme-name-valid-p): New function. (custom-available-themes): Use it. * lisp/help-mode.el (help-theme-def, help-theme-edit): New buttons.

--- a/lisp/cus-theme.el	Tue Oct 12 04:45:24 2010 +0200
+++ b/lisp/cus-theme.el	Mon Oct 11 23:10:21 2010 -0400
@@ -35,27 +35,18 @@
   (let ((map (make-keymap)))
     (set-keymap-parent map widget-keymap)
     (suppress-keymap map)
+    (define-key map "\C-x\C-s" 'custom-theme-write)
     (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'."
+(define-derived-mode custom-new-theme-mode nil "Cus-Theme"
+  "Major mode for editing Custom themes.
+Do not call this mode function yourself.  It is meant for internal use."
   (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)
-  (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) "")
-    (set (make-local-variable 'widget-link-prefix) "")
-    (set (make-local-variable 'widget-link-suffix) "")))
+  (custom--initialize-widget-variables)
+  (set (make-local-variable 'revert-buffer-function) 'custom-theme-revert))
 (put 'custom-new-theme-mode 'mode-class 'special)
 
 (defvar custom-theme-name nil)
@@ -82,17 +73,21 @@
   query-replace)
   "Faces listed by default in the *Custom Theme* buffer.")
 
+(defvar custom-theme--save-name)
+
 ;;;###autoload
-(defun customize-create-theme (&optional buffer)
-  "Create a custom theme.
+(defun customize-create-theme (&optional theme buffer)
+  "Create or edit a custom theme.
+THEME, if non-nil, should be an existing theme to edit.
 BUFFER, if non-nil, should be a buffer to use."
   (interactive)
-  (switch-to-buffer (or buffer (generate-new-buffer "*Custom Theme*")))
+  (switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*")))
   ;; Save current faces
   (let ((inhibit-read-only t))
     (erase-buffer))
   (custom-new-theme-mode)
   (make-local-variable 'custom-theme-name)
+  (set (make-local-variable 'custom-theme--save-name) theme)
   (set (make-local-variable 'custom-theme-faces) nil)
   (set (make-local-variable 'custom-theme-variables) nil)
   (set (make-local-variable 'custom-theme-description) "")
@@ -116,7 +111,8 @@
 
   (widget-insert "\n\nTheme name : ")
   (setq custom-theme-name
-	(widget-create 'editable-field))
+	(widget-create 'editable-field
+		       :value (if theme (symbol-name theme) "")))
   (widget-insert "Description: ")
   (setq custom-theme-description
 	(widget-create 'text
@@ -164,14 +160,15 @@
 		 :action (lambda (widget &optional event)
 			   (call-interactively 'custom-theme-add-variable)))
   (widget-insert ?\n)
+  (if theme
+      (custom-theme-merge-theme theme))
   (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))))
+    (customize-create-theme custom-theme--save-name (current-buffer))))
 
 ;;; Theme variables
 
@@ -318,10 +315,8 @@
 
 (defun custom-theme-visit-theme ()
   (interactive)
-  (when (or (and (null custom-theme-variables)
-		 (null custom-theme-faces))
-	    (and (y-or-n-p "Discard current changes? ")
-		 (progn (revert-buffer) t)))
+  (when (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)))
@@ -331,9 +326,14 @@
       (widget-setup))))
 
 (defun custom-theme-merge-theme (theme)
-  (interactive "SCustom theme name: ")
-  (unless (eq theme 'user)
-    (load-theme theme))
+  (interactive
+   (list
+    (intern (completing-read "Merge custom theme: "
+			     (mapcar 'symbol-name
+				     (custom-available-themes))))))
+  (unless (custom-theme-name-valid-p theme)
+    (error "Invalid theme name `%s'" theme))
+  (load-theme theme)
   (let ((settings (get theme 'theme-settings)))
     (dolist (setting settings)
       (if (eq (car setting) 'theme-value)
@@ -343,6 +343,7 @@
   theme)
 
 (defun custom-theme-write (&rest ignore)
+  (interactive)
   (let* ((name (widget-value custom-theme-name))
 	 (doc (widget-value custom-theme-description))
 	 (vars  custom-theme-variables)
@@ -351,12 +352,8 @@
     (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"))
-	   (error "Custom themes cannot be named `%s'" name))
-	  ((string-match " " name)
-	   (error "Custom theme names should not contain spaces")))
+    (unless (custom-theme-name-valid-p (intern name))
+      (error "Custom themes cannot be named `%s'" name))
 
     (setq filename (expand-file-name (concat name "-theme.el")
 				     custom-theme-directory))
@@ -384,7 +381,8 @@
     (dolist (face custom-theme-faces)
       (when (widget-get (cdr face) :children)
 	(widget-put (cdr face) :custom-state 'saved)
-	(custom-redraw-magic (cdr face))))))
+	(custom-redraw-magic (cdr face))))
+    (message "Theme written to %s" filename)))
 
 (defun custom-theme-write-variables (theme vars)
   "Write a `custom-theme-set-variables' command for THEME.
@@ -456,5 +454,196 @@
       (unless (looking-at "\n")
 	(princ "\n")))))
 
+
+;;; Describing Custom themes.
+
+;;;###autoload
+(defun describe-theme (theme)
+  "Display a description of the Custom theme THEME (a symbol)."
+  (interactive
+   (list
+    (intern (completing-read "Describe custom theme: "
+			     (mapcar 'symbol-name
+				     (custom-available-themes))))))
+  (unless (custom-theme-name-valid-p theme)
+    (error "Invalid theme name `%s'" theme))
+  (help-setup-xref (list 'describe-theme theme)
+		   (called-interactively-p 'interactive))
+  (with-help-window (help-buffer)
+    (with-current-buffer standard-output
+      (describe-theme-1 theme))))
+
+(defun describe-theme-1 (theme)
+  (prin1 theme)
+  (princ " is a custom theme")
+  (let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
+			 (cons custom-theme-directory load-path)
+			 '("" "c"))))
+    (when fn
+      (princ " in `")
+      (help-insert-xref-button (file-name-nondirectory fn)
+			       'help-theme-def fn)
+      (princ "'"))
+    (princ ".\n"))
+  (if (not (memq theme custom-known-themes))
+      (princ "It is not loaded.")
+    (if (custom-theme-enabled-p theme)
+	(princ "It is loaded and enabled.\n")
+      (princ "It is loaded but disabled.\n"))
+    (princ "\nDocumentation:\n")
+    (princ (or (get theme 'theme-documentation)
+	       "No documentation available.")))
+  (princ "\n\nYou can ")
+  (help-insert-xref-button "customize" 'help-theme-edit theme)
+  (princ " this theme."))
+
+
+;;; Theme chooser
+
+(defvar custom--listed-themes)
+
+(defcustom custom-theme-allow-multiple-selections nil
+  "Whether to allow multi-selections in the *Custom Themes* buffer."
+  :type 'boolean
+  :group 'custom-buffer)
+
+(defvar custom-theme-choose-mode-map
+  (let ((map (make-keymap)))
+    (set-keymap-parent map widget-keymap)
+    (suppress-keymap map)
+    (define-key map "\C-x\C-s" 'custom-theme-save)
+    (define-key map "n" 'widget-forward)
+    (define-key map "p" 'widget-backward)
+    (define-key map "?" 'custom-describe-theme)
+    map)
+  "Keymap for `custom-theme-choose-mode'.")
+
+(define-derived-mode custom-theme-choose-mode nil "Cus-Theme"
+  "Major mode for selecting Custom themes.
+Do not call this mode function yourself.  It is meant for internal use."
+  (use-local-map custom-theme-choose-mode-map)
+  (custom--initialize-widget-variables)
+  (set (make-local-variable 'revert-buffer-function)
+       (lambda (ignore-auto noconfirm)
+	 (when (or noconfirm (y-or-n-p "Discard current choices? "))
+	   (customize-themes (current-buffer))))))
+(put 'custom-theme-choose-mode 'mode-class 'special)
+
+;;;###autoload
+(defun customize-themes (&optional buffer)
+  "Display a selectable list of Custom themes.
+When called from Lisp, BUFFER should be the buffer to use; if
+omitted, a buffer named *Custom Themes* is used."
+  (interactive)
+  (pop-to-buffer (get-buffer-create (or buffer "*Custom Themes*")))
+  (let ((inhibit-read-only t))
+    (erase-buffer))
+  (custom-theme-choose-mode)
+  (set (make-local-variable 'custom--listed-themes) nil)
+  (make-local-variable 'custom-theme-allow-multiple-selections)
+  (and (null custom-theme-allow-multiple-selections)
+       (> (length custom-enabled-themes) 1)
+       (setq custom-theme-allow-multiple-selections t))
+
+  (widget-insert
+   (substitute-command-keys
+    "Type RET or click to enable/disable listed custom themes.
+Type \\[custom-describe-theme] to describe the theme at point.
+Theme files are named *-theme.el in `"))
+  (when (stringp custom-theme-directory)
+    (widget-create 'link :value custom-theme-directory
+		   :button-face 'custom-link
+		   :mouse-face 'highlight
+		   :pressed-face 'highlight
+		   :help-echo "Describe `custom-theme-directory'."
+		   :keymap custom-mode-link-map
+		   :follow-link 'mouse-face
+		   :action (lambda (widget &rest ignore)
+			     (describe-variable 'custom-theme-directory)))
+    (widget-insert "' or `"))
+  (widget-create 'link :value "load-path"
+		 :button-face 'custom-link
+		 :mouse-face 'highlight
+		 :pressed-face 'highlight
+		 :help-echo "Describe `load-path'."
+		 :keymap custom-mode-link-map
+		 :follow-link 'mouse-face
+		 :action (lambda (widget &rest ignore)
+			   (describe-variable 'load-path)))
+  (widget-insert "'.\n\n")
+  (widget-create 'push-button
+		 :tag " Save Theme Settings "
+		 :help-echo "Save the selected themes for future sessions."
+		 :action 'custom-theme-save)
+  (widget-insert ?\n)
+  (widget-create 'checkbox
+		 :value custom-theme-allow-multiple-selections
+		 :action 'custom-theme-selections-toggle)
+  (widget-insert (propertize " Allow more than one theme at a time"
+			     'face '(variable-pitch (:height 0.9))))
+
+  (widget-insert "\n\nAvailable Custom Themes:\n")
+  (let (widget)
+    (dolist (theme (custom-available-themes))
+      (setq widget (widget-create 'checkbox
+				  :value (custom-theme-enabled-p theme)
+				  :theme-name theme
+				  :action 'custom-theme-checkbox-toggle))
+      (push (cons theme widget) custom--listed-themes)
+      (widget-create-child-and-convert widget 'push-button
+				       :button-face-get 'ignore
+				       :mouse-face-get 'ignore
+				       :value (format " %s" theme)
+				       :action 'widget-parent-action)
+      (widget-insert ?\n)))
+  (goto-char (point-min))
+  (widget-setup))
+
+(defun custom-theme-checkbox-toggle (widget &optional event)
+  (let ((this-theme (widget-get widget :theme-name)))
+    (if (widget-value widget)
+	;; Disable the theme.
+	(disable-theme this-theme)
+      ;; Enable the theme.
+      (unless custom-theme-allow-multiple-selections
+	;; If only one theme is allowed, disable all other themes and
+	;; uncheck their boxes.
+	(dolist (theme custom-enabled-themes)
+	  (and (not (eq theme this-theme))
+	       (assq theme custom--listed-themes)
+	       (disable-theme theme)))
+	(dolist (theme custom--listed-themes)
+	  (unless (eq (car theme) this-theme)
+	    (widget-value-set (cdr theme) nil)
+	    (widget-apply (cdr theme) :notify (cdr theme) event))))
+      (load-theme this-theme)))
+  ;; Mark `custom-enabled-themes' as "set for current session".
+  (put 'custom-enabled-themes 'customized-value
+       (list (custom-quote custom-enabled-themes)))
+  ;; Check/uncheck the widget.
+  (widget-toggle-action widget event))
+
+(defun custom-describe-theme ()
+  "Describe the Custom theme on the current line."
+  (interactive)
+  (let ((widget (widget-at (line-beginning-position))))
+    (and widget
+	 (describe-theme (widget-get widget :theme-name)))))
+
+(defun custom-theme-save (&rest ignore)
+  (interactive)
+  (customize-save-variable 'custom-enabled-themes custom-enabled-themes)
+  (message "Custom themes saved for future sessions."))
+
+(defun custom-theme-selections-toggle (widget &optional event)
+  (when (widget-value widget)
+    ;; Deactivate multiple-selections.
+    (if (> (length (delq nil (mapcar (lambda (x) (widget-value (cdr x)))
+				     custom--listed-themes)))
+	   1)
+	(error "More than one theme is currently selected")))
+  (widget-toggle-action widget event)
+  (setq custom-theme-allow-multiple-selections (widget-value widget)))
+
 ;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
 ;;; cus-theme.el ends here