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 Free Software Foundation, Inc.
   5 ;;
   6 ;; Author: Alex Schroeder <alex@gnu.org>
   7 ;; Maintainer: FSF
   8 ;; Keywords: help, faces
   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, or (at your option)
  15 ;; 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; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Code:
  28
  29 (require 'widget)
  30 (require 'cus-edit)
  31
  32 (eval-when-compile
  33   (require 'wid-edit))
  34
  35 (defvar custom-new-theme-mode-map
  36   (let ((map (make-keymap)))
  37     (set-keymap-parent map widget-keymap)
  38     (suppress-keymap map)
  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 "New-Theme"
  45   "Major mode for the buffer created by `customize-create-theme'.
  46 Do not call this mode function yourself.  It is only meant for internal
  47 use by `customize-create-theme'."
  48   (use-local-map custom-new-theme-mode-map)
  49   (define-key custom-new-theme-mode-map [mouse-1] 'widget-move-and-invoke)
  50   (set (make-local-variable 'widget-documentation-face) 'custom-documentation)
  51   (set (make-local-variable 'widget-button-face) custom-button)
  52   (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed)
  53   (set (make-local-variable 'widget-mouse-face) custom-button-mouse)
  54   (when custom-raised-buttons
  55     (set (make-local-variable 'widget-push-button-prefix) "")
  56     (set (make-local-variable 'widget-push-button-suffix) "")
  57     (set (make-local-variable 'widget-link-prefix) "")
  58     (set (make-local-variable 'widget-link-suffix) "")))
  59 (put 'custom-new-theme-mode 'mode-class 'special)
  60
  61 (defvar custom-theme-name nil)
  62 (defvar custom-theme-variables nil)
  63 (defvar custom-theme-faces nil)
  64 (defvar custom-theme-description)
  65 (defvar custom-theme-insert-variable-marker)
  66 (defvar custom-theme-insert-face-marker)
  67
  68 ;;;###autoload
  69 (defun customize-create-theme ()
  70   "Create a custom theme."
  71   (interactive)
  72   (switch-to-buffer (generate-new-buffer "*New Custom Theme*"))
  73   (let ((inhibit-read-only t))
  74     (erase-buffer))
  75   (custom-new-theme-mode)
  76   (make-local-variable 'custom-theme-name)
  77   (make-local-variable 'custom-theme-variables)
  78   (make-local-variable 'custom-theme-faces)
  79   (make-local-variable 'custom-theme-description)
  80   (make-local-variable 'custom-theme-insert-variable-marker)
  81   (make-local-variable 'custom-theme-insert-face-marker)
  82   (widget-insert "This buffer helps you write a custom theme elisp file.
  83 This will help you share your customizations with other people.
  84
  85 Insert the names of all variables and faces you want the theme to include.
  86 Invoke \"Save Theme\" to save the theme.  The theme file will be saved to
  87 the directory " custom-theme-directory "\n\n")
  88   (widget-create 'push-button
  89                  :tag "Visit Theme"
  90                  :help-echo "Insert the settings of a pre-defined theme."
  91                  :action (lambda (widget &optional event)
  92                            (call-interactively 'custom-theme-visit-theme)))
  93   (widget-insert "  ")
  94   (widget-create 'push-button
  95                  :tag "Merge Theme"
  96                  :help-echo "Merge in the settings of a pre-defined theme."
  97                  :action (lambda (widget &optional event)
  98                            (call-interactively 'custom-theme-merge-theme)))
  99   (widget-insert "  ")
 100   (widget-create 'push-button
 101                  :notify (lambda (&rest ignore)
 102                            (when (y-or-n-p "Discard current changes? ")
 103                              (kill-buffer (current-buffer))
 104                              (customize-create-theme)))
 105                  "Reset Buffer")
 106   (widget-insert "  ")
 107   (widget-create 'push-button
 108                  :notify (function custom-theme-write)
 109                  "Save Theme")
 110   (widget-insert "\n")
 111
 112   (widget-insert "\n\nTheme name: ")
 113   (setq custom-theme-name
 114         (widget-create 'editable-field
 115                        :size 10
 116                        user-login-name))
 117   (widget-insert "\n\nDocumentation:\n")
 118   (setq custom-theme-description
 119         (widget-create 'text
 120                        :value (format-time-string "Created %Y-%m-%d.")))
 121   (widget-insert "\n")
 122   (widget-create 'push-button
 123                  :tag "Insert Variable"
 124                  :help-echo "Add another variable to this theme."
 125                  :action (lambda (widget &optional event)
 126                            (call-interactively 'custom-theme-add-variable)))
 127   (widget-insert "\n")
 128   (setq custom-theme-insert-variable-marker (point-marker))
 129   (widget-insert "\n")
 130   (widget-create 'push-button
 131                  :tag "Insert Face"
 132                  :help-echo "Add another face to this theme."
 133                  :action (lambda (widget &optional event)
 134                            (call-interactively 'custom-theme-add-face)))
 135   (widget-insert "\n")
 136   (setq custom-theme-insert-face-marker (point-marker))
 137   (widget-insert "\n")
 138   (widget-create 'push-button
 139                  :notify (lambda (&rest ignore)
 140                            (when (y-or-n-p "Discard current changes? ")
 141                              (kill-buffer (current-buffer))
 142                              (customize-create-theme)))
 143                  "Reset Buffer")
 144   (widget-insert "  ")
 145   (widget-create 'push-button
 146                  :notify (function custom-theme-write)
 147                  "Save Theme")
 148   (widget-insert "\n")
 149   (widget-setup)
 150   (goto-char (point-min))
 151   (message ""))
 152
 153 ;;; Theme variables
 154
 155 (defun custom-theme-add-variable (symbol)
 156   (interactive "vVariable name: ")
 157   (cond ((assq symbol custom-theme-variables)
 158          (message "%s is already in the theme" (symbol-name symbol)))
 159         ((not (boundp symbol))
 160          (message "%s is not defined as a variable" (symbol-name symbol)))
 161         ((eq symbol 'custom-enabled-themes)
 162          (message "Custom theme cannot contain `custom-enabled-themes'"))
 163         (t
 164          (save-excursion
 165            (goto-char custom-theme-insert-variable-marker)
 166            (widget-insert "\n")
 167            (let ((widget (widget-create 'custom-variable
 168                                         :tag (custom-unlispify-tag-name symbol)
 169                                         :custom-level 0
 170                                         :action 'custom-theme-variable-action
 171                                         :custom-state 'unknown
 172                                         :value symbol)))
 173              (push (cons symbol widget) custom-theme-variables)
 174              (custom-magic-reset widget))
 175            (widget-setup)))))
 176
 177 (defvar custom-theme-variable-menu
 178   `(("Reset to Current" custom-redraw
 179      (lambda (widget)
 180        (and (boundp (widget-value widget))
 181             (memq (widget-get widget :custom-state)
 182                   '(themed modified changed)))))
 183     ("Reset to Theme Value" custom-variable-reset-theme
 184      (lambda (widget)
 185        (let ((theme  (intern (widget-value custom-theme-name)))
 186              (symbol (widget-value widget))
 187              found)
 188          (and (custom-theme-p theme)
 189               (dolist (setting (get theme 'theme-settings) found)
 190                 (if (and (eq (cadr setting) symbol)
 191                          (eq (car  setting) 'theme-value))
 192                     (setq found t)))))))
 193     ("---" ignore ignore)
 194     ("Delete" custom-theme-delete-variable nil))
 195   "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
 196 See the documentation for `custom-variable'.")
 197
 198 (defun custom-theme-variable-action (widget &optional event)
 199   "Show the Custom Theme Mode menu for a `custom-variable' widget.
 200 Optional EVENT is the location for the menu."
 201   (let ((custom-variable-menu custom-theme-variable-menu))
 202     (custom-variable-action widget event)))
 203
 204 (defun custom-variable-reset-theme (widget)
 205   "Reset WIDGET to its value for the currently edited theme."
 206   (let ((theme  (intern (widget-value custom-theme-name)))
 207         (symbol (widget-value widget))
 208         found)
 209     (dolist (setting (get theme 'theme-settings))
 210       (if (and (eq (cadr setting) symbol)
 211                (eq (car  setting) 'theme-value))
 212           (setq found setting)))
 213     (widget-value-set (car (widget-get widget :children))
 214                       (nth 3 found)))
 215   (widget-put widget :custom-state 'themed)
 216   (custom-redraw-magic widget)
 217   (widget-setup))
 218
 219 (defun custom-theme-delete-variable (widget)
 220   (setq custom-theme-variables
 221         (assq-delete-all (widget-value widget) custom-theme-variables))
 222   (widget-delete widget))
 223
 224 ;;; Theme faces
 225
 226 (defun custom-theme-add-face (symbol)
 227   (interactive (list (read-face-name "Face name" nil nil)))
 228   (cond ((assq symbol custom-theme-faces)
 229          (message "%s is already in the theme" (symbol-name symbol)))
 230         ((not (facep symbol))
 231          (message "%s is not defined as a face" (symbol-name symbol)))
 232         (t
 233          (save-excursion
 234            (goto-char custom-theme-insert-face-marker)
 235            (widget-insert "\n")
 236            (let ((widget (widget-create 'custom-face
 237                                         :tag (custom-unlispify-tag-name symbol)
 238                                         :custom-level 0
 239                                         :action 'custom-theme-face-action
 240                                         :custom-state 'unknown
 241                                         :value symbol)))
 242              (push (cons symbol widget) custom-theme-faces)
 243              (custom-magic-reset widget)
 244              (widget-setup))))))
 245
 246 (defvar custom-theme-face-menu
 247   `(("Reset to Theme Value" custom-face-reset-theme
 248      (lambda (widget)
 249        (let ((theme  (intern (widget-value custom-theme-name)))
 250              (symbol (widget-value widget))
 251              found)
 252          (and (custom-theme-p theme)
 253               (dolist (setting (get theme 'theme-settings) found)
 254                 (if (and (eq (cadr setting) symbol)
 255                          (eq (car  setting) 'theme-face))
 256                     (setq found t)))))))
 257     ("---" ignore ignore)
 258     ("Delete" custom-theme-delete-face nil))
 259   "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
 260 See the documentation for `custom-variable'.")
 261
 262 (defun custom-theme-face-action (widget &optional event)
 263   "Show the Custom Theme Mode menu for a `custom-face' widget.
 264 Optional EVENT is the location for the menu."
 265   (let ((custom-face-menu custom-theme-face-menu))
 266     (custom-face-action widget event)))
 267
 268 (defun custom-face-reset-theme (widget)
 269   "Reset WIDGET to its value for the currently edited theme."
 270   (let ((theme  (intern (widget-value custom-theme-name)))
 271         (symbol (widget-value widget))
 272         found)
 273     (dolist (setting (get theme 'theme-settings))
 274       (if (and (eq (cadr setting) symbol)
 275                (eq (car  setting) 'theme-face))
 276           (setq found setting)))
 277     (widget-value-set (car (widget-get widget :children))
 278                       (nth 3 found)))
 279   (widget-put widget :custom-state 'themed)
 280   (custom-redraw-magic widget)
 281   (widget-setup))
 282
 283 (defun custom-theme-delete-face (widget)
 284   (setq custom-theme-faces
 285         (assq-delete-all (widget-value widget) custom-theme-faces))
 286   (widget-delete widget))
 287
 288 ;;; Reading and writing
 289
 290 (defun custom-theme-visit-theme ()
 291   (interactive)
 292   (when (or (null custom-theme-variables)
 293             (if (y-or-n-p "Discard current changes? ")
 294                 (progn (customize-create-theme) t)))
 295     (let ((theme (call-interactively 'custom-theme-merge-theme)))
 296       (unless (eq theme 'user)
 297         (widget-value-set custom-theme-name (symbol-name theme)))
 298       (widget-value-set custom-theme-description
 299                         (or (get theme 'theme-documentation)
 300                             (format-time-string "Created %Y-%m-%d.")))
 301       (widget-setup))))
 302
 303 (defun custom-theme-merge-theme (theme)
 304   (interactive "SCustom theme name: ")
 305   (unless (eq theme 'user)
 306     (load-theme theme))
 307   (let ((settings (get theme 'theme-settings)))
 308     (dolist (setting settings)
 309       (if (eq (car setting) 'theme-value)
 310           (custom-theme-add-variable (cadr setting))
 311         (custom-theme-add-face (cadr setting)))))
 312   (disable-theme theme)
 313   theme)
 314
 315 (defun custom-theme-write (&rest ignore)
 316   (let* ((name (widget-value custom-theme-name))
 317          (filename (expand-file-name (concat name "-theme.el")
 318                                      custom-theme-directory))
 319          (doc (widget-value custom-theme-description))
 320          (vars custom-theme-variables)
 321          (faces custom-theme-faces))
 322     (cond ((or (string-equal name "")
 323               (string-equal name "user")
 324               (string-equal name "changed"))
 325            (error "Custom themes cannot be named `%s'" name))
 326           ((string-match " " name)
 327            (error "Custom theme names should not contain spaces"))
 328           ((if (file-exists-p filename)
 329                (not (y-or-n-p
 330                      (format "File %s exists.  Overwrite? " filename))))
 331            (error "Aborted")))
 332     (with-temp-buffer
 333       (emacs-lisp-mode)
 334       (unless (file-exists-p custom-theme-directory)
 335         (make-directory (file-name-as-directory custom-theme-directory) t))
 336       (setq buffer-file-name filename)
 337       (erase-buffer)
 338       (insert "(deftheme " name)
 339       (if doc (insert "\n  \"" doc "\""))
 340       (insert  ")\n")
 341       (custom-theme-write-variables name vars)
 342       (custom-theme-write-faces name faces)
 343       (insert "\n(provide-theme '" name ")\n")
 344       (save-buffer))
 345     (dolist (var vars)
 346       (widget-put (cdr var) :custom-state 'saved)
 347       (custom-redraw-magic (cdr var)))
 348     (dolist (face faces)
 349       (widget-put (cdr face) :custom-state 'saved)
 350       (custom-redraw-magic (cdr face)))))
 351
 352 (defun custom-theme-write-variables (theme vars)
 353   "Write a `custom-theme-set-variables' command for THEME.
 354 It includes all variables in list VARS."
 355   (when vars
 356     (let ((standard-output (current-buffer)))
 357       (princ "\n(custom-theme-set-variables\n")
 358       (princ " '")
 359       (princ theme)
 360       (princ "\n")
 361       (mapc (lambda (spec)
 362               (let* ((symbol (car spec))
 363                      (child (car-safe (widget-get (cdr spec) :children)))
 364                      (value (if child
 365                                 (widget-value child)
 366                               ;; For hidden widgets, use the standard value
 367                               (get symbol 'standard-value))))
 368                 (when (boundp symbol)
 369                   (unless (bolp)
 370                     (princ "\n"))
 371                   (princ " '(")
 372                   (prin1 symbol)
 373                   (princ " ")
 374                   (prin1 (custom-quote value))
 375                   (princ ")"))))
 376             vars)
 377       (if (bolp)
 378           (princ " "))
 379       (princ ")")
 380       (unless (looking-at "\n")
 381         (princ "\n")))))
 382
 383 (defun custom-theme-write-faces (theme faces)
 384   "Write a `custom-theme-set-faces' command for THEME.
 385 It includes all faces in list FACES."
 386   (when faces
 387     (let ((standard-output (current-buffer)))
 388       (princ "\n(custom-theme-set-faces\n")
 389       (princ " '")
 390       (princ theme)
 391       (princ "\n")
 392       (mapc (lambda (spec)
 393               (let* ((symbol (car spec))
 394                      (child (car-safe (widget-get (cdr spec) :children)))
 395                      (value (if child (widget-value child))))
 396                 (when (and (facep symbol) child)
 397                   (unless (bolp)
 398                     (princ "\n"))
 399                   (princ " '(")
 400                   (prin1 symbol)
 401                   (princ " ")
 402                   (prin1 value)
 403                   (princ ")"))))
 404             faces)
 405       (if (bolp)
 406           (princ " "))
 407       (princ ")")
 408       (unless (looking-at "\n")
 409         (princ "\n")))))
 410
 411 ;;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
 412 ;;; cus-theme.el ends here