mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-21 06:55:39 +00:00
ecf08f0621
dc4e6b1329; Update copyright years in more files64b3777631; Run set-copyright from admin.el8e1c56ae46; Add 2024 to copyright years # Conflicts: # doc/misc/modus-themes.org # doc/misc/texinfo.tex # etc/NEWS # etc/refcards/ru-refcard.tex # etc/themes/modus-operandi-theme.el # etc/themes/modus-themes.el # etc/themes/modus-vivendi-theme.el # lib/alloca.in.h # lib/binary-io.h # lib/c-ctype.h # lib/c-strcasecmp.c # lib/c-strncasecmp.c # lib/careadlinkat.c # lib/cloexec.c # lib/close-stream.c # lib/diffseq.h # lib/dup2.c # lib/filemode.h # lib/fpending.c # lib/fpending.h # lib/fsusage.c # lib/getgroups.c # lib/getloadavg.c # lib/gettext.h # lib/gettime.c # lib/gettimeofday.c # lib/group-member.c # lib/malloc.c # lib/md5-stream.c # lib/md5.c # lib/md5.h # lib/memmem.c # lib/memrchr.c # lib/nanosleep.c # lib/save-cwd.h # lib/sha1.c # lib/sig2str.c # lib/stdlib.in.h # lib/strtoimax.c # lib/strtol.c # lib/strtoll.c # lib/time_r.c # lib/xalloc-oversized.h # lisp/auth-source-pass.el # lisp/emacs-lisp/lisp-mnt.el # lisp/emacs-lisp/timer.el # lisp/info-look.el # lisp/jit-lock.el # lisp/loadhist.el # lisp/mail/rmail.el # lisp/net/ntlm.el # lisp/net/webjump.el # lisp/progmodes/asm-mode.el # lisp/progmodes/project.el # lisp/progmodes/sh-script.el # lisp/textmodes/flyspell.el # lisp/textmodes/reftex-toc.el # lisp/textmodes/reftex.el # lisp/textmodes/tex-mode.el # lisp/url/url-gw.el # m4/alloca.m4 # m4/clock_time.m4 # m4/d-type.m4 # m4/dirent_h.m4 # m4/dup2.m4 # m4/euidaccess.m4 # m4/fchmodat.m4 # m4/filemode.m4 # m4/fsusage.m4 # m4/getgroups.m4 # m4/getloadavg.m4 # m4/getrandom.m4 # m4/gettime.m4 # m4/gettimeofday.m4 # m4/gnulib-common.m4 # m4/group-member.m4 # m4/inttypes.m4 # m4/malloc.m4 # m4/manywarnings.m4 # m4/mempcpy.m4 # m4/memrchr.m4 # m4/mkostemp.m4 # m4/mktime.m4 # m4/nproc.m4 # m4/nstrftime.m4 # m4/pathmax.m4 # m4/pipe2.m4 # m4/pselect.m4 # m4/pthread_sigmask.m4 # m4/readlink.m4 # m4/realloc.m4 # m4/sig2str.m4 # m4/ssize_t.m4 # m4/stat-time.m4 # m4/stddef_h.m4 # m4/stdint.m4 # m4/stdio_h.m4 # m4/stdlib_h.m4 # m4/stpcpy.m4 # m4/strnlen.m4 # m4/strtoimax.m4 # m4/strtoll.m4 # m4/time_h.m4 # m4/timegm.m4 # m4/timer_time.m4 # m4/timespec.m4 # m4/unistd_h.m4 # m4/warnings.m4 # nt/configure.bat # nt/preprep.c # test/lisp/register-tests.el
744 lines
26 KiB
EmacsLisp
744 lines
26 KiB
EmacsLisp
;;; cus-theme.el --- custom theme creation user interface -*- lexical-binding: t -*-
|
||
|
||
;; Copyright (C) 2001-2024 Free Software Foundation, Inc.
|
||
|
||
;; Author: Alex Schroeder <alex@gnu.org>
|
||
;; Maintainer: emacs-devel@gnu.org
|
||
;; Keywords: help, faces
|
||
;; Package: emacs
|
||
|
||
;; This file is part of GNU Emacs.
|
||
|
||
;; GNU Emacs is free software: you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation, either version 3 of the License, or
|
||
;; (at your option) any later version.
|
||
|
||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;;; Code:
|
||
|
||
(require 'widget)
|
||
(require 'cus-edit)
|
||
|
||
(eval-when-compile
|
||
(require 'wid-edit))
|
||
|
||
(defvar-keymap custom-new-theme-mode-map
|
||
:doc "Keymap for `custom-new-theme-mode'."
|
||
:full t
|
||
:suppress t
|
||
:parent (make-composed-keymap widget-keymap special-mode-map)
|
||
"C-x C-s" #'custom-theme-write
|
||
"q" #'Custom-buffer-done
|
||
"n" #'widget-forward
|
||
"p" #'widget-backward)
|
||
|
||
(define-derived-mode custom-new-theme-mode nil "Custom-Theme"
|
||
"Major mode for editing Custom themes.
|
||
Do not call this mode function yourself. It is meant for internal use."
|
||
(use-local-map custom-new-theme-mode-map)
|
||
(custom--initialize-widget-variables)
|
||
(setq-local revert-buffer-function #'custom-theme-revert))
|
||
(put 'custom-new-theme-mode 'mode-class 'special)
|
||
|
||
(defvar custom-theme-name nil)
|
||
;; Each element has the form (VAR CHECKBOX-WIDGET VAR-WIDGET)
|
||
(defvar custom-theme-variables nil)
|
||
;; Each element has the form (FACE CHECKBOX-WIDGET FACE-WIDGET)
|
||
(defvar custom-theme-faces nil)
|
||
(defvar custom-theme-description nil)
|
||
(defvar custom-theme--migrate-settings nil)
|
||
(defvar custom-theme-insert-variable-marker nil)
|
||
(defvar custom-theme-insert-face-marker nil)
|
||
|
||
(defvar custom-theme--listed-faces '(default cursor fixed-pitch
|
||
variable-pitch escape-glyph homoglyph
|
||
minibuffer-prompt highlight region
|
||
shadow secondary-selection trailing-whitespace
|
||
font-lock-bracket-face font-lock-builtin-face
|
||
font-lock-comment-delimiter-face font-lock-comment-face
|
||
font-lock-constant-face font-lock-delimiter-face
|
||
font-lock-doc-face font-lock-doc-markup-face
|
||
font-lock-escape-face font-lock-function-call-face
|
||
font-lock-function-name-face
|
||
font-lock-keyword-face font-lock-negation-char-face
|
||
font-lock-number-face font-lock-misc-punctuation-face
|
||
font-lock-operator-face font-lock-preprocessor-face
|
||
font-lock-property-name-face font-lock-property-use-face
|
||
font-lock-punctuation-face
|
||
font-lock-regexp-grouping-backslash font-lock-regexp-grouping-construct
|
||
font-lock-string-face font-lock-type-face font-lock-variable-name-face
|
||
font-lock-variable-use-face
|
||
font-lock-warning-face button link link-visited fringe
|
||
header-line tooltip mode-line mode-line-buffer-id
|
||
mode-line-emphasis mode-line-highlight mode-line-inactive
|
||
isearch isearch-fail lazy-highlight match next-error
|
||
query-replace)
|
||
"Faces listed by default in the *Custom Theme* buffer.")
|
||
|
||
(defvar custom-theme--save-name)
|
||
|
||
;;;###autoload
|
||
(defun customize-create-theme (&optional theme buffer)
|
||
"Create or edit a custom theme.
|
||
THEME, if non-nil, should be an existing theme to edit. If THEME
|
||
is `user', the resulting *Custom Theme* buffer also contains a
|
||
checkbox for removing the theme settings specified in the buffer
|
||
from the Custom save file.
|
||
BUFFER, if non-nil, should be a buffer to use; the default is
|
||
named *Custom Theme*."
|
||
(interactive)
|
||
(switch-to-buffer (get-buffer-create (or buffer "*Custom Theme*")))
|
||
(let ((inhibit-read-only t))
|
||
(erase-buffer)
|
||
(delete-all-overlays))
|
||
(custom-new-theme-mode)
|
||
(make-local-variable 'custom-theme-name)
|
||
(setq-local custom-theme--save-name theme)
|
||
(setq-local custom-theme-faces nil)
|
||
(setq-local custom-theme-variables nil)
|
||
(setq-local custom-theme-description "")
|
||
(setq-local custom-theme--migrate-settings nil)
|
||
(make-local-variable 'custom-theme-insert-face-marker)
|
||
(make-local-variable 'custom-theme-insert-variable-marker)
|
||
(make-local-variable 'custom-theme--listed-faces)
|
||
(when (called-interactively-p 'interactive)
|
||
(unless (y-or-n-p "Include basic face customizations in this theme? ")
|
||
(setq custom-theme--listed-faces nil)))
|
||
|
||
(let (vars values faces face-specs)
|
||
|
||
;; Load the theme settings.
|
||
(when theme
|
||
(if (eq theme 'user)
|
||
(widget-insert "This buffer contains all the Custom settings you have made.
|
||
You can convert them into a new custom theme, and optionally
|
||
remove them from your saved Custom file.\n\n")
|
||
(load-theme theme nil t))
|
||
|
||
(dolist (setting (get theme 'theme-settings))
|
||
(if (eq (car setting) 'theme-value)
|
||
(progn (push (nth 1 setting) vars)
|
||
(push (nth 3 setting) values))
|
||
(push (nth 1 setting) faces)
|
||
(push (nth 3 setting) face-specs))))
|
||
|
||
(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
|
||
:tag " Revert "
|
||
:help-echo "Revert this buffer to its original state."
|
||
:action (lambda (&rest _ignored) (revert-buffer)))
|
||
|
||
(widget-insert "\n\nTheme name : ")
|
||
(setq custom-theme-name
|
||
(widget-create 'editable-field
|
||
:value (if (and theme (not (eq theme 'user)))
|
||
(symbol-name theme)
|
||
"")))
|
||
(widget-insert "Description: ")
|
||
(setq custom-theme-description
|
||
(widget-create 'text :format "%v"
|
||
:value (or (get theme 'theme-documentation)
|
||
(format-time-string "Created %Y-%m-%d."))))
|
||
(widget-create 'push-button
|
||
:notify #'custom-theme-write
|
||
" Save Theme ")
|
||
(when (eq theme 'user)
|
||
(setq custom-theme--migrate-settings t)
|
||
(widget-insert " ")
|
||
(widget-create 'checkbox
|
||
:value custom-theme--migrate-settings
|
||
:action (lambda (widget &optional event)
|
||
(when (widget-value widget)
|
||
(widget-toggle-action widget event)
|
||
(setq custom-theme--migrate-settings
|
||
(widget-value widget)))))
|
||
(widget-insert (propertize " Remove saved theme settings from Custom save file."
|
||
'face '(variable-pitch (:height 0.9)))))
|
||
|
||
;; If THEME is non-nil, insert all of that theme's faces.
|
||
;; Otherwise, insert those in `custom-theme--listed-faces'.
|
||
(widget-insert "\n\n Theme faces:\n ")
|
||
(if theme
|
||
(while faces
|
||
(custom-theme-add-face-1 (pop faces) (pop face-specs)))
|
||
(dolist (face custom-theme--listed-faces)
|
||
(custom-theme-add-face-1 face nil)))
|
||
(setq custom-theme-insert-face-marker (point-marker))
|
||
(widget-insert " ")
|
||
(widget-create 'push-button
|
||
:tag "Insert Additional Face"
|
||
:help-echo "Add another face to this theme."
|
||
:follow-link 'mouse-face
|
||
:button-face 'custom-link
|
||
:mouse-face 'highlight
|
||
:pressed-face 'highlight
|
||
:action (lambda (_widget &optional _event)
|
||
(call-interactively #'custom-theme-add-face)))
|
||
|
||
;; If THEME is non-nil, insert all of that theme's variables.
|
||
(widget-insert "\n\n Theme variables:\n ")
|
||
(if theme
|
||
(while vars
|
||
(if (eq (car vars) 'custom-enabled-themes)
|
||
(progn (pop vars) (pop values))
|
||
(custom-theme-add-var-1 (pop vars) (eval (pop values))))))
|
||
(setq custom-theme-insert-variable-marker (point-marker))
|
||
(widget-insert " ")
|
||
(widget-create 'push-button
|
||
:tag "Insert Variable"
|
||
:help-echo "Add another variable to this theme."
|
||
:follow-link 'mouse-face
|
||
:button-face 'custom-link
|
||
:mouse-face 'highlight
|
||
:pressed-face 'highlight
|
||
:action (lambda (_widget &optional _event)
|
||
(call-interactively #'custom-theme-add-variable)))
|
||
(widget-insert ?\n)
|
||
(widget-setup)
|
||
(goto-char (point-min))
|
||
(message "")))
|
||
|
||
(defun custom-theme-revert (_ignore-auto noconfirm)
|
||
"Revert the current *Custom Theme* buffer.
|
||
This is the `revert-buffer-function' for `custom-new-theme-mode'."
|
||
(when (or noconfirm (y-or-n-p "Discard current changes? "))
|
||
(customize-create-theme custom-theme--save-name (current-buffer))))
|
||
|
||
;;; Theme variables
|
||
|
||
(defun custom-theme-add-variable (var value)
|
||
"Add a widget for VAR (a symbol) to the *New Custom Theme* buffer.
|
||
VALUE should be a value to which to set the widget; when called
|
||
interactively, this defaults to the current value of VAR."
|
||
(interactive
|
||
(let ((v (read-variable "Variable name: ")))
|
||
(list v (symbol-value v))))
|
||
(let ((entry (assq var custom-theme-variables)))
|
||
(cond ((null entry)
|
||
;; If VAR is not yet in the buffer, add it.
|
||
(save-excursion
|
||
(goto-char custom-theme-insert-variable-marker)
|
||
(custom-theme-add-var-1 var value)
|
||
(move-marker custom-theme-insert-variable-marker (point))
|
||
(widget-setup)))
|
||
;; Otherwise, alter that var widget.
|
||
(t
|
||
(widget-value-set (nth 1 entry) t)
|
||
(let ((widget (nth 2 entry)))
|
||
(widget-put widget :shown-value (list value))
|
||
(custom-redraw widget))))))
|
||
|
||
(defun custom-theme-add-var-1 (symbol val)
|
||
(widget-insert " ")
|
||
(push (list symbol
|
||
(prog1 (widget-create 'checkbox
|
||
:value t
|
||
:help-echo "Enable/disable this variable.")
|
||
(widget-insert " "))
|
||
(widget-create 'custom-variable
|
||
:tag (custom-unlispify-tag-name symbol)
|
||
:value symbol
|
||
:shown-value (list val)
|
||
:notify #'ignore
|
||
:custom-level 0
|
||
:custom-state 'hidden
|
||
:custom-style 'simple))
|
||
custom-theme-variables)
|
||
(widget-insert " "))
|
||
|
||
;;; Theme faces
|
||
|
||
(defun custom-theme-add-face (face &optional spec)
|
||
"Add a widget for FACE (a symbol) to the *New Custom Theme* buffer.
|
||
SPEC, if non-nil, should be a face spec to which to set the widget."
|
||
(interactive (list (read-face-name "Face name" (face-at-point t))))
|
||
(unless (or (facep face) spec)
|
||
(error "`%s' has no face definition" face))
|
||
(let ((entry (assq face custom-theme-faces)))
|
||
(cond ((null entry)
|
||
;; If FACE is not yet in the buffer, add it.
|
||
(save-excursion
|
||
(goto-char custom-theme-insert-face-marker)
|
||
(custom-theme-add-face-1 face spec)
|
||
(move-marker custom-theme-insert-face-marker (point))
|
||
(widget-setup)))
|
||
;; Otherwise, if SPEC is supplied, alter that face widget.
|
||
(spec
|
||
(widget-value-set (nth 1 entry) t)
|
||
(let ((widget (nth 2 entry)))
|
||
(widget-put widget :shown-value spec)
|
||
(custom-redraw widget)))
|
||
((called-interactively-p 'interactive)
|
||
(error "`%s' is already present" face)))))
|
||
|
||
(defun custom-theme-add-face-1 (symbol spec)
|
||
(widget-insert " ")
|
||
(push (list symbol
|
||
(prog1
|
||
(widget-create 'checkbox
|
||
:value t
|
||
:help-echo "Enable/disable this face.")
|
||
(widget-insert " "))
|
||
(widget-create 'custom-face
|
||
:tag (custom-unlispify-tag-name symbol)
|
||
:documentation-shown t
|
||
:value symbol
|
||
:custom-state 'hidden
|
||
:custom-style 'simple
|
||
:shown-value spec
|
||
:sample-indent 34))
|
||
custom-theme-faces)
|
||
(widget-insert " "))
|
||
|
||
;;; Reading and writing
|
||
|
||
;;;###autoload
|
||
(defun custom-theme-visit-theme (theme)
|
||
"Set up a Custom buffer to edit custom theme THEME."
|
||
(interactive
|
||
(list
|
||
(intern (completing-read "Find custom theme: "
|
||
(mapcar #'symbol-name
|
||
(custom-available-themes))))))
|
||
(unless (custom-theme-name-valid-p theme)
|
||
(error "No valid theme named `%s'" theme))
|
||
(cond ((not (eq major-mode 'custom-new-theme-mode))
|
||
(customize-create-theme theme))
|
||
((y-or-n-p "Discard current changes? ")
|
||
(setq custom-theme--save-name theme)
|
||
(custom-theme-revert nil t))))
|
||
|
||
(defun custom-theme-merge-theme (theme)
|
||
"Merge the custom theme THEME's settings into the current buffer."
|
||
(interactive
|
||
(list
|
||
(intern (completing-read "Merge custom theme: "
|
||
(mapcar #'symbol-name
|
||
(custom-available-themes))))))
|
||
(unless (eq theme 'user)
|
||
(unless (custom-theme-name-valid-p theme)
|
||
(error "Invalid theme name `%s'" theme))
|
||
(load-theme theme nil t))
|
||
(let ((settings (reverse (get theme 'theme-settings))))
|
||
(dolist (setting settings)
|
||
(let ((option (eq (car setting) 'theme-value))
|
||
(name (nth 1 setting))
|
||
(value (nth 3 setting)))
|
||
(unless (and option
|
||
(memq name '(custom-enabled-themes
|
||
custom-safe-themes)))
|
||
(funcall (if option
|
||
#'custom-theme-add-variable
|
||
#'custom-theme-add-face)
|
||
name value)))))
|
||
theme)
|
||
|
||
;; From cus-edit.el
|
||
(defvar custom-reset-standard-faces-list)
|
||
(defvar custom-reset-standard-variables-list)
|
||
|
||
(defun custom-theme-write (&rest _ignore)
|
||
"Write the current custom theme to its theme file."
|
||
(interactive)
|
||
(let* ((name (widget-value custom-theme-name))
|
||
(doc (widget-value custom-theme-description))
|
||
(vars custom-theme-variables)
|
||
(faces custom-theme-faces)
|
||
filename)
|
||
(when (string-equal name "")
|
||
(setq name (read-from-minibuffer "Theme name: " (user-login-name)))
|
||
(widget-value-set custom-theme-name name))
|
||
(unless (custom-theme-name-valid-p (intern name))
|
||
(error "Custom themes cannot be named `%s'" name))
|
||
|
||
(setq filename (expand-file-name (concat name "-theme.el")
|
||
custom-theme-directory))
|
||
(and (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-directory-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 (reverse vars))
|
||
(custom-theme-write-faces name (reverse faces))
|
||
(insert "\n(provide-theme '" name ")\n")
|
||
(save-buffer))
|
||
(message "Theme written to %s" filename)
|
||
|
||
(when custom-theme--migrate-settings
|
||
;; Remove these settings from the Custom file.
|
||
(let ((custom-reset-standard-variables-list '(t))
|
||
(custom-reset-standard-faces-list '(t)))
|
||
(dolist (var vars)
|
||
(when (and (not (eq (car var) 'custom-enabled-themes))
|
||
(widget-get (nth 1 var) :value))
|
||
(widget-apply (nth 2 var) :custom-mark-to-reset-standard)))
|
||
(dolist (face faces)
|
||
(when (widget-get (nth 1 face) :value)
|
||
(widget-apply (nth 2 face) :custom-mark-to-reset-standard)))
|
||
(custom-save-all))
|
||
(let ((custom-theme-load-path (list 'custom-theme-directory)))
|
||
(load-theme (intern name))))))
|
||
|
||
(defun custom-theme-write-variables (theme vars)
|
||
"Write a `custom-theme-set-variables' command for THEME.
|
||
It includes all variables in list VARS."
|
||
(when vars
|
||
(let ((standard-output (current-buffer)))
|
||
(princ "\n(custom-theme-set-variables\n")
|
||
(princ " '")
|
||
(princ theme)
|
||
(princ "\n")
|
||
(dolist (spec vars)
|
||
(when (widget-get (nth 1 spec) :value)
|
||
(let* ((symbol (nth 0 spec))
|
||
(widget (nth 2 spec))
|
||
(child (car-safe (widget-get widget :children)))
|
||
(value (if child
|
||
(widget-value child)
|
||
;; Child is null if the widget is closed (hidden).
|
||
(car (widget-get widget :shown-value)))))
|
||
(unless (bolp)
|
||
(princ "\n"))
|
||
(princ " '(")
|
||
(prin1 symbol)
|
||
(princ " ")
|
||
(prin1 (custom-quote value))
|
||
(princ ")"))))
|
||
(if (bolp)
|
||
(princ " "))
|
||
(princ ")")
|
||
(when (/= (following-char) ?\n)
|
||
(princ "\n")))))
|
||
|
||
(defun custom-theme-write-faces (theme faces)
|
||
"Write a `custom-theme-set-faces' command for THEME.
|
||
It includes all faces in list FACES."
|
||
(when faces
|
||
(let ((standard-output (current-buffer)))
|
||
(princ "\n(custom-theme-set-faces\n")
|
||
(princ " '")
|
||
(princ theme)
|
||
(princ "\n")
|
||
(dolist (spec faces)
|
||
;; Insert the face iff the checkbox widget is checked.
|
||
(when (widget-get (nth 1 spec) :value)
|
||
(let* ((symbol (nth 0 spec))
|
||
(widget (nth 2 spec))
|
||
(value
|
||
(cond
|
||
((car-safe (widget-get widget :children))
|
||
(custom-face-widget-to-spec widget))
|
||
;; Child is null if the widget is closed (hidden).
|
||
((widget-get widget :shown-value))
|
||
(t (custom-face-get-current-spec symbol)))))
|
||
(when value
|
||
(princ (if (bolp) " '(" "\n '("))
|
||
(prin1 symbol)
|
||
(princ " ")
|
||
(prin1 value)
|
||
(princ ")")))))
|
||
(if (bolp) (princ " "))
|
||
(princ ")")
|
||
(when (/= (following-char) ?\n)
|
||
(princ "\n")))))
|
||
|
||
|
||
;;; Describing Custom themes.
|
||
|
||
;;;###autoload
|
||
(defun describe-theme (theme)
|
||
"Display a description of the Custom theme THEME (a symbol)."
|
||
(interactive
|
||
(list
|
||
(intern (completing-read "Describe custom theme: "
|
||
(mapcar #'symbol-name
|
||
(custom-available-themes))))))
|
||
(unless (custom-theme-name-valid-p theme)
|
||
(error "Invalid theme name `%s'" theme))
|
||
(help-setup-xref (list 'describe-theme theme)
|
||
(called-interactively-p 'interactive))
|
||
(with-help-window (help-buffer)
|
||
(with-current-buffer standard-output
|
||
(describe-theme-1 theme))))
|
||
|
||
(defun describe-theme-from-file (theme &optional file short)
|
||
"Describe THEME from its FILE without loading it.
|
||
|
||
If FILE is nil try to look in `custom-theme-load-path' for the
|
||
theme's file using the theme's name.
|
||
If SHORT is non-nil, show only the first line of thene's documentation."
|
||
(let ((file (or file
|
||
(locate-file (concat (symbol-name theme) "-theme.el")
|
||
(custom-theme--load-path)
|
||
'("" "c")))))
|
||
(with-temp-buffer
|
||
(insert-file-contents file)
|
||
(catch 'found
|
||
(let (sexp)
|
||
(while (setq sexp (let ((read-circle nil))
|
||
(condition-case nil
|
||
(read (current-buffer))
|
||
(end-of-file nil))))
|
||
(when (eq (car-safe sexp) 'deftheme)
|
||
(throw 'found (if short
|
||
(car (split-string (nth 2 sexp) "\n"))
|
||
(nth 2 sexp))))))))))
|
||
|
||
(defun describe-theme-1 (theme)
|
||
(prin1 theme)
|
||
(princ " is a custom theme")
|
||
(let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
|
||
(custom-theme--load-path)
|
||
'("" "c")))
|
||
doc)
|
||
(when fn
|
||
(princ (substitute-command-keys " in `"))
|
||
(help-insert-xref-button (file-name-nondirectory fn)
|
||
'help-theme-def fn)
|
||
(princ (substitute-quotes "'")))
|
||
(princ ".\n")
|
||
(if (custom-theme-p theme)
|
||
(progn
|
||
(if (custom-theme-enabled-p theme)
|
||
(princ "It is loaded and enabled.")
|
||
(princ "It is loaded but disabled."))
|
||
(setq doc (get theme 'theme-documentation)))
|
||
(princ "It is not loaded.")
|
||
;; Attempt to grab the theme documentation from file.
|
||
(when fn
|
||
(setq doc (describe-theme-from-file theme fn))))
|
||
(princ "\n\nDocumentation:\n")
|
||
(princ (if (stringp doc)
|
||
(substitute-command-keys doc)
|
||
"No documentation available.")))
|
||
(princ "\n\nYou can ")
|
||
(help-insert-xref-button "customize" 'help-theme-edit theme)
|
||
(princ " this theme."))
|
||
|
||
|
||
;;; Theme chooser
|
||
|
||
(defvar custom--listed-themes)
|
||
|
||
(defcustom custom-theme-allow-multiple-selections nil
|
||
"Whether to allow multi-selections in the *Custom Themes* buffer."
|
||
:version "24.1"
|
||
:type 'boolean
|
||
:group 'custom-buffer)
|
||
|
||
(defvar-keymap custom-theme-choose-mode-map
|
||
:doc "Keymap for `custom-theme-choose-mode'."
|
||
:full t
|
||
:suppress t
|
||
:parent (make-composed-keymap widget-keymap special-mode-map)
|
||
"C-x C-s" #'custom-theme-save
|
||
"n" #'widget-forward
|
||
"p" #'widget-backward
|
||
"?" #'custom-describe-theme)
|
||
|
||
(define-derived-mode custom-theme-choose-mode special-mode "Themes"
|
||
"Major mode for selecting Custom themes.
|
||
Do not call this mode function yourself. It is meant for internal use."
|
||
(use-local-map custom-theme-choose-mode-map)
|
||
(custom--initialize-widget-variables)
|
||
(setq-local revert-buffer-function
|
||
(lambda (_ignore-auto noconfirm)
|
||
(when (or noconfirm (y-or-n-p "Discard current choices? "))
|
||
(customize-themes (current-buffer))))))
|
||
(put 'custom-theme-choose-mode 'mode-class 'special)
|
||
|
||
;;;###autoload
|
||
(defun customize-themes (&optional buffer)
|
||
"Display a selectable list of Custom themes.
|
||
When called from Lisp, BUFFER should be the buffer to use; if
|
||
omitted, a buffer named *Custom Themes* is used."
|
||
(interactive)
|
||
(switch-to-buffer (get-buffer-create (or buffer "*Custom Themes*")))
|
||
(let ((inhibit-read-only t))
|
||
(erase-buffer))
|
||
(custom-theme-choose-mode)
|
||
(setq-local custom--listed-themes nil)
|
||
(make-local-variable 'custom-theme-allow-multiple-selections)
|
||
(and (null custom-theme-allow-multiple-selections)
|
||
(> (length custom-enabled-themes) 1)
|
||
(setq custom-theme-allow-multiple-selections t))
|
||
|
||
(widget-insert
|
||
(substitute-command-keys
|
||
"Type RET or click to enable/disable listed custom themes.
|
||
Type \\[custom-describe-theme] to describe the theme at point.
|
||
Theme files are named *-theme.el in `"))
|
||
(widget-create 'link :value "custom-theme-load-path"
|
||
:button-face 'custom-link
|
||
:mouse-face 'highlight
|
||
:pressed-face 'highlight
|
||
:help-echo "Describe `custom-theme-load-path'."
|
||
:keymap custom-mode-link-map
|
||
:follow-link 'mouse-face
|
||
:action (lambda (_widget &rest _ignore)
|
||
(describe-variable 'custom-theme-load-path)))
|
||
(widget-insert (substitute-command-keys "'.\n\n"))
|
||
|
||
;; If the user has made customizations, display a warning and
|
||
;; provide buttons to disable or convert them.
|
||
(let ((user-settings (get 'user 'theme-settings)))
|
||
(unless (or (null user-settings)
|
||
(and (null (cdr user-settings))
|
||
(eq (caar user-settings) 'theme-value)
|
||
(eq (cadr (car user-settings)) 'custom-enabled-themes)))
|
||
(widget-insert
|
||
(propertize
|
||
" Note: Your custom settings take precedence over theme settings.
|
||
To migrate your settings into a theme, click "
|
||
'face 'font-lock-warning-face))
|
||
(widget-create 'link :value "here"
|
||
:button-face 'custom-link
|
||
:mouse-face 'highlight
|
||
:pressed-face 'highlight
|
||
:help-echo "Migrate."
|
||
:keymap custom-mode-link-map
|
||
:follow-link 'mouse-face
|
||
:action (lambda (_widget &rest _ignore)
|
||
(customize-create-theme 'user)))
|
||
(widget-insert ".\n\n")))
|
||
|
||
(widget-create 'push-button
|
||
:tag " Save Theme Settings "
|
||
:help-echo "Save the selected themes for future sessions."
|
||
:action #'custom-theme-save)
|
||
(widget-insert ?\n)
|
||
(widget-create 'checkbox
|
||
:value custom-theme-allow-multiple-selections
|
||
:action #'custom-theme-selections-toggle)
|
||
(widget-insert (propertize " Select more than one theme at a time"
|
||
'face '(variable-pitch (:height 0.9))))
|
||
|
||
(widget-insert "\n\nAvailable Custom Themes:\n")
|
||
(let ((help-echo "mouse-2: Enable this theme for this session")
|
||
widget)
|
||
(dolist (theme (custom-available-themes))
|
||
;; Don't list obsolete themes.
|
||
(unless (get theme 'byte-obsolete-info)
|
||
(setq widget (widget-create 'checkbox
|
||
:value (custom-theme-enabled-p theme)
|
||
:theme-name theme
|
||
:help-echo help-echo
|
||
:action #'custom-theme-checkbox-toggle))
|
||
(push (cons theme widget) custom--listed-themes)
|
||
(widget-create-child-and-convert widget 'push-button
|
||
:button-face-get 'ignore
|
||
:mouse-face-get 'ignore
|
||
:value (format " %s" theme)
|
||
:action #'widget-parent-action
|
||
:help-echo help-echo)
|
||
(widget-insert " -- "
|
||
(propertize (custom-theme-summary theme)
|
||
'face 'shadow)
|
||
?\n))))
|
||
(goto-char (point-min))
|
||
(widget-setup))
|
||
|
||
(defun custom-theme-summary (theme)
|
||
"Return the summary line of THEME."
|
||
(let (doc)
|
||
(if (custom-theme-p theme)
|
||
(setq doc (get theme 'theme-documentation))
|
||
(let ((fn (locate-file (concat (symbol-name theme) "-theme.el")
|
||
(custom-theme--load-path)
|
||
'("" "c"))))
|
||
(when fn
|
||
(with-temp-buffer
|
||
(insert-file-contents fn)
|
||
(let ((sexp (let ((read-circle nil))
|
||
(condition-case nil
|
||
(progn
|
||
(re-search-forward "^(deftheme")
|
||
(beginning-of-line)
|
||
(read (current-buffer)))
|
||
(error nil)))))
|
||
(setq doc (nth 2 sexp)))))))
|
||
(cond ((null doc)
|
||
"(no documentation available)")
|
||
((string-match ".*" doc)
|
||
(match-string 0 doc))
|
||
(t doc))))
|
||
|
||
(defun custom-theme-checkbox-toggle (widget &optional event)
|
||
(let ((this-theme (widget-get widget :theme-name)))
|
||
(if (widget-value widget)
|
||
;; Disable the theme.
|
||
(progn
|
||
(disable-theme this-theme)
|
||
(widget-toggle-action widget event))
|
||
;; Enable the theme.
|
||
(unless custom-theme-allow-multiple-selections
|
||
;; If only one theme is allowed, disable all other themes and
|
||
;; uncheck their boxes.
|
||
(dolist (theme custom-enabled-themes)
|
||
(and (not (eq theme this-theme))
|
||
(assq theme custom--listed-themes)
|
||
(disable-theme theme)))
|
||
(dolist (theme custom--listed-themes)
|
||
(unless (eq (car theme) this-theme)
|
||
(widget-value-set (cdr theme) nil)
|
||
(widget-apply (cdr theme) :notify (cdr theme) event))))
|
||
(when (load-theme this-theme)
|
||
(widget-toggle-action widget event)))
|
||
;; Mark `custom-enabled-themes' as "set for current session".
|
||
(put 'custom-enabled-themes 'customized-value
|
||
(list (custom-quote custom-enabled-themes)))))
|
||
|
||
(defun custom-describe-theme ()
|
||
"Describe the Custom theme on the current line."
|
||
(interactive)
|
||
(let ((widget (widget-at (line-beginning-position))))
|
||
(and widget
|
||
(describe-theme (widget-get widget :theme-name)))))
|
||
|
||
(defun custom-theme-save (&rest _ignore)
|
||
(interactive)
|
||
(customize-save-variable 'custom-enabled-themes custom-enabled-themes)
|
||
(message "Custom themes saved for future sessions."))
|
||
|
||
(defun custom-theme-selections-toggle (widget &optional event)
|
||
(when (widget-value widget)
|
||
;; Deactivate multiple-selections.
|
||
(if (< 1 (length (delq nil (mapcar (lambda (x) (widget-value (cdr x)))
|
||
custom--listed-themes))))
|
||
(error "More than one theme is currently selected")))
|
||
(widget-toggle-action widget event)
|
||
(setq custom-theme-allow-multiple-selections (widget-value widget)))
|
||
|
||
(provide 'cus-theme)
|
||
|
||
;;; cus-theme.el ends here
|