diff options
Diffstat (limited to 'lisp/cus-theme.el')
| -rw-r--r-- | lisp/cus-theme.el | 811 |
1 files changed, 534 insertions, 277 deletions
diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el index 0fb6e485de1..e6e286f00fa 100644 --- a/lisp/cus-theme.el +++ b/lisp/cus-theme.el @@ -6,6 +6,7 @@ ;; Author: Alex Schroeder <alex@gnu.org> ;; Maintainer: FSF ;; Keywords: help, faces +;; Package: emacs ;; This file is part of GNU Emacs. @@ -34,318 +35,353 @@ (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 "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) - (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) - (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) +;; 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) -(defvar custom-theme-insert-variable-marker) -(defvar custom-theme-insert-face-marker) +(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) + +(defvar custom-theme--listed-faces '(default cursor 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.") + +(defvar custom-theme--save-name) ;;;###autoload -(defun customize-create-theme () - "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. If THEME +is `user', provide an option to remove these as custom settings. +BUFFER, if non-nil, should be a buffer to use; the default is +named *Custom Theme*." (interactive) - (switch-to-buffer (generate-new-buffer "*New Custom Theme*")) + (switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*"))) (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) - (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--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) - (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) + + (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")) -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") + :tag " Revert " + :help-echo "Revert this buffer to its original state." + :action (lambda (&rest ignored) (revert-buffer))) - (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") + :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 "\n") - (widget-create 'push-button - :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 - :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-setup) - (goto-char (point-min)) - (message "")) + " Save Theme ") + (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 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) (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) + (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 "\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)) +(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 "\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)) +(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))) + ;; 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 (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-visit-theme (theme) + "Load the custom theme THEME's settings into the current buffer." + (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) - (interactive "SCustom theme name: ") + "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 (eq theme 'user) - (load-theme theme)) - (let ((settings (get theme 'theme-settings))) + (unless (custom-theme-name-valid-p theme) + (error "Invalid theme name `%s'" theme)) + (load-theme theme 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) + (funcall (if (eq (car setting) 'theme-value) + 'custom-theme-add-variable + 'custom-theme-add-face) + (nth 1 setting) + (nth 3 setting)))) theme) (defun custom-theme-write (&rest ignore) + "Write the current custom theme to its theme file." + (interactive) (let* ((name (widget-value custom-theme-name)) - (filename (expand-file-name (concat name "-theme.el") - custom-theme-directory)) - (doc (widget-value custom-theme-description)) + (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"))) + (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)) + (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)) + (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) + (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) - (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))))) + (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. @@ -356,22 +392,23 @@ It includes all variables in list VARS." (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) + (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 ")") @@ -387,24 +424,244 @@ It includes all faces in list FACES." (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) - (if (bolp) - (princ " ")) + (dolist (spec faces) + (when (widget-get (nth 1 spec) :value) + (let* ((symbol (nth 0 spec)) + (widget (nth 2 spec)) + (value + (if (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)))) + (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"))))) + +;;; 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") + (custom-theme--load-path) + '("" "c"))) + doc) + (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)) + (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))) + + (princ "\n\nDocumentation:\n") + (princ (if (stringp doc) + doc + "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 "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) + (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 `")) + (widget-create 'link :value "custom-theme-load-path" + :button-face 'custom-link + :mouse-face 'highlight + :pressed-face 'highlight + :help-echo "Describe `custom-theme-load-path'." + :keymap custom-mode-link-map + :follow-link 'mouse-face + :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." + :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 (< 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 ;;; cus-theme.el ends here |