X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/0c747cb143fa227e78f350ac353d703f489209df..d3e4228575e9ba9e99dc4a7dae788280ffcc4566:/lisp/cus-theme.el diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el index 197d9787d9..606033f915 100644 --- a/lisp/cus-theme.el +++ b/lisp/cus-theme.el @@ -1,7 +1,6 @@ ;;; cus-theme.el -- custom theme creation user interface ;; -;; Copyright (C) 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2001-2012 Free Software Foundation, Inc. ;; ;; Author: Alex Schroeder ;; Maintainer: FSF @@ -41,7 +40,7 @@ map) "Keymap for `custom-new-theme-mode'.") -(define-derived-mode custom-new-theme-mode nil "Cus-Theme" +(define-derived-mode custom-new-theme-mode nil "Custom-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) @@ -50,9 +49,12 @@ Do not call this mode function yourself. It is meant for internal use." (put 'custom-new-theme-mode 'mode-class 'special) (defvar custom-theme-name nil) +;; Each element has the form (VAR CHECKBOX-WIDGET VAR-WIDGET) (defvar custom-theme-variables nil) +;; Each element has the form (FACE CHECKBOX-WIDGET FACE-WIDGET) (defvar custom-theme-faces nil) (defvar custom-theme-description nil) +(defvar custom-theme--migrate-settings nil) (defvar custom-theme-insert-variable-marker nil) (defvar custom-theme-insert-face-marker nil) @@ -78,275 +80,281 @@ Do not call this mode function yourself. It is meant for internal use." ;;;###autoload (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." +THEME, if non-nil, should be an existing theme to edit. If THEME +is `user', the resulting *Custom Theme* buffer also contains a +checkbox for removing the theme settings specified in the buffer +from the Custom save file. +BUFFER, if non-nil, should be a buffer to use; the default is +named *Custom Theme*." (interactive) (switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*"))) - ;; Save current faces (let ((inhibit-read-only t)) - (erase-buffer)) + (erase-buffer) + (dolist (ov (overlays-in (point-min) (point-max))) + (delete-overlay ov))) (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) "") + (set (make-local-variable 'custom-theme--migrate-settings) nil) (make-local-variable 'custom-theme-insert-face-marker) (make-local-variable 'custom-theme-insert-variable-marker) (make-local-variable 'custom-theme--listed-faces) + (when (called-interactively-p 'interactive) + (unless (y-or-n-p "Include basic face customizations in this theme? ") + (setq custom-theme--listed-faces nil))) + + (if (eq theme 'user) + (widget-insert "This buffer contains all the Custom settings you have made. +You can convert them into a new custom theme, and optionally +remove them from your saved Custom file.\n\n")) (widget-create 'push-button :tag " Visit Theme " :help-echo "Insert the settings of a pre-defined theme." - :action (lambda (widget &optional event) + :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) + :action (lambda (_widget &optional _event) (call-interactively 'custom-theme-merge-theme))) (widget-insert " ") - (widget-create 'push-button :notify 'revert-buffer " Revert ") + (widget-create 'push-button + :tag " Revert " + :help-echo "Revert this buffer to its original state." + :action (lambda (&rest ignored) (revert-buffer))) (widget-insert "\n\nTheme name : ") (setq custom-theme-name (widget-create 'editable-field - :value (if theme (symbol-name theme) ""))) + :value (if (and theme (not (eq theme 'user))) + (symbol-name theme) + ""))) (widget-insert "Description: ") (setq custom-theme-description (widget-create 'text :value (format-time-string "Created %Y-%m-%d."))) - (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) - (if theme - (custom-theme-merge-theme theme)) - (widget-setup) - (goto-char (point-min)) - (message "")) - -(defun custom-theme-revert (ignore-auto noconfirm) + (when (eq theme 'user) + (setq custom-theme--migrate-settings t) + (widget-insert " ") + (widget-create 'checkbox + :value custom-theme--migrate-settings + :action (lambda (widget &optional event) + (when (widget-value widget) + (widget-toggle-action widget event) + (setq custom-theme--migrate-settings + (widget-value widget))))) + (widget-insert (propertize " Remove saved theme settings from Custom save file." + 'face '(variable-pitch (:height 0.9))))) + + (let (vars values faces face-specs) + + ;; Load the theme settings. + (when theme + (unless (eq theme 'user) + (load-theme theme nil t)) + (dolist (setting (get theme 'theme-settings)) + (if (eq (car setting) 'theme-value) + (progn (push (nth 1 setting) vars) + (push (nth 3 setting) values)) + (push (nth 1 setting) faces) + (push (nth 3 setting) face-specs)))) + + ;; If THEME is non-nil, insert all of that theme's faces. + ;; Otherwise, insert those in `custom-theme--listed-faces'. + (widget-insert "\n\n Theme faces:\n ") + (if theme + (while faces + (custom-theme-add-face-1 (pop faces) (pop face-specs))) + (dolist (face custom-theme--listed-faces) + (custom-theme-add-face-1 face nil))) + (setq custom-theme-insert-face-marker (point-marker)) + (widget-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))) + + ;; If THEME is non-nil, insert all of that theme's variables. + (widget-insert "\n\n Theme variables:\n ") + (if theme + (while vars + (if (eq (car vars) 'custom-enabled-themes) + (progn (pop vars) (pop values)) + (custom-theme-add-var-1 (pop vars) (eval (pop values)))))) + (setq custom-theme-insert-variable-marker (point-marker)) + (widget-insert " ") + (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) + (widget-setup) + (goto-char (point-min)) + (message ""))) + +(defun custom-theme-revert (_ignore-auto noconfirm) + "Revert the current *Custom Theme* buffer. +This is the `revert-buffer-function' for `custom-new-theme-mode'." (when (or noconfirm (y-or-n-p "Discard current changes? ")) (customize-create-theme custom-theme--save-name (current-buffer)))) ;;; 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 " ") - (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-insert " ") - (move-marker custom-theme-insert-variable-marker (point)) - (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)) +(defun custom-theme-add-variable (var value) + "Add a widget for VAR (a symbol) to the *New Custom Theme* buffer. +VALUE should be a value to which to set the widget; when called +interactively, this defaults to the current value of VAR." + (interactive + (let ((v (read-variable "Variable name: "))) + (list v (symbol-value v)))) + (let ((entry (assq var custom-theme-variables))) + (cond ((null entry) + ;; If VAR is not yet in the buffer, add it. + (save-excursion + (goto-char custom-theme-insert-variable-marker) + (custom-theme-add-var-1 var value) + (move-marker custom-theme-insert-variable-marker (point)) + (widget-setup))) + ;; Otherwise, alter that var widget. + (t + (widget-value-set (nth 1 entry) t) + (let ((widget (nth 2 entry))) + (widget-put widget :shown-value (list value)) + (custom-redraw widget)))))) + +(defun custom-theme-add-var-1 (symbol val) + (widget-insert " ") + (push (list symbol + (prog1 (widget-create 'checkbox + :value t + :help-echo "Enable/disable this variable.") + (widget-insert " ")) + (widget-create 'custom-variable + :tag (custom-unlispify-tag-name symbol) + :value symbol + :shown-value (list val) + :notify 'ignore + :custom-level 0 + :custom-state 'hidden + :custom-style 'simple)) + custom-theme-variables) + (widget-insert " ")) ;;; 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 " ") - (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 " ") +(defun custom-theme-add-face (face &optional spec) + "Add a widget for FACE (a symbol) to the *New Custom Theme* buffer. +SPEC, if non-nil, should be a face spec to which to set the widget." + (interactive (list (read-face-name "Face name" nil nil) nil)) + (unless (or (facep face) spec) + (error "`%s' has no face definition" face)) + (let ((entry (assq face custom-theme-faces))) + (cond ((null entry) + ;; If FACE is not yet in the buffer, add it. + (save-excursion + (goto-char custom-theme-insert-face-marker) + (custom-theme-add-face-1 face spec) (move-marker custom-theme-insert-face-marker (point)) - (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)) + (widget-setup))) + ;; Otherwise, if SPEC is supplied, alter that face widget. + (spec + (widget-value-set (nth 1 entry) t) + (let ((widget (nth 2 entry))) + (widget-put widget :shown-value spec) + (custom-redraw widget))) + ((called-interactively-p 'interactive) + (error "`%s' is already present" face))))) + +(defun custom-theme-add-face-1 (symbol spec) + (widget-insert " ") + (push (list symbol + (prog1 + (widget-create 'checkbox + :value t + :help-echo "Enable/disable this face.") + (widget-insert " ")) + (widget-create 'custom-face + :tag (custom-unlispify-tag-name symbol) + :documentation-shown t + :value symbol + :custom-state 'hidden + :custom-style 'simple + :shown-value spec + :sample-indent 34)) + custom-theme-faces) + (widget-insert " ")) ;;; Reading and writing -(defun custom-theme-visit-theme () - (interactive) - (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))) - (widget-value-set custom-theme-description - (or (get theme 'theme-documentation) - (format-time-string "Created %Y-%m-%d."))) - (widget-setup)))) +;;;###autoload +(defun custom-theme-visit-theme (theme) + "Set up a Custom buffer to edit custom theme THEME." + (interactive + (list + (intern (completing-read "Find custom theme: " + (mapcar 'symbol-name + (custom-available-themes)))))) + (unless (custom-theme-name-valid-p theme) + (error "No valid theme named `%s'" theme)) + (cond ((not (eq major-mode 'custom-new-theme-mode)) + (customize-create-theme theme)) + ((y-or-n-p "Discard current changes? ") + (setq custom-theme--save-name theme) + (custom-theme-revert nil t)))) (defun custom-theme-merge-theme (theme) + "Merge the custom theme THEME's settings into the current buffer." (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))) + (unless (eq theme 'user) + (unless (custom-theme-name-valid-p theme) + (error "Invalid theme name `%s'" theme)) + (load-theme theme nil t)) + (let ((settings (reverse (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) + (let ((option (eq (car setting) 'theme-value)) + (name (nth 1 setting)) + (value (nth 3 setting))) + (unless (and option + (memq name '(custom-enabled-themes + custom-safe-themes))) + (funcall (if option + 'custom-theme-add-variable + 'custom-theme-add-face) + name value))))) theme) -(defun custom-theme-write (&rest ignore) +;; From cus-edit.el +(defvar custom-reset-standard-faces-list) +(defvar custom-reset-standard-variables-list) + +(defun custom-theme-write (&rest _ignore) + "Write the current custom theme to its theme file." (interactive) (let* ((name (widget-value custom-theme-name)) - (doc (widget-value custom-theme-description)) - (vars custom-theme-variables) + (doc (widget-value custom-theme-description)) + (vars custom-theme-variables) (faces custom-theme-faces) filename) (when (string-equal name "") @@ -363,26 +371,33 @@ Optional EVENT is the location for the menu." (with-temp-buffer (emacs-lisp-mode) - (unless (file-exists-p custom-theme-directory) + (unless (file-directory-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) + (custom-theme-write-variables name (reverse vars)) + (custom-theme-write-faces name (reverse faces)) (insert "\n(provide-theme '" name ")\n") (save-buffer)) - (dolist (var vars) - (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)))) - (message "Theme written to %s" filename))) + (message "Theme written to %s" filename) + + (when custom-theme--migrate-settings + ;; Remove these settings from the Custom file. + (let ((custom-reset-standard-variables-list '(t)) + (custom-reset-standard-faces-list '(t))) + (dolist (var vars) + (when (and (not (eq (car var) 'custom-enabled-themes)) + (widget-get (nth 1 var) :value)) + (widget-apply (nth 2 var) :custom-mark-to-reset-standard))) + (dolist (face faces) + (when (widget-get (nth 1 face) :value) + (widget-apply (nth 2 face) :custom-mark-to-reset-standard))) + (custom-save-all)) + (let ((custom-theme-load-path (list 'custom-theme-directory))) + (load-theme (intern name)))))) (defun custom-theme-write-variables (theme vars) "Write a `custom-theme-set-variables' command for THEME. @@ -394,20 +409,22 @@ It includes all variables in list VARS." (princ theme) (princ "\n") (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 ")")))) + (when (widget-get (nth 1 spec) :value) + (let* ((symbol (nth 0 spec)) + (widget (nth 2 spec)) + (child (car-safe (widget-get widget :children))) + (value (if child + (widget-value child) + ;; Child is null if the widget is closed (hidden). + (car (widget-get widget :shown-value))))) + (when (boundp symbol) + (unless (bolp) + (princ "\n")) + (princ " '(") + (prin1 symbol) + (princ " ") + (prin1 (custom-quote value)) + (princ ")"))))) (if (bolp) (princ " ")) (princ ")") @@ -424,32 +441,24 @@ It includes all faces in list FACES." (princ theme) (princ "\n") (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 " ")) + ;; Insert the face iff the checkbox widget is checked. + (when (widget-get (nth 1 spec) :value) + (let* ((symbol (nth 0 spec)) + (widget (nth 2 spec)) + (value + (cond + ((car-safe (widget-get widget :children)) + (custom-face-widget-to-spec widget)) + ;; Child is null if the widget is closed (hidden). + ((widget-get widget :shown-value)) + (t (custom-face-get-current-spec symbol))))) + (when (and (facep symbol) value) + (princ (if (bolp) " '(" "\n '(")) + (prin1 symbol) + (princ " ") + (prin1 value) + (princ ")"))))) + (if (bolp) (princ " ")) (princ ")") (unless (looking-at "\n") (princ "\n"))))) @@ -477,7 +486,7 @@ It includes all faces in list FACES." (prin1 theme) (princ " is a custom theme") (let ((fn (locate-file (concat (symbol-name theme) "-theme.el") - (cons custom-theme-directory load-path) + (custom-theme--load-path) '("" "c"))) doc) (when fn @@ -486,25 +495,24 @@ It includes all faces in list FACES." 'help-theme-def fn) (princ "'")) (princ ".\n") - (if (not (memq theme custom-known-themes)) + (if (custom-theme-p theme) (progn - (princ "It is not loaded.") - ;; Attempt to grab the theme documentation - (when fn - (with-temp-buffer - (insert-file-contents fn) - (let ((sexp (let ((read-circle nil)) - (condition-case nil - (read (current-buffer)) - (end-of-file nil))))) - (and sexp (listp sexp) - (eq (car sexp) 'deftheme) - (setq doc (nth 2 sexp))))))) - (if (custom-theme-enabled-p theme) - (princ "It is loaded and enabled.") - (princ "It is loaded but disabled.")) - (setq doc (get theme 'theme-documentation))) - + (if (custom-theme-enabled-p theme) + (princ "It is loaded and enabled.") + (princ "It is loaded but disabled.")) + (setq doc (get theme 'theme-documentation))) + (princ "It is not loaded.") + ;; Attempt to grab the theme documentation + (when fn + (with-temp-buffer + (insert-file-contents fn) + (let ((sexp (let ((read-circle nil)) + (condition-case nil + (read (current-buffer)) + (end-of-file nil))))) + (and sexp (listp sexp) + (eq (car sexp) 'deftheme) + (setq doc (nth 2 sexp))))))) (princ "\n\nDocumentation:\n") (princ (if (stringp doc) doc @@ -520,12 +528,14 @@ It includes all faces in list FACES." (defcustom custom-theme-allow-multiple-selections nil "Whether to allow multi-selections in the *Custom Themes* buffer." + :version "24.1" :type 'boolean :group 'custom-buffer) (defvar custom-theme-choose-mode-map (let ((map (make-keymap))) - (set-keymap-parent map widget-keymap) + (set-keymap-parent map (make-composed-keymap widget-keymap + special-mode-map)) (suppress-keymap map) (define-key map "\C-x\C-s" 'custom-theme-save) (define-key map "n" 'widget-forward) @@ -534,13 +544,13 @@ It includes all faces in list FACES." map) "Keymap for `custom-theme-choose-mode'.") -(define-derived-mode custom-theme-choose-mode nil "Cus-Theme" +(define-derived-mode custom-theme-choose-mode special-mode "Themes" "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) + (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) @@ -551,7 +561,7 @@ Do not call this mode function yourself. It is meant for internal use." 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*"))) + (switch-to-buffer (get-buffer-create (or buffer "*Custom Themes*"))) (let ((inhibit-read-only t)) (erase-buffer)) (custom-theme-choose-mode) @@ -566,27 +576,40 @@ omitted, a buffer named *Custom Themes* is used." "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" + (widget-create 'link :value "custom-theme-load-path" :button-face 'custom-link :mouse-face 'highlight :pressed-face 'highlight - :help-echo "Describe `load-path'." + :help-echo "Describe `custom-theme-load-path'." :keymap custom-mode-link-map :follow-link 'mouse-face - :action (lambda (widget &rest ignore) - (describe-variable 'load-path))) + :action (lambda (_widget &rest _ignore) + (describe-variable 'custom-theme-load-path))) (widget-insert "'.\n\n") + + ;; If the user has made customizations, display a warning and + ;; provide buttons to disable or convert them. + (let ((user-settings (get 'user 'theme-settings))) + (unless (or (null user-settings) + (and (null (cdr user-settings)) + (eq (caar user-settings) 'theme-value) + (eq (cadr (car user-settings)) 'custom-enabled-themes))) + (widget-insert + (propertize + " Note: Your custom settings take precedence over theme settings. + To migrate your settings into a theme, click " + 'face 'font-lock-warning-face)) + (widget-create 'link :value "here" + :button-face 'custom-link + :mouse-face 'highlight + :pressed-face 'highlight + :help-echo "Migrate." + :keymap custom-mode-link-map + :follow-link 'mouse-face + :action (lambda (_widget &rest _ignore) + (customize-create-theme 'user))) + (widget-insert ".\n\n"))) + (widget-create 'push-button :tag " Save Theme Settings " :help-echo "Save the selected themes for future sessions." @@ -595,31 +618,63 @@ Theme files are named *-theme.el in `")) (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" + (widget-insert (propertize " Select more than one theme at a time" 'face '(variable-pitch (:height 0.9)))) (widget-insert "\n\nAvailable Custom Themes:\n") - (let (widget) + (let ((help-echo "mouse-2: Enable this theme for this session") + widget) (dolist (theme (custom-available-themes)) (setq widget (widget-create 'checkbox :value (custom-theme-enabled-p theme) :theme-name theme + :help-echo help-echo :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))) + :action 'widget-parent-action + :help-echo help-echo) + (widget-insert " -- " + (propertize (custom-theme-summary theme) + 'face 'shadow) + ?\n))) (goto-char (point-min)) (widget-setup)) +(defun custom-theme-summary (theme) + "Return the summary line of THEME." + (let (doc) + (if (custom-theme-p theme) + (setq doc (get theme 'theme-documentation)) + (let ((fn (locate-file (concat (symbol-name theme) "-theme.el") + (custom-theme--load-path) + '("" "c")))) + (when fn + (with-temp-buffer + (insert-file-contents fn) + (let ((sexp (let ((read-circle nil)) + (condition-case nil + (read (current-buffer)) + (end-of-file nil))))) + (and sexp (listp sexp) + (eq (car sexp) 'deftheme) + (setq doc (nth 2 sexp)))))))) + (cond ((null doc) + "(no documentation available)") + ((string-match ".*" doc) + (match-string 0 doc)) + (t doc)))) + (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) + (progn + (disable-theme this-theme) + (widget-toggle-action widget event)) ;; Enable the theme. (unless custom-theme-allow-multiple-selections ;; If only one theme is allowed, disable all other themes and @@ -632,12 +687,11 @@ Theme files are named *-theme.el in `")) (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)) + (when (load-theme this-theme) + (widget-toggle-action widget event))) + ;; Mark `custom-enabled-themes' as "set for current session". + (put 'custom-enabled-themes 'customized-value + (list (custom-quote custom-enabled-themes))))) (defun custom-describe-theme () "Describe the Custom theme on the current line." @@ -646,7 +700,7 @@ Theme files are named *-theme.el in `")) (and widget (describe-theme (widget-get widget :theme-name))))) -(defun custom-theme-save (&rest ignore) +(defun custom-theme-save (&rest _ignore) (interactive) (customize-save-variable 'custom-enabled-themes custom-enabled-themes) (message "Custom themes saved for future sessions.")) @@ -654,12 +708,12 @@ Theme files are named *-theme.el in `")) (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) + (if (< 1 (length (delq nil (mapcar (lambda (x) (widget-value (cdr x))) + custom--listed-themes)))) (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 +(provide 'cus-theme) + ;;; cus-theme.el ends here