bug#57639: [PATCH] Add new command 'toggle-theme'

[Philip Kaludercic]

Lars Ingebrigtsen <larsi@gnus.org> writes:

> Philip Kaludercic <philipk@posteo.net> writes:
>
>>> autoloads: $(lisp)/emacs-lisp/loaddefs-gen.elc gen-lisp
>>>     $(AM_V_GEN)$(emacs) \
>>>             -l $(lisp)/emacs-lisp/loaddefs-gen.elc \
>>>         -f loaddefs-generate--emacs-batch ${SUBDIRS_ALMOST}
>>>
>>> We can add ../etc/themes there after ${SUBDIRS_ALMOST}, though.
>>
>> Would there be a disadvantage to doing so?
>
> There's no problems when doing
>
> ;;;###autoload(put ...)

Ok, that sounds good.  Here is the updated patch:

>From 6e6c5a9cf356b5f634ba388f8e2724a1de893297 Mon Sep 17 00:00:00 2001
From: Philip Kaludercic <philipk@posteo.net>
Date: Sat, 17 Sep 2022 20:11:42 +0200
Subject: [PATCH] Tag themes with properties

* doc/emacs/custom.texi (Custom Themes): Document 'theme-choose-variant'.
* doc/lispref/customize.texi (Custom Themes): Document the new
optional argument to 'deftheme'.
* etc/themes/adwaita-theme.el (adwaita): Add properties.
* etc/themes/deeper-blue-theme.el (deeper-blue): Add properties.
* etc/themes/dichromacy-theme.el (dichromacy): Add properties.
* etc/themes/light-blue-theme.el (light-blue): Add properties.
* etc/themes/manoj-dark-theme.el (manoj-dark): Add properties.
* etc/themes/misterioso-theme.el (misterioso): Add properties.
* etc/themes/tango-dark-theme.el (tango-dark): Add properties.
* etc/themes/tango-theme.el (tango): Add properties.
* etc/themes/tsdh-dark-theme.el (tsdh-dark): Add properties.
* etc/themes/tsdh-light-theme.el (tsdh-light): Add properties.
* etc/themes/wheatgrass-theme.el (wheatgrass): Add properties.
* etc/themes/whiteboard-theme.el (whiteboard): Add properties.
* etc/themes/wombat-theme.el (wombat): Add properties.
* lisp/custom.el (deftheme): Allow for optional arguments to set the
property list.
(custom-declare-theme): Accept the same optional arguments as 'deftheme'.
(theme-list-variants): Add new function.
(theme-choose-variant): Add new command for switching between members
of a theme family.
(toggle-theme): Add an alias for 'theme-choose-variant'.  (Bug#57639)

This patch adds theme properties twice, once as part of the deftheme
declarations and once by explicitly manipulating the symbol plist.
Ideally only the first case would be necessary, but in that case the
theme properties only become visible after the theme has been loaded
which is (initially) unfortunate if you want to toggle between themes.
---
 doc/emacs/custom.texi           | 10 +++++
 doc/lispref/customize.texi      |  5 ++-
 etc/themes/adwaita-theme.el     |  6 ++-
 etc/themes/deeper-blue-theme.el |  6 ++-
 etc/themes/dichromacy-theme.el  |  6 ++-
 etc/themes/leuven-dark-theme.el |  9 ++++-
 etc/themes/leuven-theme.el      |  9 ++++-
 etc/themes/light-blue-theme.el  |  6 ++-
 etc/themes/manoj-dark-theme.el  |  6 ++-
 etc/themes/misterioso-theme.el  |  6 ++-
 etc/themes/tango-dark-theme.el  |  7 +++-
 etc/themes/tango-theme.el       |  7 +++-
 etc/themes/tsdh-dark-theme.el   |  7 +++-
 etc/themes/tsdh-light-theme.el  |  7 +++-
 etc/themes/wheatgrass-theme.el  |  6 ++-
 etc/themes/whiteboard-theme.el  |  6 ++-
 etc/themes/wombat-theme.el      |  6 ++-
 lisp/custom.el                  | 70 ++++++++++++++++++++++++++++++---
 18 files changed, 160 insertions(+), 25 deletions(-)

diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi
index ff7ab83190..f98527bf9a 100644
--- a/doc/emacs/custom.texi
+++ b/doc/emacs/custom.texi
@@ -667,6 +667,16 @@ Custom Themes
 the @file{*Custom Themes*} buffer; or type @kbd{M-x describe-theme}
 anywhere in Emacs and enter the theme name.
 
+@findex theme-choose-variant
+Some themes have variants (most often just two: light and dark).  You
+can switch to another variant using @kbd{M-x theme-choose-variant}.
+If the currently active theme has only one other variant, it will be
+selected; if there are more variants, the command will prompt you
+which one to switch to.
+
+Note that @code{theme-choose-variant} only works if a single theme
+is active.
+
 @node Creating Custom Themes
 @subsection Creating Custom Themes
 @cindex custom themes, creating
diff --git a/doc/lispref/customize.texi b/doc/lispref/customize.texi
index 6ba35cffff..911b6c4d75 100644
--- a/doc/lispref/customize.texi
+++ b/doc/lispref/customize.texi
@@ -1428,12 +1428,13 @@ Custom Themes
 be a call to @code{deftheme}, and the last form should be a call to
 @code{provide-theme}.
 
-@defmac deftheme theme &optional doc
+@defmac deftheme theme &optional doc &rest properties
 This macro declares @var{theme} (a symbol) as the name of a Custom
 theme.  The optional argument @var{doc} should be a string describing
 the theme; this is the description shown when the user invokes the
 @code{describe-theme} command or types @kbd{?} in the @samp{*Custom
-Themes*} buffer.
+Themes*} buffer.  The remaining arguments @var{properties} are used
+pass a property list with theme attributes.
 
 Two special theme names are disallowed (using them causes an error):
 @code{user} is a dummy theme that stores the user's direct
diff --git a/etc/themes/adwaita-theme.el b/etc/themes/adwaita-theme.el
index ba83a0578c..c1d694f5dc 100644
--- a/etc/themes/adwaita-theme.el
+++ b/etc/themes/adwaita-theme.el
@@ -24,7 +24,11 @@
 (deftheme adwaita
   "Face colors similar to the default theme of Gnome 3 (Adwaita).
 The colors are chosen to match Adwaita window decorations and the
-default look of the Gnome 3 desktop.")
+default look of the Gnome 3 desktop."
+  :background-mode 'light
+  :kind 'color-scheme)
+
+;;;###autoload (put 'adwaita 'theme-properties '(:background-mode light :kind 
color-scheme))
 
 (let ((class '((class color) (min-colors 89))))
   (custom-theme-set-faces
diff --git a/etc/themes/deeper-blue-theme.el b/etc/themes/deeper-blue-theme.el
index 8f19147f91..13abbe0672 100644
--- a/etc/themes/deeper-blue-theme.el
+++ b/etc/themes/deeper-blue-theme.el
@@ -22,7 +22,11 @@
 ;;; Code:
 
 (deftheme deeper-blue
-  "Face colors using a deep blue background.")
+  "Face colors using a deep blue background."
+  :background-mode 'dark
+  :kind 'color-scheme)
+
+;;;###autoload (put 'deeper-blue 'theme-properties '(:background-mode dark 
:kind color-scheme))
 
 (let ((class '((class color) (min-colors 89))))
   (custom-theme-set-faces
diff --git a/etc/themes/dichromacy-theme.el b/etc/themes/dichromacy-theme.el
index d53c075d92..a25d2c310f 100644
--- a/etc/themes/dichromacy-theme.el
+++ b/etc/themes/dichromacy-theme.el
@@ -28,7 +28,11 @@ dichromacy
 differentiated by individuals with protanopia or deuteranopia.
 
 Basic, Font Lock, Isearch, Gnus, Message, Flyspell, and
-Ansi-Color faces are included.")
+Ansi-Color faces are included."
+  :background-mode 'light
+  :kind 'color-scheme)
+
+;;;###autoload (put 'dichromacy 'theme-properties '(:background-mode light 
:kind color-scheme))
 
 (let ((class '((class color) (min-colors 89)))
       (orange "#e69f00")
diff --git a/etc/themes/leuven-dark-theme.el b/etc/themes/leuven-dark-theme.el
index 0e162c8bab..0d3e1970ac 100644
--- a/etc/themes/leuven-dark-theme.el
+++ b/etc/themes/leuven-dark-theme.el
@@ -5,7 +5,7 @@
 ;; Author: Fabrice Niessen <(concat "fniessen" at-sign "pirilampo.org")>
 ;; Contributor: Thibault Polge <(concat "thibault" at-sign "thb.lt")>
 ;; URL: https://github.com/fniessen/emacs-leuven-dark-theme
-;; Version: 20220202.1126
+;; Version: 20220921.1327
 ;; Keywords: color theme
 
 ;; This file is part of GNU Emacs.
@@ -97,7 +97,12 @@ leuven-dark
   "Face colors with a light background.
 Basic, Font Lock, Isearch, Gnus, Message, Org mode, Diff, Ediff,
 Flyspell, Semantic, and Ansi-Color faces are included -- and much
-more...")
+more..."
+  :background-mode 'dark
+  :family 'leuven
+  :kind 'color-scheme)
+
+;;;###autoload (put 'leuven-dark 'theme-properties '(:background-mode dark 
:family leuven :kind color-scheme))
 
 (let ((class '((class color) (min-colors 89)))
 
diff --git a/etc/themes/leuven-theme.el b/etc/themes/leuven-theme.el
index d9a8d5391a..0bbc69aa05 100644
--- a/etc/themes/leuven-theme.el
+++ b/etc/themes/leuven-theme.el
@@ -4,7 +4,7 @@
 
 ;; Author: Fabrice Niessen <(concat "fniessen" at-sign "pirilampo.org")>
 ;; URL: https://github.com/fniessen/emacs-leuven-theme
-;; Version: 20200513.1928
+;; Version: 20220921.1328
 ;; Keywords: color theme
 
 ;; This file is part of GNU Emacs.
@@ -78,7 +78,12 @@ leuven
   "Face colors with a light background.
 Basic, Font Lock, Isearch, Gnus, Message, Org mode, Diff, Ediff,
 Flyspell, Semantic, and Ansi-Color faces are included -- and much
-more...")
+more..."
+  :background-mode 'light
+  :kind 'color-scheme
+  :family 'leuven)
+
+;;;###autoload (put 'leuven 'theme-properties '(:background-mode light :family 
leuven :kind color-scheme))
 
 (let ((class '((class color) (min-colors 89)))
 
diff --git a/etc/themes/light-blue-theme.el b/etc/themes/light-blue-theme.el
index eeca46210c..ff1fde85a9 100644
--- a/etc/themes/light-blue-theme.el
+++ b/etc/themes/light-blue-theme.el
@@ -27,7 +27,11 @@
 ;;; Code:
 
 (deftheme light-blue
-  "Face colors utilizing a light blue background.")
+  "Face colors utilizing a light blue background."
+  :background-mode 'light
+  :kind 'color-scheme)
+
+;;;###autoload (put 'light-blue 'theme-properties '(:background-mode light 
:kind color-scheme))
 
 (make-obsolete 'light-blue nil "29.1")
 
diff --git a/etc/themes/manoj-dark-theme.el b/etc/themes/manoj-dark-theme.el
index af5576386c..791ad2f353 100644
--- a/etc/themes/manoj-dark-theme.el
+++ b/etc/themes/manoj-dark-theme.el
@@ -67,7 +67,11 @@
 (deftheme manoj-dark
   "Very high contrast faces with a black background.
 This theme avoids subtle color variations, while avoiding the
-jarring angry fruit salad look to reduce eye fatigue.")
+jarring angry fruit salad look to reduce eye fatigue."
+  :background-mode 'dark
+  :kind 'color-scheme)
+
+;;;###autoload (put 'manoj-dark 'theme-properties '(:background-mode dark 
:kind color-scheme))
 
 (custom-theme-set-faces
  'manoj-dark
diff --git a/etc/themes/misterioso-theme.el b/etc/themes/misterioso-theme.el
index 55186384ad..e7e5dac3dc 100644
--- a/etc/themes/misterioso-theme.el
+++ b/etc/themes/misterioso-theme.el
@@ -22,7 +22,11 @@
 ;;; Code:
 
 (deftheme misterioso
-  "Predominantly blue/cyan faces on a dark cyan background.")
+  "Predominantly blue/cyan faces on a dark cyan background."
+  :background-mode 'dark
+  :kind 'color-scheme)
+
+;;;###autoload (put 'misterioso 'theme-properties '(:background-mode dark 
:kind color-scheme))
 
 (let ((class '((class color) (min-colors 89))))
 
diff --git a/etc/themes/tango-dark-theme.el b/etc/themes/tango-dark-theme.el
index ef00d2ac49..f7d13c5bd5 100644
--- a/etc/themes/tango-dark-theme.el
+++ b/etc/themes/tango-dark-theme.el
@@ -30,7 +30,12 @@
 (deftheme tango-dark
   "Face colors using the Tango palette (dark background).
 Basic, Font Lock, Isearch, Gnus, Message, Ediff, Flyspell,
-Semantic, and Ansi-Color faces are included.")
+Semantic, and Ansi-Color faces are included."
+  :background-mode 'dark
+  :kind 'color-scheme
+  :family 'tango)
+
+;;;###autoload (put 'tango-dark 'theme-properties '(:background-mode dark 
:kind color-scheme :family tango))
 
 (let ((class '((class color) (min-colors 89)))
       ;; Tango palette colors.
diff --git a/etc/themes/tango-theme.el b/etc/themes/tango-theme.el
index ecbbf03753..8df3f50ded 100644
--- a/etc/themes/tango-theme.el
+++ b/etc/themes/tango-theme.el
@@ -30,7 +30,12 @@
 (deftheme tango
   "Face colors using the Tango palette (light background).
 Basic, Font Lock, Isearch, Gnus, Message, Ediff, Flyspell,
-Semantic, and Ansi-Color faces are included.")
+Semantic, and Ansi-Color faces are included."
+  :background-mode 'light
+  :kind 'color-scheme
+  :family 'tango)
+
+;;;###autoload (put 'tango 'theme-properties '(:background-mode light :kind 
color-scheme :family tango))
 
 (let ((class '((class color) (min-colors 89)))
       ;; Tango palette colors.
diff --git a/etc/themes/tsdh-dark-theme.el b/etc/themes/tsdh-dark-theme.el
index a88ad75520..afb915dcce 100644
--- a/etc/themes/tsdh-dark-theme.el
+++ b/etc/themes/tsdh-dark-theme.el
@@ -20,7 +20,12 @@
 ;;; Code:
 
 (deftheme tsdh-dark
-  "A dark theme used and created by Tassilo Horn.")
+  "A dark theme used and created by Tassilo Horn."
+  :background-mode 'dark
+  :kind 'color-scheme
+  :family 'tsdh)
+
+;;;###autoload (put 'tsdh-dark 'theme-properties '(:background-mode dark :kind 
color-scheme :family tsdh))
 
 (custom-theme-set-faces
  'tsdh-dark
diff --git a/etc/themes/tsdh-light-theme.el b/etc/themes/tsdh-light-theme.el
index d9d09b702b..7fad6c337a 100644
--- a/etc/themes/tsdh-light-theme.el
+++ b/etc/themes/tsdh-light-theme.el
@@ -21,7 +21,12 @@
 
 (deftheme tsdh-light
   "A light Emacs theme.
-Used and created by Tassilo Horn.")
+Used and created by Tassilo Horn."
+  :background-mode 'light
+  :kind 'color-scheme
+  :family 'tsdh)
+
+;;;###autoload (put 'tsdh-light 'theme-properties '(:background-mode light 
:kind color-scheme :family tsdh))
 
 (custom-theme-set-faces
  'tsdh-light
diff --git a/etc/themes/wheatgrass-theme.el b/etc/themes/wheatgrass-theme.el
index c56c8a2d8a..81aa68cb34 100644
--- a/etc/themes/wheatgrass-theme.el
+++ b/etc/themes/wheatgrass-theme.el
@@ -23,7 +23,11 @@ wheatgrass
   "High-contrast green/blue/brown faces on a black background.
 Basic, Font Lock, Isearch, Gnus, and Message faces are included.
 The default face foreground is wheat, with other faces in shades
-of green, brown, and blue.")
+of green, brown, and blue."
+  :background-mode 'dark
+  :kind 'color-scheme)
+
+;;;###autoload (put 'wheatgrass 'theme-properties '(:background-mode dark 
:kind color-scheme))
 
 (let ((class '((class color) (min-colors 89))))
   (custom-theme-set-faces
diff --git a/etc/themes/whiteboard-theme.el b/etc/themes/whiteboard-theme.el
index f21b18b421..7b92510049 100644
--- a/etc/themes/whiteboard-theme.el
+++ b/etc/themes/whiteboard-theme.el
@@ -22,7 +22,11 @@
 ;;; Code:
 
 (deftheme whiteboard
-  "Face colors similar to markers on a whiteboard.")
+  "Face colors similar to markers on a whiteboard."
+  :background-mode 'light
+  :kind 'color-scheme)
+
+;;;###autoload (put 'whiteboard 'theme-properties '(:background-mode light 
:kind color-scheme))
 
 (let ((class '((class color) (min-colors 89))))
   (custom-theme-set-faces
diff --git a/etc/themes/wombat-theme.el b/etc/themes/wombat-theme.el
index d9fab8ac78..2d0669f632 100644
--- a/etc/themes/wombat-theme.el
+++ b/etc/themes/wombat-theme.el
@@ -25,7 +25,11 @@ wombat
   "Medium-contrast faces with a dark gray background.
 Adapted, with permission, from a Vim color scheme by Lars H. Nielsen.
 Basic, Font Lock, Isearch, Gnus, Message, and Ansi-Color faces
-are included.")
+are included."
+  :background-mode 'dark
+  :kind 'color-scheme)
+
+;;;###autoload (put 'wombat 'theme-properties '(:background-mode dark :kind 
color-scheme))
 
 (let ((class '((class color) (min-colors 89))))
   (custom-theme-set-faces
diff --git a/lisp/custom.el b/lisp/custom.el
index 352b5b0e16..93ea80ef43 100644
--- a/lisp/custom.el
+++ b/lisp/custom.el
@@ -1152,9 +1152,11 @@ custom--sort-vars-1
 ;;   (provide-theme 'THEME)
 
 
-(defmacro deftheme (theme &optional doc)
+(defmacro deftheme (theme &optional doc &rest properties)
   "Declare THEME to be a Custom theme.
 The optional argument DOC is a doc string describing the theme.
+PROPERTIES are interpreted as a property list that will be stored
+in the `theme-properties' property for THEME.
 
 Any theme `foo' should be defined in a file called `foo-theme.el';
 see `custom-make-theme-feature' for more information."
@@ -1164,18 +1166,25 @@ deftheme
     ;; It is better not to use backquote in this file,
     ;; because that makes a bootstrapping problem
     ;; if you need to recompile all the Lisp files using interpreted code.
-    (list 'custom-declare-theme (list 'quote theme) (list 'quote feature) 
doc)))
+    (list 'custom-declare-theme (list 'quote theme) (list 'quote feature) doc
+          (cons 'list properties))))
 
-(defun custom-declare-theme (theme feature &optional doc)
+(defun custom-declare-theme (theme feature &optional doc properties)
   "Like `deftheme', but THEME is evaluated as a normal argument.
-FEATURE is the feature this theme provides.  Normally, this is a symbol
-created from THEME by `custom-make-theme-feature'."
+FEATURE is the feature this theme provides.  Normally, this is a
+symbol created from THEME by `custom-make-theme-feature'.  The
+optional argument DOC may contain the documentation for THEME.
+The optional argument PROPERTIES may contain a property list of
+attributes associated with THEME."
   (unless (custom-theme-name-valid-p theme)
     (error "Custom theme cannot be named %S" theme))
   (unless (memq theme custom-known-themes)
     (push theme custom-known-themes))
   (put theme 'theme-feature feature)
-  (when doc (put theme 'theme-documentation doc)))
+  (when doc
+    (put theme 'theme-documentation doc))
+  (when properties
+    (put theme 'theme-properties properties)))
 
 (defun custom-make-theme-feature (theme)
   "Given a symbol THEME, create a new symbol by appending \"-theme\".
@@ -1372,6 +1381,55 @@ load-theme
     (enable-theme theme))
   t)
 
+(defun theme-list-variants (theme)
+  "Return a list of theme variants for THEME."
+  (let* ((properties (get theme 'theme-properties))
+         (family (plist-get properties :family)))
+    (when family
+      (seq-filter
+       (lambda (variant)
+         (and (eq (plist-get (get variant 'theme-properties) :family)
+                  family)
+              (not (eq variant theme))))
+       (custom-available-themes)))))
+
+(defun theme-choose-variant (&optional no-confirm no-enable)
+  "Prompt to switch from the current theme to one of its a variants.
+The current theme will be disabled before variant is enabled.  If
+the current theme has only one variant, switch to that variant
+without prompting, otherwise prompt for the variant to select.
+See `load-theme' for the meaning of NO-CONFIRM and NO-ENABLE."
+  (interactive)
+  (let ((active-color-schemes
+         (seq-filter
+          (lambda (theme)
+            ;; FIXME: As most themes currently do not have a `:kind'
+            ;; tag, it is assumed that a theme is a color scheme by
+            ;; default.  This should be reconsidered in the future.
+            (memq (plist-get (get theme 'theme-properties) :kind)
+                  '(color-scheme nil)))
+          custom-enabled-themes)))
+    (cond
+     ((length= active-color-schemes 0)
+      (user-error "No theme is active, cannot toggle"))
+     ((length> active-color-schemes 1)
+      (user-error "More than one theme active, cannot unambiguously toggle")))
+    (let* ((theme (car active-color-schemes))
+           (family (plist-get (get theme 'theme-properties) :family)))
+      (unless family
+        (error "Theme `%s' does not have any known variants" theme))
+      (let* ((variants (theme-list-variants theme))
+             (choice (cond
+                      ((null variants)
+                       (error "`%s' has no variants" theme))
+                      ((length= variants 1)
+                       (car variants))
+                      ((intern (completing-read "Load custom theme: " 
variants))))))
+        (disable-theme theme)
+        (load-theme choice no-confirm no-enable)))))
+
+(defalias 'toggle-theme #'theme-choose-variant)
+
 (defun custom-theme-load-confirm (hash)
   "Query the user about loading a Custom theme that may not be safe.
 The theme should be in the current buffer.  If the user agrees,
-- 
2.37.3

> because those are entered into the loaddefs.el file literally.  There
> may be some confusion if people start putting
>
> ;;;###autoload
> (defun ...)
>
> into the theme files, because the etc/themes directory is not in
> `load-path' (so those autoloads will fail).
>
> So it has a slightly inconsistent effect, but I don't think there'll be
> a problem in practice, because people don't put functions into the theme
> files.  *knocks on wood*

This is actually done a few times by the modus themes and at least once
by `leuven-dark' (see `leuven-dark-scale-font', tough I don't see why,
and if the autoloads aren't being generated to begin with the cookie is
pointless anyway).

Should this be addressed before the patch is pushed?