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   (set (make-local-variable 'revert-buffer-function) 'custom-theme-revert)
  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 nil)
  65 (defvar custom-theme-insert-variable-marker nil)
  66 (defvar custom-theme-insert-face-marker nil)
  67
  68 (defvar custom-theme--listed-faces '(default fixed-pitch
  69   variable-pitch escape-glyph minibuffer-prompt highlight region
  70   shadow secondary-selection trailing-whitespace
  71   font-lock-builtin-face font-lock-comment-delimiter-face
  72   font-lock-comment-face font-lock-constant-face
  73   font-lock-doc-face font-lock-function-name-face
  74   font-lock-keyword-face font-lock-negation-char-face
  75   font-lock-preprocessor-face font-lock-regexp-grouping-backslash
  76   font-lock-regexp-grouping-construct font-lock-string-face
  77   font-lock-type-face font-lock-variable-name-face
  78   font-lock-warning-face button link link-visited fringe
  79   header-line tooltip mode-line mode-line-buffer-id
  80   mode-line-emphasis mode-line-highlight mode-line-inactive
  81   isearch isearch-fail lazy-highlight match next-error
  82   query-replace)
  83   "Faces listed by default in the *Custom Theme* buffer.")
  84
  85 ;;;###autoload
  86 (defun customize-create-theme (&optional buffer)
  87   "Create a custom theme.
  88 BUFFER, if non-nil, should be a buffer to use."
  89   (interactive)
  90   (switch-to-buffer (or buffer (generate-new-buffer "*Custom Theme*")))
  91   ;; Save current faces
  92   (let ((inhibit-read-only t))
  93     (erase-buffer))
  94   (custom-new-theme-mode)
  95   (make-local-variable 'custom-theme-name)
  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   (make-local-variable 'custom-theme-insert-face-marker)
 100   (make-local-variable 'custom-theme-insert-variable-marker)
 101   (make-local-variable 'custom-theme--listed-faces)
 102
 103   (widget-create 'push-button
 104                  :tag " Visit Theme "
 105                  :help-echo "Insert the settings of a pre-defined theme."
 106                  :action (lambda (widget &optional event)
 107                            (call-interactively 'custom-theme-visit-theme)))
 108   (widget-insert "  ")
 109   (widget-create 'push-button
 110                  :tag " Merge Theme "
 111                  :help-echo "Merge in the settings of a pre-defined theme."
 112                  :action (lambda (widget &optional event)
 113                            (call-interactively 'custom-theme-merge-theme)))
 114   (widget-insert "  ")
 115   (widget-create 'push-button :notify 'revert-buffer " Revert ")
 116
 117   (widget-insert "\n\nTheme name : ")
 118   (setq custom-theme-name
 119         (widget-create 'editable-field))
 120   (widget-insert "Description: ")
 121   (setq custom-theme-description
 122         (widget-create 'text
 123                        :value (format-time-string "Created %Y-%m-%d.")))
 124   (widget-insert "             ")
 125   (widget-create 'push-button
 126                  :notify (function custom-theme-write)
 127                  " Save Theme ")
 128   ;; Face widgets
 129   (widget-insert "\n\n  Theme faces:\n")
 130   (let (widget)
 131     (dolist (face custom-theme--listed-faces)
 132       (widget-insert "  ")
 133       (setq widget (widget-create 'custom-face
 134                                   :documentation-shown t
 135                                   :tag (custom-unlispify-tag-name face)
 136                                   :value face
 137                                   :display-style 'concise
 138                                   :custom-state 'hidden
 139                                   :sample-indent 34))
 140       (custom-magic-reset widget)
 141       (push (cons face widget) custom-theme-faces)))
 142   (insert " ")
 143   (setq custom-theme-insert-face-marker (point-marker))
 144   (insert " ")
 145   (widget-create 'push-button
 146                  :tag "Insert Additional Face"
 147                  :help-echo "Add another face to this theme."
 148                  :follow-link 'mouse-face
 149                  :button-face 'custom-link
 150                  :mouse-face 'highlight
 151                  :pressed-face 'highlight
 152                  :action (lambda (widget &optional event)
 153                            (call-interactively 'custom-theme-add-face)))
 154   (widget-insert "\n\n  Theme variables:\n ")
 155   (setq custom-theme-insert-variable-marker (point-marker))
 156   (widget-insert ?\s)
 157   (widget-create 'push-button
 158                  :tag "Insert Variable"
 159                  :help-echo "Add another variable to this theme."
 160                  :follow-link 'mouse-face
 161                  :button-face 'custom-link
 162                  :mouse-face 'highlight
 163                  :pressed-face 'highlight
 164                  :action (lambda (widget &optional event)
 165                            (call-interactively 'custom-theme-add-variable)))
 166   (widget-insert ?\n)
 167   (widget-setup)
 168   (goto-char (point-min))
 169   (message ""))
 170
 171 (defun custom-theme-revert (ignore-auto noconfirm)
 172   (when (or noconfirm (y-or-n-p "Discard current changes? "))
 173     (erase-buffer)
 174     (customize-create-theme (current-buffer))))
 175
 176 ;;; Theme variables
 177
 178 (defun custom-theme-add-variable (symbol)
 179   (interactive "vVariable name: ")
 180   (cond ((assq symbol custom-theme-variables)
 181          (message "%s is already in the theme" (symbol-name symbol)))
 182         ((not (boundp symbol))
 183          (message "%s is not defined as a variable" (symbol-name symbol)))
 184         ((eq symbol 'custom-enabled-themes)
 185          (message "Custom theme cannot contain `custom-enabled-themes'"))
 186         (t
 187          (save-excursion
 188            (goto-char custom-theme-insert-variable-marker)
 189            (widget-insert " ")
 190            (let ((widget (widget-create 'custom-variable
 191                                         :tag (custom-unlispify-tag-name symbol)
 192                                         :custom-level 0
 193                                         :action 'custom-theme-variable-action
 194                                         :custom-state 'unknown
 195                                         :value symbol)))
 196              (push (cons symbol widget) custom-theme-variables)
 197              (custom-magic-reset widget))
 198            (widget-insert " ")
 199            (move-marker custom-theme-insert-variable-marker (point))
 200            (widget-setup)))))
 201
 202 (defvar custom-theme-variable-menu
 203   `(("Reset to Current" custom-redraw
 204      (lambda (widget)
 205        (and (boundp (widget-value widget))
 206             (memq (widget-get widget :custom-state)
 207                   '(themed modified changed)))))
 208     ("Reset to Theme Value" custom-variable-reset-theme
 209      (lambda (widget)
 210        (let ((theme  (intern (widget-value custom-theme-name)))
 211              (symbol (widget-value widget))
 212              found)
 213          (and (custom-theme-p theme)
 214               (dolist (setting (get theme 'theme-settings) found)
 215                 (if (and (eq (cadr setting) symbol)
 216                          (eq (car  setting) 'theme-value))
 217                     (setq found t)))))))
 218     ("---" ignore ignore)
 219     ("Delete" custom-theme-delete-variable nil))
 220   "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
 221 See the documentation for `custom-variable'.")
 222
 223 (defun custom-theme-variable-action (widget &optional event)
 224   "Show the Custom Theme Mode menu for a `custom-variable' widget.
 225 Optional EVENT is the location for the menu."
 226   (let ((custom-variable-menu custom-theme-variable-menu))
 227     (custom-variable-action widget event)))
 228
 229 (defun custom-variable-reset-theme (widget)
 230   "Reset WIDGET to its value for the currently edited theme."
 231   (let ((theme  (intern (widget-value custom-theme-name)))
 232         (symbol (widget-value widget))
 233         found)
 234     (dolist (setting (get theme 'theme-settings))
 235       (if (and (eq (cadr setting) symbol)
 236                (eq (car  setting) 'theme-value))
 237           (setq found setting)))
 238     (widget-value-set (car (widget-get widget :children))
 239                       (nth 3 found)))
 240   (widget-put widget :custom-state 'themed)
 241   (custom-redraw-magic widget)
 242   (widget-setup))
 243
 244 (defun custom-theme-delete-variable (widget)
 245   (setq custom-theme-variables
 246         (assq-delete-all (widget-value widget) custom-theme-variables))
 247   (widget-delete widget))
 248
 249 ;;; Theme faces
 250
 251 (defun custom-theme-add-face (symbol)
 252   (interactive (list (read-face-name "Face name" nil nil)))
 253   (cond ((assq symbol custom-theme-faces)
 254          (message "%s is already in the theme" (symbol-name symbol)))
 255         ((not (facep symbol))
 256          (message "%s is not defined as a face" (symbol-name symbol)))
 257         (t
 258          (save-excursion
 259            (goto-char custom-theme-insert-face-marker)
 260            (widget-insert " ")
 261            (let ((widget (widget-create 'custom-face
 262                                         :tag (custom-unlispify-tag-name symbol)
 263                                         :custom-level 0
 264                                         :action 'custom-theme-face-action
 265                                         :custom-state 'unknown
 266                                         :display-style 'concise
 267                                         :sample-indent 34
 268                                         :value symbol)))
 269              (push (cons symbol widget) custom-theme-faces)
 270              (custom-magic-reset widget)
 271              (widget-insert " ")
 272              (move-marker custom-theme-insert-face-marker (point))
 273              (widget-setup))))))
 274
 275 (defvar custom-theme-face-menu
 276   `(("Reset to Theme Value" custom-face-reset-theme
 277      (lambda (widget)
 278        (let ((theme  (intern (widget-value custom-theme-name)))
 279              (symbol (widget-value widget))
 280              found)
 281          (and (custom-theme-p theme)
 282               (dolist (setting (get theme 'theme-settings) found)
 283                 (if (and (eq (cadr setting) symbol)
 284                          (eq (car  setting) 'theme-face))
 285                     (setq found t)))))))
 286     ("---" ignore ignore)
 287     ("Delete" custom-theme-delete-face nil))
 288   "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
 289 See the documentation for `custom-variable'.")
 290
 291 (defun custom-theme-face-action (widget &optional event)
 292   "Show the Custom Theme Mode menu for a `custom-face' widget.
 293 Optional EVENT is the location for the menu."
 294   (let ((custom-face-menu custom-theme-face-menu))
 295     (custom-face-action widget event)))
 296
 297 (defun custom-face-reset-theme (widget)
 298   "Reset WIDGET to its value for the currently edited theme."
 299   (let ((theme  (intern (widget-value custom-theme-name)))
 300         (symbol (widget-value widget))
 301         found)
 302     (dolist (setting (get theme 'theme-settings))
 303       (if (and (eq (cadr setting) symbol)
 304                (eq (car  setting) 'theme-face))
 305           (setq found setting)))
 306     (widget-value-set (car (widget-get widget :children))
 307                       (nth 3 found)))
 308   (widget-put widget :custom-state 'themed)
 309   (custom-redraw-magic widget)
 310   (widget-setup))
 311
 312 (defun custom-theme-delete-face (widget)
 313   (setq custom-theme-faces
 314         (assq-delete-all (widget-value widget) custom-theme-faces))
 315   (widget-delete widget))
 316
 317 ;;; Reading and writing
 318
 319 (defun custom-theme-visit-theme ()
 320   (interactive)
 321   (when (or (and (null custom-theme-variables)
 322                  (null custom-theme-faces))
 323             (and (y-or-n-p "Discard current changes? ")
 324                  (progn (revert-buffer) t)))
 325     (let ((theme (call-interactively 'custom-theme-merge-theme)))
 326       (unless (eq theme 'user)
 327         (widget-value-set custom-theme-name (symbol-name theme)))
 328       (widget-value-set custom-theme-description
 329                         (or (get theme 'theme-documentation)
 330                             (format-time-string "Created %Y-%m-%d.")))
 331       (widget-setup))))
 332
 333 (defun custom-theme-merge-theme (theme)
 334   (interactive "SCustom theme name: ")
 335   (unless (eq theme 'user)
 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   (let* ((name (widget-value custom-theme-name))
 347          (doc (widget-value custom-theme-description))
 348          (vars  custom-theme-variables)
 349          (faces custom-theme-faces)
 350          filename)
 351     (when (string-equal name "")
 352       (setq name (read-from-minibuffer "Theme name: " (user-login-name)))
 353       (widget-value-set custom-theme-name name))
 354     (cond ((or (string-equal name "")
 355                (string-equal name "user")
 356                (string-equal name "changed"))
 357            (error "Custom themes cannot be named `%s'" name))
 358           ((string-match " " name)
 359            (error "Custom theme names should not contain spaces")))
 360
 361     (setq filename (expand-file-name (concat name "-theme.el")
 362                                      custom-theme-directory))
 363     (and (file-exists-p filename)
 364          (not (y-or-n-p (format "File %s exists.  Overwrite? " filename)))
 365          (error "Aborted"))
 366
 367     (with-temp-buffer
 368       (emacs-lisp-mode)
 369       (unless (file-exists-p custom-theme-directory)
 370         (make-directory (file-name-as-directory custom-theme-directory) t))
 371       (setq buffer-file-name filename)
 372       (erase-buffer)
 373       (insert "(deftheme " name)
 374       (if doc (insert "\n  \"" doc "\""))
 375       (insert  ")\n")
 376       (custom-theme-write-variables name vars)
 377       (custom-theme-write-faces name faces)
 378       (insert "\n(provide-theme '" name ")\n")
 379       (save-buffer))
 380     (dolist (var vars)
 381       (when (widget-get (cdr var) :children)
 382         (widget-put (cdr var) :custom-state 'saved)
 383         (custom-redraw-magic (cdr var))))
 384     (dolist (face custom-theme-faces)
 385       (when (widget-get (cdr face) :children)
 386         (widget-put (cdr face) :custom-state 'saved)
 387         (custom-redraw-magic (cdr face))))))
 388
 389 (defun custom-theme-write-variables (theme vars)
 390   "Write a `custom-theme-set-variables' command for THEME.
 391 It includes all variables in list VARS."
 392   (when vars
 393     (let ((standard-output (current-buffer)))
 394       (princ "\n(custom-theme-set-variables\n")
 395       (princ " '")
 396       (princ theme)
 397       (princ "\n")
 398       (dolist (spec vars)
 399         (let* ((symbol (car spec))
 400                (child (car-safe (widget-get (cdr spec) :children)))
 401                (value (if child
 402                           (widget-value child)
 403                         ;; For hidden widgets, use the standard value
 404                         (get symbol 'standard-value))))
 405           (when (boundp symbol)
 406             (unless (bolp)
 407               (princ "\n"))
 408             (princ " '(")
 409             (prin1 symbol)
 410             (princ " ")
 411             (prin1 (custom-quote value))
 412             (princ ")"))))
 413       (if (bolp)
 414           (princ " "))
 415       (princ ")")
 416       (unless (looking-at "\n")
 417         (princ "\n")))))
 418
 419 (defun custom-theme-write-faces (theme faces)
 420   "Write a `custom-theme-set-faces' command for THEME.
 421 It includes all faces in list FACES."
 422   (when faces
 423     (let ((standard-output (current-buffer)))
 424       (princ "\n(custom-theme-set-faces\n")
 425       (princ " '")
 426       (princ theme)
 427       (princ "\n")
 428       (dolist (spec faces)
 429         (let* ((symbol (car spec))
 430                (widget (cdr spec))
 431                (child  (car-safe (widget-get widget :children)))
 432                (state  (if child
 433                            (widget-get widget :custom-state)
 434                          (custom-face-state symbol)))
 435                (value
 436                 (cond ((eq state 'standard)
 437                        nil) ; do nothing
 438                       (child
 439                        (custom-face-widget-to-spec widget))
 440                       (t
 441                        ;; Widget is closed (hidden), but the face has
 442                        ;; a non-standard value.  Try to extract that
 443                        ;; value and save it.
 444                        (custom-face-get-current-spec symbol)))))
 445           (when (and (facep symbol) value)
 446             (if (bolp)
 447                 (princ " '(")
 448               (princ "\n '("))
 449             (prin1 symbol)
 450             (princ " ")
 451             (prin1 value)
 452             (princ ")"))))
 453       (if (bolp)
 454           (princ " "))
 455       (princ ")")
 456       (unless (looking-at "\n")
 457         (princ "\n")))))
 458
 459 ;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
 460 ;;; cus-theme.el ends here