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