(set (make-local-variable 'widget-link-suffix) "")))
(put 'custom-new-theme-mode 'mode-class 'special)
-(defvar custom-theme-name)
-(defvar custom-theme-variables)
-(defvar custom-theme-faces)
+(defvar custom-theme-name nil)
+(defvar custom-theme-variables nil)
+(defvar custom-theme-faces nil)
(defvar custom-theme-description)
+(defvar custom-theme-insert-variable-marker)
+(defvar custom-theme-insert-face-marker)
;;;###autoload
(defun customize-create-theme ()
"Create a custom theme."
(interactive)
- (if (get-buffer "*New Custom Theme*")
- (kill-buffer "*New Custom Theme*"))
- (switch-to-buffer "*New Custom Theme*")
+ (switch-to-buffer (generate-new-buffer "*New Custom Theme*"))
(let ((inhibit-read-only t))
(erase-buffer))
(custom-new-theme-mode)
(make-local-variable 'custom-theme-variables)
(make-local-variable 'custom-theme-faces)
(make-local-variable 'custom-theme-description)
+ (make-local-variable 'custom-theme-insert-variable-marker)
+ (make-local-variable 'custom-theme-insert-face-marker)
(widget-insert "This buffer helps you write a custom theme elisp file.
This will help you share your customizations with other people.
-Just insert the names of all variables and faces you want the theme
-to include. Then clicking mouse-2 or pressing RET on the [Done] button
-will write a theme file that sets all these variables and faces to their
-current global values. It will write that file into the directory given
-by the variable `custom-theme-directory', usually \"~/.emacs.d/\".
+Insert the names of all variables and faces you want the theme to include.
+Invoke \"Save Theme\" to save the theme. The theme file will be saved to
+the directory " custom-theme-directory "\n\n")
+ (widget-create 'push-button
+ :tag "Visit Theme"
+ :help-echo "Insert the settings of a pre-defined theme."
+ :action (lambda (widget &optional event)
+ (call-interactively 'custom-theme-visit-theme)))
+ (widget-insert " ")
+ (widget-create 'push-button
+ :tag "Merge Theme"
+ :help-echo "Merge in the settings of a pre-defined theme."
+ :action (lambda (widget &optional event)
+ (call-interactively 'custom-theme-merge-theme)))
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (when (y-or-n-p "Discard current changes?")
+ (kill-buffer (current-buffer))
+ (customize-create-theme)))
+ "Reset Buffer")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (function custom-theme-write)
+ "Save Theme")
+ (widget-insert "\n")
-To undo all your edits to the buffer, use the [Reset] button.\n\n")
- (widget-insert "Theme name: ")
+ (widget-insert "\n\nTheme name: ")
(setq custom-theme-name
(widget-create 'editable-field
:size 10
(setq custom-theme-description
(widget-create 'text
:value (format-time-string "Created %Y-%m-%d.")))
- (widget-insert "\nVariables:\n\n")
- (setq custom-theme-variables
- (widget-create 'editable-list
- :entry-format "%i %d %v"
- 'variable))
- (widget-insert "\nFaces:\n\n")
- (setq custom-theme-faces
- (widget-create 'editable-list
- :entry-format "%i %d %v"
- 'face))
(widget-insert "\n")
(widget-create 'push-button
- :notify (function custom-theme-write)
- "Done")
- (widget-insert " ")
+ :tag "Insert Variable"
+ :help-echo "Add another variable to this theme."
+ :action (lambda (widget &optional event)
+ (call-interactively 'custom-theme-add-variable)))
+ (widget-insert "\n")
+ (setq custom-theme-insert-variable-marker (point-marker))
+ (widget-insert "\n")
(widget-create 'push-button
- :notify (lambda (&rest ignore)
- (customize-create-theme))
- "Reset")
- (widget-insert " ")
+ :tag "Insert Face"
+ :help-echo "Add another face to this theme."
+ :action (lambda (widget &optional event)
+ (call-interactively 'custom-theme-add-face)))
+ (widget-insert "\n")
+ (setq custom-theme-insert-face-marker (point-marker))
+ (widget-insert "\n")
(widget-create 'push-button
:notify (lambda (&rest ignore)
- (bury-buffer))
- "Bury Buffer")
+ (when (y-or-n-p "Discard current changes?")
+ (kill-buffer (current-buffer))
+ (customize-create-theme)))
+ "Reset Buffer")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (function custom-theme-write)
+ "Save Theme")
(widget-insert "\n")
+ (widget-setup)
+ (goto-char (point-min))
+ (message ""))
+
+;;; Theme variables
+
+(defun custom-theme-add-variable (symbol)
+ (interactive "vVariable name: ")
+ (save-excursion
+ (goto-char custom-theme-insert-variable-marker)
+ (if (assq symbol custom-theme-variables)
+ (message "%s is already in the theme" (symbol-name symbol))
+ (widget-insert "\n")
+ (let ((widget (widget-create 'custom-variable
+ :tag (custom-unlispify-tag-name symbol)
+ :custom-level 0
+ :action 'custom-theme-variable-action
+ :custom-state 'unknown
+ :value symbol)))
+ (push (cons symbol widget) custom-theme-variables)
+ (custom-magic-reset widget))
+ (widget-setup))))
+
+(defvar custom-theme-variable-menu
+ `(("Reset to Current" custom-redraw
+ (lambda (widget)
+ (and (boundp (widget-value widget))
+ (memq (widget-get widget :custom-state)
+ '(themed modified changed)))))
+ ("Reset to Theme Value" custom-variable-reset-theme
+ (lambda (widget)
+ (let ((theme (intern (widget-value custom-theme-name)))
+ (symbol (widget-value widget))
+ found)
+ (and (custom-theme-p theme)
+ (dolist (setting (get theme 'theme-settings) found)
+ (if (and (eq (cadr setting) symbol)
+ (eq (car setting) 'theme-value))
+ (setq found t)))))))
+ ("---" ignore ignore)
+ ("Delete" custom-theme-delete-variable nil))
+ "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
+See the documentation for `custom-variable'.")
+
+(defun custom-theme-variable-action (widget &optional event)
+ "Show the Custom Theme Mode menu for a `custom-variable' widget.
+Optional EVENT is the location for the menu."
+ (let ((custom-variable-menu custom-theme-variable-menu))
+ (custom-variable-action widget event)))
+
+(defun custom-variable-reset-theme (widget)
+ "Reset WIDGET to its value for the currently edited theme."
+ (let ((theme (intern (widget-value custom-theme-name)))
+ (symbol (widget-value widget))
+ found)
+ (dolist (setting (get theme 'theme-settings))
+ (if (and (eq (cadr setting) symbol)
+ (eq (car setting) 'theme-value))
+ (setq found setting)))
+ (widget-value-set (car (widget-get widget :children))
+ (nth 3 found)))
+ (widget-put widget :custom-state 'themed)
+ (custom-redraw-magic widget)
+ (widget-setup))
+
+(defun custom-theme-delete-variable (widget)
+ (setq custom-theme-variables
+ (assq-delete-all (widget-value widget) custom-theme-variables))
+ (widget-delete widget))
+
+;;; Theme faces
+
+(defun custom-theme-add-face (symbol)
+ (interactive (list (read-face-name "Face name" nil nil)))
+ (save-excursion
+ (goto-char custom-theme-insert-face-marker)
+ (if (assq symbol custom-theme-faces)
+ (message "%s is already in the theme" (symbol-name symbol))
+ (widget-insert "\n")
+ (let ((widget (widget-create 'custom-face
+ :tag (custom-unlispify-tag-name symbol)
+ :custom-level 0
+ :action 'custom-theme-face-action
+ :custom-state 'unknown
+ :value symbol)))
+ (push (cons symbol widget) custom-theme-faces)
+ (custom-magic-reset widget)
+ (widget-setup)))))
+
+(defvar custom-theme-face-menu
+ `(("Reset to Theme Value" custom-face-reset-theme
+ (lambda (widget)
+ (let ((theme (intern (widget-value custom-theme-name)))
+ (symbol (widget-value widget))
+ found)
+ (and (custom-theme-p theme)
+ (dolist (setting (get theme 'theme-settings) found)
+ (if (and (eq (cadr setting) symbol)
+ (eq (car setting) 'theme-face))
+ (setq found t)))))))
+ ("---" ignore ignore)
+ ("Delete" custom-theme-delete-face nil))
+ "Alist of actions for the `custom-variable' widget in Custom Theme Mode.
+See the documentation for `custom-variable'.")
+
+(defun custom-theme-face-action (widget &optional event)
+ "Show the Custom Theme Mode menu for a `custom-face' widget.
+Optional EVENT is the location for the menu."
+ (let ((custom-face-menu custom-theme-face-menu))
+ (custom-face-action widget event)))
+
+(defun custom-face-reset-theme (widget)
+ "Reset WIDGET to its value for the currently edited theme."
+ (let ((theme (intern (widget-value custom-theme-name)))
+ (symbol (widget-value widget))
+ found)
+ (dolist (setting (get theme 'theme-settings))
+ (if (and (eq (cadr setting) symbol)
+ (eq (car setting) 'theme-face))
+ (setq found setting)))
+ (widget-value-set (car (widget-get widget :children))
+ (nth 3 found)))
+ (widget-put widget :custom-state 'themed)
+ (custom-redraw-magic widget)
(widget-setup))
+(defun custom-theme-delete-face (widget)
+ (setq custom-theme-faces
+ (assq-delete-all (widget-value widget) custom-theme-faces))
+ (widget-delete widget))
+
+;;; Reading and writing
+
+(defun custom-theme-visit-theme ()
+ (interactive)
+ (when (or (null custom-theme-variables)
+ (if (y-or-n-p "Discard current changes?")
+ (progn (customize-create-theme) t)))
+ (let ((theme (call-interactively 'custom-theme-merge-theme)))
+ (unless (eq theme 'user)
+ (widget-value-set custom-theme-name (symbol-name theme)))
+ (widget-value-set custom-theme-description
+ (or (get theme 'theme-documentation)
+ (format-time-string "Created %Y-%m-%d.")))
+ (widget-setup))))
+
+(defun custom-theme-merge-theme (theme)
+ (interactive "SCustom theme name: ")
+ (unless (eq theme 'user)
+ (load-theme theme))
+ (let ((settings (get theme 'theme-settings)))
+ (dolist (setting settings)
+ (if (eq (car setting) 'theme-value)
+ (custom-theme-add-variable (cadr setting))
+ (custom-theme-add-face (cadr setting)))))
+ (disable-theme theme)
+ theme)
+
(defun custom-theme-write (&rest ignore)
- (let ((name (widget-value custom-theme-name))
- (doc (widget-value custom-theme-description))
- (variables (widget-value custom-theme-variables))
- (faces (widget-value custom-theme-faces)))
- (switch-to-buffer (concat name "-theme.el"))
- (emacs-lisp-mode)
- (unless (file-exists-p custom-theme-directory)
- (make-directory (file-name-as-directory custom-theme-directory) t))
- (setq default-directory custom-theme-directory)
- (setq buffer-file-name (expand-file-name (concat name "-theme.el")))
- (let ((inhibit-read-only t))
- (erase-buffer))
- (insert "(deftheme " name)
- (when doc
- (newline)
- (insert " \"" doc "\""))
- (insert ")\n")
- (custom-theme-write-variables name variables)
- (custom-theme-write-faces name faces)
- (insert "\n(provide-theme '" name ")\n")
- (save-buffer)))
+ (let* ((name (widget-value custom-theme-name))
+ (filename (expand-file-name (concat name "-theme.el")
+ custom-theme-directory))
+ (doc (widget-value custom-theme-description))
+ (vars custom-theme-variables)
+ (faces custom-theme-faces))
+ (cond ((or (string-equal name "")
+ (string-equal name "user")
+ (string-equal name "changed"))
+ (error "Custom themes cannot be named `%s'" name))
+ ((string-match " " name)
+ (error "Custom theme names should not contain spaces"))
+ ((if (file-exists-p filename)
+ (not (y-or-n-p
+ (format "File %s exists. Overwrite? " filename))))
+ (error "Aborted")))
+ (with-temp-buffer
+ (emacs-lisp-mode)
+ (unless (file-exists-p custom-theme-directory)
+ (make-directory (file-name-as-directory custom-theme-directory) t))
+ (setq buffer-file-name filename)
+ (erase-buffer)
+ (insert "(deftheme " name)
+ (if doc (insert "\n \"" doc "\""))
+ (insert ")\n")
+ (custom-theme-write-variables name vars)
+ (custom-theme-write-faces name faces)
+ (insert "\n(provide-theme '" name ")\n")
+ (save-buffer))
+ (dolist (var vars)
+ (widget-put (cdr var) :custom-state 'saved)
+ (custom-redraw-magic (cdr var)))
+ (dolist (face faces)
+ (widget-put (cdr face) :custom-state 'saved)
+ (custom-redraw-magic (cdr face)))))
(defun custom-theme-write-variables (theme vars)
"Write a `custom-theme-set-variables' command for THEME.
It includes all variables in list VARS."
- ;; Most code is stolen from `custom-save-variables'.
(when vars
(let ((standard-output (current-buffer)))
(princ "\n(custom-theme-set-variables\n")
(princ " '")
(princ theme)
(princ "\n")
- (mapc (lambda (symbol)
- (when (boundp symbol)
- (unless (bolp)
- (princ "\n"))
- (princ " '(")
- (prin1 symbol)
- (princ " ")
- (prin1 (custom-quote (symbol-value symbol)))
- (princ ")")))
- vars)
+ (mapc (lambda (spec)
+ (let* ((symbol (car spec))
+ (child (car-safe (widget-get (cdr spec) :children)))
+ (value (if child
+ (widget-value child)
+ ;; For hidden widgets, use the standard value
+ (get symbol 'standard-value))))
+ (when (boundp symbol)
+ (unless (bolp)
+ (princ "\n"))
+ (princ " '(")
+ (prin1 symbol)
+ (princ " ")
+ (prin1 (custom-quote value))
+ (princ ")"))))
+ vars)
(if (bolp)
(princ " "))
(princ ")")
(princ " '")
(princ theme)
(princ "\n")
- (mapc (lambda (symbol)
- (when (facep symbol)
- (unless (bolp)
- (princ "\n"))
- (princ " '(")
- (prin1 symbol)
- (princ " ")
- (prin1 (list (append '(t)
- (custom-face-attributes-get
- 'font-lock-comment-face nil))))
- (princ ")")))
- faces)
+ (mapc (lambda (spec)
+ (let* ((symbol (car spec))
+ (child (car-safe (widget-get (cdr spec) :children)))
+ (value (if child (widget-value child))))
+ (when (and (facep symbol) child)
+ (unless (bolp)
+ (princ "\n"))
+ (princ " '(")
+ (prin1 symbol)
+ (princ " ")
+ (prin1 value)
+ (princ ")"))))
+ faces)
(if (bolp)
(princ " "))
(princ ")")
projects / emacs.git / commitdiff