code.delx.au - gnu-emacs/blob - lisp/cus-theme.el

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