lisp/cus-theme.el

   1 ;;; cus-theme.el -- custom theme creation user interface
   2 ;;
   3 ;; Copyright (C) 2001-2017 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Alex Schroeder <alex@gnu.org>
   6 ;; Maintainer: emacs-devel@gnu.org
   7 ;; Keywords: help, faces
   8 ;; Package: emacs
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Code:
  26
  27 (require 'widget)
  28 (require 'cus-edit)
  29
  30 (eval-when-compile
  31   (require 'wid-edit))
  32
  33 (defvar custom-new-theme-mode-map
  34   (let ((map (make-keymap)))
  35     (set-keymap-parent map (make-composed-keymap widget-keymap
  36                                                  special-mode-map))
  37     (suppress-keymap map)
  38     (define-key map "\C-x\C-s" 'custom-theme-write)
  39     (define-key map "q" 'Custom-buffer-done)
  40     (define-key map "n" 'widget-forward)
  41     (define-key map "p" 'widget-backward)
  42     map)
  43   "Keymap for `custom-new-theme-mode'.")
  44
  45 (define-derived-mode custom-new-theme-mode nil "Custom-Theme"
  46   "Major mode for editing Custom themes.
  47 Do not call this mode function yourself.  It is meant for internal use."
  48   (use-local-map custom-new-theme-mode-map)
  49   (custom--initialize-widget-variables)
  50   (set (make-local-variable 'revert-buffer-function) 'custom-theme-revert))
  51 (put 'custom-new-theme-mode 'mode-class 'special)
  52
  53 (defvar custom-theme-name nil)
  54 ;; Each element has the form (VAR CHECKBOX-WIDGET VAR-WIDGET)
  55 (defvar custom-theme-variables nil)
  56 ;; Each element has the form (FACE CHECKBOX-WIDGET FACE-WIDGET)
  57 (defvar custom-theme-faces nil)
  58 (defvar custom-theme-description nil)
  59 (defvar custom-theme--migrate-settings nil)
  60 (defvar custom-theme-insert-variable-marker nil)
  61 (defvar custom-theme-insert-face-marker nil)
  62
  63 (defvar custom-theme--listed-faces '(default cursor fixed-pitch
  64   variable-pitch escape-glyph homoglyph
  65   minibuffer-prompt highlight region
  66   shadow secondary-selection trailing-whitespace
  67   font-lock-builtin-face font-lock-comment-delimiter-face
  68   font-lock-comment-face font-lock-constant-face
  69   font-lock-doc-face font-lock-function-name-face
  70   font-lock-keyword-face font-lock-negation-char-face
  71   font-lock-preprocessor-face font-lock-regexp-grouping-backslash
  72   font-lock-regexp-grouping-construct font-lock-string-face
  73   font-lock-type-face font-lock-variable-name-face
  74   font-lock-warning-face button link link-visited fringe
  75   header-line tooltip mode-line mode-line-buffer-id
  76   mode-line-emphasis mode-line-highlight mode-line-inactive
  77   isearch isearch-fail lazy-highlight match next-error
  78   query-replace)
  79   "Faces listed by default in the *Custom Theme* buffer.")
  80
  81 (defvar custom-theme--save-name)
  82
  83 ;;;###autoload
  84 (defun customize-create-theme (&optional theme buffer)
  85   "Create or edit a custom theme.
  86 THEME, if non-nil, should be an existing theme to edit.  If THEME
  87 is `user', the resulting *Custom Theme* buffer also contains a
  88 checkbox for removing the theme settings specified in the buffer
  89 from the Custom save file.
  90 BUFFER, if non-nil, should be a buffer to use; the default is
  91 named *Custom Theme*."
  92   (interactive)
  93   (switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*")))
  94   (let ((inhibit-read-only t))
  95     (erase-buffer)
  96     (dolist (ov (overlays-in (point-min) (point-max)))
  97       (delete-overlay ov)))
  98   (custom-new-theme-mode)
  99   (make-local-variable 'custom-theme-name)
 100   (set (make-local-variable 'custom-theme--save-name) theme)
 101   (set (make-local-variable 'custom-theme-faces) nil)
 102   (set (make-local-variable 'custom-theme-variables) nil)
 103   (set (make-local-variable 'custom-theme-description) "")
 104   (set (make-local-variable 'custom-theme--migrate-settings) nil)
 105   (make-local-variable 'custom-theme-insert-face-marker)
 106   (make-local-variable 'custom-theme-insert-variable-marker)
 107   (make-local-variable 'custom-theme--listed-faces)
 108   (when (called-interactively-p 'interactive)
 109     (unless (y-or-n-p "Include basic face customizations in this theme? ")
 110       (setq custom-theme--listed-faces nil)))
 111
 112   (if (eq theme 'user)
 113       (widget-insert "This buffer contains all the Custom settings you have made.
 114 You can convert them into a new custom theme, and optionally
 115 remove them from your saved Custom file.\n\n"))
 116
 117   (widget-create 'push-button
 118                  :tag " Visit Theme "
 119                  :help-echo "Insert the settings of a pre-defined theme."
 120                  :action (lambda (_widget &optional _event)
 121                            (call-interactively 'custom-theme-visit-theme)))
 122   (widget-insert "  ")
 123   (widget-create 'push-button
 124                  :tag " Merge Theme "
 125                  :help-echo "Merge in the settings of a pre-defined theme."
 126                  :action (lambda (_widget &optional _event)
 127                            (call-interactively 'custom-theme-merge-theme)))
 128   (widget-insert "  ")
 129   (widget-create 'push-button
 130                  :tag " Revert "
 131                  :help-echo "Revert this buffer to its original state."
 132                  :action (lambda (&rest ignored) (revert-buffer)))
 133
 134   (widget-insert "\n\nTheme name : ")
 135   (setq custom-theme-name
 136         (widget-create 'editable-field
 137                        :value (if (and theme (not (eq theme 'user)))
 138                                   (symbol-name theme)
 139                                 "")))
 140   (widget-insert "Description: ")
 141   (setq custom-theme-description
 142         (widget-create 'text
 143                        :value (format-time-string "Created %Y-%m-%d.")))
 144   (widget-create 'push-button
 145                  :notify (function custom-theme-write)
 146                  " Save Theme ")
 147   (when (eq theme 'user)
 148     (setq custom-theme--migrate-settings t)
 149     (widget-insert "  ")
 150     (widget-create 'checkbox
 151                    :value custom-theme--migrate-settings
 152                    :action (lambda (widget &optional event)
 153                              (when (widget-value widget)
 154                                (widget-toggle-action widget event)
 155                                (setq custom-theme--migrate-settings
 156                                      (widget-value widget)))))
 157     (widget-insert (propertize " Remove saved theme settings from Custom save file."
 158                                'face '(variable-pitch (:height 0.9)))))
 159
 160   (let (vars values faces face-specs)
 161
 162     ;; Load the theme settings.
 163     (when theme
 164       (unless (eq theme 'user)
 165         (load-theme theme nil t))
 166       (dolist (setting (get theme 'theme-settings))
 167         (if (eq (car setting) 'theme-value)
 168             (progn (push (nth 1 setting) vars)
 169                    (push (nth 3 setting) values))
 170           (push (nth 1 setting) faces)
 171           (push (nth 3 setting) face-specs))))
 172
 173     ;; If THEME is non-nil, insert all of that theme's faces.
 174     ;; Otherwise, insert those in `custom-theme--listed-faces'.
 175     (widget-insert "\n\n  Theme faces:\n ")
 176     (if theme
 177         (while faces
 178           (custom-theme-add-face-1 (pop faces) (pop face-specs)))
 179       (dolist (face custom-theme--listed-faces)
 180         (custom-theme-add-face-1 face nil)))
 181     (setq custom-theme-insert-face-marker (point-marker))
 182     (widget-insert " ")
 183     (widget-create 'push-button
 184                    :tag "Insert Additional Face"
 185                    :help-echo "Add another face to this theme."
 186                    :follow-link 'mouse-face
 187                    :button-face 'custom-link
 188                    :mouse-face 'highlight
 189                    :pressed-face 'highlight
 190                    :action (lambda (_widget &optional _event)
 191                              (call-interactively 'custom-theme-add-face)))
 192
 193     ;; If THEME is non-nil, insert all of that theme's variables.
 194     (widget-insert "\n\n  Theme variables:\n ")
 195     (if theme
 196         (while vars
 197           (if (eq (car vars) 'custom-enabled-themes)
 198               (progn (pop vars) (pop values))
 199             (custom-theme-add-var-1 (pop vars) (eval (pop values))))))
 200     (setq custom-theme-insert-variable-marker (point-marker))
 201     (widget-insert " ")
 202     (widget-create 'push-button
 203                    :tag "Insert Variable"
 204                    :help-echo "Add another variable to this theme."
 205                    :follow-link 'mouse-face
 206                    :button-face 'custom-link
 207                    :mouse-face 'highlight
 208                    :pressed-face 'highlight
 209                    :action (lambda (_widget &optional _event)
 210                              (call-interactively 'custom-theme-add-variable)))
 211     (widget-insert ?\n)
 212     (widget-setup)
 213     (goto-char (point-min))
 214     (message "")))
 215
 216 (defun custom-theme-revert (_ignore-auto noconfirm)
 217   "Revert the current *Custom Theme* buffer.
 218 This is the `revert-buffer-function' for `custom-new-theme-mode'."
 219   (when (or noconfirm (y-or-n-p "Discard current changes? "))
 220     (customize-create-theme custom-theme--save-name (current-buffer))))
 221
 222 ;;; Theme variables
 223
 224 (defun custom-theme-add-variable (var value)
 225   "Add a widget for VAR (a symbol) to the *New Custom Theme* buffer.
 226 VALUE should be a value to which to set the widget; when called
 227 interactively, this defaults to the current value of VAR."
 228   (interactive
 229    (let ((v (read-variable "Variable name: ")))
 230      (list v (symbol-value v))))
 231   (let ((entry (assq var custom-theme-variables)))
 232     (cond ((null entry)
 233            ;; If VAR is not yet in the buffer, add it.
 234            (save-excursion
 235              (goto-char custom-theme-insert-variable-marker)
 236              (custom-theme-add-var-1 var value)
 237              (move-marker custom-theme-insert-variable-marker (point))
 238              (widget-setup)))
 239           ;; Otherwise, alter that var widget.
 240           (t
 241            (widget-value-set (nth 1 entry) t)
 242            (let ((widget (nth 2 entry)))
 243              (widget-put widget :shown-value (list value))
 244              (custom-redraw widget))))))
 245
 246 (defun custom-theme-add-var-1 (symbol val)
 247   (widget-insert " ")
 248   (push (list symbol
 249               (prog1 (widget-create 'checkbox
 250                                     :value t
 251                                     :help-echo "Enable/disable this variable.")
 252                 (widget-insert " "))
 253               (widget-create 'custom-variable
 254                              :tag (custom-unlispify-tag-name symbol)
 255                              :value symbol
 256                              :shown-value (list val)
 257                              :notify 'ignore
 258                              :custom-level 0
 259                              :custom-state 'hidden
 260                              :custom-style 'simple))
 261         custom-theme-variables)
 262   (widget-insert " "))
 263
 264 ;;; Theme faces
 265
 266 (defun custom-theme-add-face (face &optional spec)
 267   "Add a widget for FACE (a symbol) to the *New Custom Theme* buffer.
 268 SPEC, if non-nil, should be a face spec to which to set the widget."
 269   (interactive (list (read-face-name "Face name" (face-at-point t))))
 270   (unless (or (facep face) spec)
 271     (error "`%s' has no face definition" face))
 272   (let ((entry (assq face custom-theme-faces)))
 273     (cond ((null entry)
 274            ;; If FACE is not yet in the buffer, add it.
 275            (save-excursion
 276              (goto-char custom-theme-insert-face-marker)
 277              (custom-theme-add-face-1 face spec)
 278              (move-marker custom-theme-insert-face-marker (point))
 279              (widget-setup)))
 280           ;; Otherwise, if SPEC is supplied, alter that face widget.
 281           (spec
 282            (widget-value-set (nth 1 entry) t)
 283            (let ((widget (nth 2 entry)))
 284              (widget-put widget :shown-value spec)
 285              (custom-redraw widget)))
 286           ((called-interactively-p 'interactive)
 287            (error "`%s' is already present" face)))))
 288
 289 (defun custom-theme-add-face-1 (symbol spec)
 290   (widget-insert " ")
 291   (push (list symbol
 292               (prog1
 293                   (widget-create 'checkbox
 294                                  :value t
 295                                  :help-echo "Enable/disable this face.")
 296                 (widget-insert " "))
 297               (widget-create 'custom-face
 298                              :tag (custom-unlispify-tag-name symbol)
 299                              :documentation-shown t
 300                              :value symbol
 301                              :custom-state 'hidden
 302                              :custom-style 'simple
 303                              :shown-value spec
 304                              :sample-indent 34))
 305         custom-theme-faces)
 306   (widget-insert " "))
 307
 308 ;;; Reading and writing
 309
 310 ;;;###autoload
 311 (defun custom-theme-visit-theme (theme)
 312   "Set up a Custom buffer to edit custom theme THEME."
 313   (interactive
 314    (list
 315     (intern (completing-read "Find custom theme: "
 316                              (mapcar 'symbol-name
 317                                      (custom-available-themes))))))
 318   (unless (custom-theme-name-valid-p theme)
 319     (error "No valid theme named `%s'" theme))
 320   (cond ((not (eq major-mode 'custom-new-theme-mode))
 321          (customize-create-theme theme))
 322         ((y-or-n-p "Discard current changes? ")
 323          (setq custom-theme--save-name theme)
 324          (custom-theme-revert nil t))))
 325
 326 (defun custom-theme-merge-theme (theme)
 327   "Merge the custom theme THEME's settings into the current buffer."
 328   (interactive
 329    (list
 330     (intern (completing-read "Merge custom theme: "
 331                              (mapcar 'symbol-name
 332                                      (custom-available-themes))))))
 333   (unless (eq theme 'user)
 334     (unless (custom-theme-name-valid-p theme)
 335       (error "Invalid theme name `%s'" theme))
 336     (load-theme theme nil t))
 337   (let ((settings (reverse (get theme 'theme-settings))))
 338     (dolist (setting settings)
 339       (let ((option (eq (car setting) 'theme-value))
 340             (name   (nth 1 setting))
 341             (value  (nth 3 setting)))
 342         (unless (and option
 343                      (memq name '(custom-enabled-themes
 344                                   custom-safe-themes)))
 345           (funcall (if option
 346                        'custom-theme-add-variable
 347                      'custom-theme-add-face)
 348                    name value)))))
 349   theme)
 350
 351 ;; From cus-edit.el
 352 (defvar custom-reset-standard-faces-list)
 353 (defvar custom-reset-standard-variables-list)
 354
 355 (defun custom-theme-write (&rest _ignore)
 356   "Write the current custom theme to its theme file."
 357   (interactive)
 358   (let* ((name (widget-value custom-theme-name))
 359          (doc  (widget-value custom-theme-description))
 360          (vars custom-theme-variables)
 361          (faces custom-theme-faces)
 362          filename)
 363     (when (string-equal name "")
 364       (setq name (read-from-minibuffer "Theme name: " (user-login-name)))
 365       (widget-value-set custom-theme-name name))
 366     (unless (custom-theme-name-valid-p (intern name))
 367       (error "Custom themes cannot be named `%s'" name))
 368
 369     (setq filename (expand-file-name (concat name "-theme.el")
 370                                      custom-theme-directory))
 371     (and (file-exists-p filename)
 372          (not (y-or-n-p (format "File %s exists.  Overwrite? " filename)))
 373          (error "Aborted"))
 374
 375     (with-temp-buffer
 376       (emacs-lisp-mode)
 377       (unless (file-directory-p custom-theme-directory)
 378         (make-directory (file-name-as-directory custom-theme-directory) t))
 379       (setq buffer-file-name filename)
 380       (erase-buffer)
 381       (insert "(deftheme " name)
 382       (if doc (insert "\n  \"" doc "\""))
 383       (insert  ")\n")
 384       (custom-theme-write-variables name (reverse vars))
 385       (custom-theme-write-faces name (reverse faces))
 386       (insert "\n(provide-theme '" name ")\n")
 387       (save-buffer))
 388     (message "Theme written to %s" filename)
 389
 390     (when custom-theme--migrate-settings
 391       ;; Remove these settings from the Custom file.
 392       (let ((custom-reset-standard-variables-list '(t))
 393             (custom-reset-standard-faces-list '(t)))
 394         (dolist (var vars)
 395           (when (and (not (eq (car var) 'custom-enabled-themes))
 396                      (widget-get (nth 1 var) :value))
 397             (widget-apply (nth 2 var) :custom-mark-to-reset-standard)))
 398         (dolist (face faces)
 399           (when (widget-get (nth 1 face) :value)
 400             (widget-apply (nth 2 face) :custom-mark-to-reset-standard)))
 401         (custom-save-all))
 402       (let ((custom-theme-load-path (list 'custom-theme-directory)))
 403         (load-theme (intern name))))))
 404
 405 (defun custom-theme-write-variables (theme vars)
 406   "Write a `custom-theme-set-variables' command for THEME.
 407 It includes all variables in list VARS."
 408   (when vars
 409     (let ((standard-output (current-buffer)))
 410       (princ "\n(custom-theme-set-variables\n")
 411       (princ " '")
 412       (princ theme)
 413       (princ "\n")
 414       (dolist (spec vars)
 415         (when (widget-get (nth 1 spec) :value)
 416           (let* ((symbol (nth 0 spec))
 417                  (widget (nth 2 spec))
 418                  (child (car-safe (widget-get widget :children)))
 419                  (value (if child
 420                             (widget-value child)
 421                           ;; Child is null if the widget is closed (hidden).
 422                           (car (widget-get widget :shown-value)))))
 423             (when (boundp symbol)
 424               (unless (bolp)
 425                 (princ "\n"))
 426               (princ " '(")
 427               (prin1 symbol)
 428               (princ " ")
 429               (prin1 (custom-quote value))
 430               (princ ")")))))
 431       (if (bolp)
 432           (princ " "))
 433       (princ ")")
 434       (unless (looking-at "\n")
 435         (princ "\n")))))
 436
 437 (defun custom-theme-write-faces (theme faces)
 438   "Write a `custom-theme-set-faces' command for THEME.
 439 It includes all faces in list FACES."
 440   (when faces
 441     (let ((standard-output (current-buffer)))
 442       (princ "\n(custom-theme-set-faces\n")
 443       (princ " '")
 444       (princ theme)
 445       (princ "\n")
 446       (dolist (spec faces)
 447         ;; Insert the face iff the checkbox widget is checked.
 448         (when (widget-get (nth 1 spec) :value)
 449           (let* ((symbol (nth 0 spec))
 450                  (widget (nth 2 spec))
 451                  (value
 452                   (cond
 453                    ((car-safe (widget-get widget :children))
 454                     (custom-face-widget-to-spec widget))
 455                    ;; Child is null if the widget is closed (hidden).
 456                    ((widget-get widget :shown-value))
 457                    (t (custom-face-get-current-spec symbol)))))
 458             (when (and (facep symbol) value)
 459               (princ (if (bolp) " '(" "\n '("))
 460               (prin1 symbol)
 461               (princ " ")
 462               (prin1 value)
 463               (princ ")")))))
 464       (if (bolp) (princ " "))
 465       (princ ")")
 466       (unless (looking-at "\n")
 467         (princ "\n")))))
 468
 469 \f
 470 ;;; Describing Custom themes.
 471
 472 ;;;###autoload
 473 (defun describe-theme (theme)
 474   "Display a description of the Custom theme THEME (a symbol)."
 475   (interactive
 476    (list
 477     (intern (completing-read "Describe custom theme: "
 478                              (mapcar 'symbol-name
 479                                      (custom-available-themes))))))
 480   (unless (custom-theme-name-valid-p theme)
 481     (error "Invalid theme name `%s'" theme))
 482   (help-setup-xref (list 'describe-theme theme)
 483                    (called-interactively-p 'interactive))
 484   (with-help-window (help-buffer)
 485     (with-current-buffer standard-output
 486       (describe-theme-1 theme))))
 487
 488 (defun describe-theme-1 (theme)
 489   (prin1 theme)
 490   (princ " is a custom theme")
 491   (let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
 492                          (custom-theme--load-path)
 493                          '("" "c")))
 494         doc)
 495     (when fn
 496       (princ (substitute-command-keys " in `"))
 497       (help-insert-xref-button (file-name-nondirectory fn)
 498                                'help-theme-def fn)
 499       (princ (substitute-command-keys "'")))
 500     (princ ".\n")
 501     (if (custom-theme-p theme)
 502         (progn
 503           (if (custom-theme-enabled-p theme)
 504               (princ "It is loaded and enabled.")
 505             (princ "It is loaded but disabled."))
 506           (setq doc (get theme 'theme-documentation)))
 507       (princ "It is not loaded.")
 508       ;; Attempt to grab the theme documentation
 509       (when fn
 510         (with-temp-buffer
 511           (insert-file-contents fn)
 512           (let ((sexp (let ((read-circle nil))
 513                         (condition-case nil
 514                             (read (current-buffer))
 515                           (end-of-file nil)))))
 516             (and sexp (listp sexp)
 517                  (eq (car sexp) 'deftheme)
 518                  (setq doc (nth 2 sexp)))))))
 519     (princ "\n\nDocumentation:\n")
 520     (princ (if (stringp doc)
 521                (substitute-command-keys doc)
 522              "No documentation available.")))
 523   (princ "\n\nYou can ")
 524   (help-insert-xref-button "customize" 'help-theme-edit theme)
 525   (princ " this theme."))
 526
 527 \f
 528 ;;; Theme chooser
 529
 530 (defvar custom--listed-themes)
 531
 532 (defcustom custom-theme-allow-multiple-selections nil
 533   "Whether to allow multi-selections in the *Custom Themes* buffer."
 534   :version "24.1"
 535   :type 'boolean
 536   :group 'custom-buffer)
 537
 538 (defvar custom-theme-choose-mode-map
 539   (let ((map (make-keymap)))
 540     (set-keymap-parent map (make-composed-keymap widget-keymap
 541                                                  special-mode-map))
 542     (suppress-keymap map)
 543     (define-key map "\C-x\C-s" 'custom-theme-save)
 544     (define-key map "n" 'widget-forward)
 545     (define-key map "p" 'widget-backward)
 546     (define-key map "?" 'custom-describe-theme)
 547     map)
 548   "Keymap for `custom-theme-choose-mode'.")
 549
 550 (define-derived-mode custom-theme-choose-mode special-mode "Themes"
 551   "Major mode for selecting Custom themes.
 552 Do not call this mode function yourself.  It is meant for internal use."
 553   (use-local-map custom-theme-choose-mode-map)
 554   (custom--initialize-widget-variables)
 555   (set (make-local-variable 'revert-buffer-function)
 556        (lambda (_ignore-auto noconfirm)
 557          (when (or noconfirm (y-or-n-p "Discard current choices? "))
 558            (customize-themes (current-buffer))))))
 559 (put 'custom-theme-choose-mode 'mode-class 'special)
 560
 561 ;;;###autoload
 562 (defun customize-themes (&optional buffer)
 563   "Display a selectable list of Custom themes.
 564 When called from Lisp, BUFFER should be the buffer to use; if
 565 omitted, a buffer named *Custom Themes* is used."
 566   (interactive)
 567   (switch-to-buffer (get-buffer-create (or buffer "*Custom Themes*")))
 568   (let ((inhibit-read-only t))
 569     (erase-buffer))
 570   (custom-theme-choose-mode)
 571   (set (make-local-variable 'custom--listed-themes) nil)
 572   (make-local-variable 'custom-theme-allow-multiple-selections)
 573   (and (null custom-theme-allow-multiple-selections)
 574        (> (length custom-enabled-themes) 1)
 575        (setq custom-theme-allow-multiple-selections t))
 576
 577   (widget-insert
 578    (substitute-command-keys
 579     "Type RET or click to enable/disable listed custom themes.
 580 Type \\[custom-describe-theme] to describe the theme at point.
 581 Theme files are named *-theme.el in `"))
 582   (widget-create 'link :value "custom-theme-load-path"
 583                  :button-face 'custom-link
 584                  :mouse-face 'highlight
 585                  :pressed-face 'highlight
 586                  :help-echo "Describe `custom-theme-load-path'."
 587                  :keymap custom-mode-link-map
 588                  :follow-link 'mouse-face
 589                  :action (lambda (_widget &rest _ignore)
 590                            (describe-variable 'custom-theme-load-path)))
 591   (widget-insert (substitute-command-keys "'.\n\n"))
 592
 593   ;; If the user has made customizations, display a warning and
 594   ;; provide buttons to disable or convert them.
 595   (let ((user-settings (get 'user 'theme-settings)))
 596     (unless (or (null user-settings)
 597                 (and (null (cdr user-settings))
 598                      (eq (caar user-settings) 'theme-value)
 599                      (eq (cadr (car user-settings)) 'custom-enabled-themes)))
 600       (widget-insert
 601        (propertize
 602         " Note: Your custom settings take precedence over theme settings.
 603        To migrate your settings into a theme, click "
 604         'face 'font-lock-warning-face))
 605       (widget-create 'link :value "here"
 606                      :button-face 'custom-link
 607                      :mouse-face 'highlight
 608                      :pressed-face 'highlight
 609                      :help-echo "Migrate."
 610                      :keymap custom-mode-link-map
 611                      :follow-link 'mouse-face
 612                      :action (lambda (_widget &rest _ignore)
 613                                (customize-create-theme 'user)))
 614       (widget-insert ".\n\n")))
 615
 616   (widget-create 'push-button
 617                  :tag " Save Theme Settings "
 618                  :help-echo "Save the selected themes for future sessions."
 619                  :action 'custom-theme-save)
 620   (widget-insert ?\n)
 621   (widget-create 'checkbox
 622                  :value custom-theme-allow-multiple-selections
 623                  :action 'custom-theme-selections-toggle)
 624   (widget-insert (propertize " Select more than one theme at a time"
 625                              'face '(variable-pitch (:height 0.9))))
 626
 627   (widget-insert "\n\nAvailable Custom Themes:\n")
 628   (let ((help-echo "mouse-2: Enable this theme for this session")
 629         widget)
 630     (dolist (theme (custom-available-themes))
 631       (setq widget (widget-create 'checkbox
 632                                   :value (custom-theme-enabled-p theme)
 633                                   :theme-name theme
 634                                   :help-echo help-echo
 635                                   :action 'custom-theme-checkbox-toggle))
 636       (push (cons theme widget) custom--listed-themes)
 637       (widget-create-child-and-convert widget 'push-button
 638                                        :button-face-get 'ignore
 639                                        :mouse-face-get 'ignore
 640                                        :value (format " %s" theme)
 641                                        :action 'widget-parent-action
 642                                        :help-echo help-echo)
 643       (widget-insert " -- "
 644                      (propertize (custom-theme-summary theme)
 645                                  'face 'shadow)
 646                      ?\n)))
 647   (goto-char (point-min))
 648   (widget-setup))
 649
 650 (defun custom-theme-summary (theme)
 651   "Return the summary line of THEME."
 652   (let (doc)
 653     (if (custom-theme-p theme)
 654         (setq doc (get theme 'theme-documentation))
 655       (let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
 656                              (custom-theme--load-path)
 657                              '("" "c"))))
 658         (when fn
 659           (with-temp-buffer
 660             (insert-file-contents fn)
 661             (let ((sexp (let ((read-circle nil))
 662                           (condition-case nil
 663                               (read (current-buffer))
 664                             (end-of-file nil)))))
 665               (and sexp (listp sexp)
 666                    (eq (car sexp) 'deftheme)
 667                    (setq doc (nth 2 sexp))))))))
 668     (cond ((null doc)
 669            "(no documentation available)")
 670           ((string-match ".*" doc)
 671            (match-string 0 doc))
 672           (t doc))))
 673
 674 (defun custom-theme-checkbox-toggle (widget &optional event)
 675   (let ((this-theme (widget-get widget :theme-name)))
 676     (if (widget-value widget)
 677         ;; Disable the theme.
 678         (progn
 679           (disable-theme this-theme)
 680           (widget-toggle-action widget event))
 681       ;; Enable the theme.
 682       (unless custom-theme-allow-multiple-selections
 683         ;; If only one theme is allowed, disable all other themes and
 684         ;; uncheck their boxes.
 685         (dolist (theme custom-enabled-themes)
 686           (and (not (eq theme this-theme))
 687                (assq theme custom--listed-themes)
 688                (disable-theme theme)))
 689         (dolist (theme custom--listed-themes)
 690           (unless (eq (car theme) this-theme)
 691             (widget-value-set (cdr theme) nil)
 692             (widget-apply (cdr theme) :notify (cdr theme) event))))
 693       (when (load-theme this-theme)
 694         (widget-toggle-action widget event)))
 695     ;; Mark `custom-enabled-themes' as "set for current session".
 696     (put 'custom-enabled-themes 'customized-value
 697          (list (custom-quote custom-enabled-themes)))))
 698
 699 (defun custom-describe-theme ()
 700   "Describe the Custom theme on the current line."
 701   (interactive)
 702   (let ((widget (widget-at (line-beginning-position))))
 703     (and widget
 704          (describe-theme (widget-get widget :theme-name)))))
 705
 706 (defun custom-theme-save (&rest _ignore)
 707   (interactive)
 708   (customize-save-variable 'custom-enabled-themes custom-enabled-themes)
 709   (message "Custom themes saved for future sessions."))
 710
 711 (defun custom-theme-selections-toggle (widget &optional event)
 712   (when (widget-value widget)
 713     ;; Deactivate multiple-selections.
 714     (if (< 1 (length (delq nil (mapcar (lambda (x) (widget-value (cdr x)))
 715                                        custom--listed-themes))))
 716         (error "More than one theme is currently selected")))
 717   (widget-toggle-action widget event)
 718   (setq custom-theme-allow-multiple-selections (widget-value widget)))
 719
 720 (provide 'cus-theme)
 721
 722 ;;; cus-theme.el ends here