lisp/cus-theme.el

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