lisp/cus-theme.el

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