lisp/cus-theme.el

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