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

[Philip Kaludercic]

Lars Ingebrigtsen <larsi@gnus.org> writes:

> Philip Kaludercic <philipk@posteo.net> writes:
>
>> Subject: [PATCH] Tag themes with properties
>
> Thanks; looks good to me.

One last additional, I've added a property to all the themes indicating
that they are colour schemes.  This would make it easier to toggle
between dark and light modes if multiple themes are enabled of which
only one is a colour theme:

>From 62c55cc27024348e43ae4591c3d239d705f8ad1b 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)
---
 doc/emacs/custom.texi           | 10 +++++
 doc/lispref/customize.texi      |  5 ++-
 etc/themes/adwaita-theme.el     |  4 +-
 etc/themes/deeper-blue-theme.el |  4 +-
 etc/themes/dichromacy-theme.el  |  4 +-
 etc/themes/leuven-dark-theme.el |  6 ++-
 etc/themes/leuven-theme.el      |  6 ++-
 etc/themes/light-blue-theme.el  |  4 +-
 etc/themes/manoj-dark-theme.el  |  4 +-
 etc/themes/misterioso-theme.el  |  4 +-
 etc/themes/tango-dark-theme.el  |  5 ++-
 etc/themes/tango-theme.el       |  5 ++-
 etc/themes/tsdh-dark-theme.el   |  5 ++-
 etc/themes/tsdh-light-theme.el  |  5 ++-
 etc/themes/wheatgrass-theme.el  |  4 +-
 etc/themes/whiteboard-theme.el  |  4 +-
 etc/themes/wombat-theme.el      |  4 +-
 lisp/custom.el                  | 70 ++++++++++++++++++++++++++++++---
 18 files changed, 128 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..6ac7d8f316 100644
--- a/etc/themes/adwaita-theme.el
+++ b/etc/themes/adwaita-theme.el
@@ -24,7 +24,9 @@
 (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)
 
 (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..db3b9b5b60 100644
--- a/etc/themes/deeper-blue-theme.el
+++ b/etc/themes/deeper-blue-theme.el
@@ -22,7 +22,9 @@
 ;;; Code:
 
 (deftheme deeper-blue
-  "Face colors using a deep blue background.")
+  "Face colors using a deep blue background."
+  :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..d2c5983862 100644
--- a/etc/themes/dichromacy-theme.el
+++ b/etc/themes/dichromacy-theme.el
@@ -28,7 +28,9 @@ 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)
 
 (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..42ebd7b2d6 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: 20220917.2332
 ;; Keywords: color theme
 
 ;; This file is part of GNU Emacs.
@@ -97,7 +97,9 @@ 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)
 
 (let ((class '((class color) (min-colors 89)))
 
diff --git a/etc/themes/leuven-theme.el b/etc/themes/leuven-theme.el
index d9a8d5391a..07c34e944c 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: 20220917.2332
 ;; Keywords: color theme
 
 ;; This file is part of GNU Emacs.
@@ -78,7 +78,9 @@ 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
+  :family 'leuven)
 
 (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..449600d01d 100644
--- a/etc/themes/light-blue-theme.el
+++ b/etc/themes/light-blue-theme.el
@@ -27,7 +27,9 @@
 ;;; Code:
 
 (deftheme light-blue
-  "Face colors utilizing a light blue background.")
+  "Face colors utilizing a light blue background."
+  :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..402aafe49d 100644
--- a/etc/themes/manoj-dark-theme.el
+++ b/etc/themes/manoj-dark-theme.el
@@ -67,7 +67,9 @@
 (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)
 
 (custom-theme-set-faces
  'manoj-dark
diff --git a/etc/themes/misterioso-theme.el b/etc/themes/misterioso-theme.el
index 55186384ad..7e3f0289f1 100644
--- a/etc/themes/misterioso-theme.el
+++ b/etc/themes/misterioso-theme.el
@@ -22,7 +22,9 @@
 ;;; 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)
 
 (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..73a928e445 100644
--- a/etc/themes/tango-dark-theme.el
+++ b/etc/themes/tango-dark-theme.el
@@ -30,7 +30,10 @@
 (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)
 
 (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..8b8011bd1f 100644
--- a/etc/themes/tango-theme.el
+++ b/etc/themes/tango-theme.el
@@ -30,7 +30,10 @@
 (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)
 
 (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..2a2507f147 100644
--- a/etc/themes/tsdh-dark-theme.el
+++ b/etc/themes/tsdh-dark-theme.el
@@ -20,7 +20,10 @@
 ;;; 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)
 
 (custom-theme-set-faces
  'tsdh-dark
diff --git a/etc/themes/tsdh-light-theme.el b/etc/themes/tsdh-light-theme.el
index d9d09b702b..130b2a33d4 100644
--- a/etc/themes/tsdh-light-theme.el
+++ b/etc/themes/tsdh-light-theme.el
@@ -21,7 +21,10 @@
 
 (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)
 
 (custom-theme-set-faces
  'tsdh-light
diff --git a/etc/themes/wheatgrass-theme.el b/etc/themes/wheatgrass-theme.el
index c56c8a2d8a..5b4370351f 100644
--- a/etc/themes/wheatgrass-theme.el
+++ b/etc/themes/wheatgrass-theme.el
@@ -23,7 +23,9 @@ 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)
 
 (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..676e0e0f70 100644
--- a/etc/themes/whiteboard-theme.el
+++ b/etc/themes/whiteboard-theme.el
@@ -22,7 +22,9 @@
 ;;; 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)
 
 (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..4eef29841b 100644
--- a/etc/themes/wombat-theme.el
+++ b/etc/themes/wombat-theme.el
@@ -25,7 +25,9 @@ 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)
 
 (let ((class '((class color) (min-colors 89))))
   (custom-theme-set-faces
diff --git a/lisp/custom.el b/lisp/custom.el
index 352b5b0e16..3b36544d9d 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 &rest list)
+  "Return a list of theme variants for THEME.
+If the optional argument LIST is not given, "
+  (let* ((properties (get theme 'theme-properties))
+         (family (plist-get properties :family)))
+    (seq-filter
+     (lambda (variant)
+       (and (eq (plist-get (get variant 'theme-properties) :family)
+                family)
+            (not (eq variant theme))))
+     (or list (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


Also, the issue I mentioned previously remains.  The properties are only
noticed if the theme file is loaded.  So if you enabled `leuven-dark',
you won't be able to toggle before `leuven' is loaded at least once.