lisp/cus-theme.el

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