[elpa] master 807f484 03/31: Allow themes to be overridden, but warn.

[Jackson Ray Hamilton]

branch: master
commit 807f484f511a9bfd58d0dd89eb11eacce3b96b33
Author: Jackson Ray Hamilton <address@hidden>
Commit: Jackson Ray Hamilton <address@hidden>

    Allow themes to be overridden, but warn.
---
 context-coloring.el           |   63 ++++++++++++++++++++++++----------------
 test/context-coloring-test.el |   31 ++++++++++++++++++++
 2 files changed, 69 insertions(+), 25 deletions(-)

diff --git a/context-coloring.el b/context-coloring.el
index b09ed1c..2dcf183 100644
--- a/context-coloring.el
+++ b/context-coloring.el
@@ -481,15 +481,25 @@ would be redundant."
   "Return t if THEME is defined, nil otherwise."
   (and (gethash theme context-coloring-theme-hash-table)))
 
-(defun context-coloring-check-theme (theme)
-  "Signal error if THEME is undefined."
-  (when (not (context-coloring-themep theme))
-    (error (format "No such theme `%s'" theme))))
-
 (defconst context-coloring-level-face-regexp
   "context-coloring-level-\\([[:digit:]]+\\)-face"
   "Regular expression for extracting a level from a face.")
 
+(defun context-coloring-theme-definedp (theme)
+  "Return t if there is a `context-coloring-level-N-face' defined
+for THEME, nil otherwise."
+  (let* ((settings (get theme 'theme-settings))
+         (tail settings)
+         found)
+    (while (and tail (not found))
+      (and (eq (nth 0 (car tail)) 'theme-face)
+           (string-match
+            context-coloring-level-face-regexp
+            (symbol-name (nth 1 (car tail))))
+           (setq found t))
+      (setq tail (cdr tail)))
+    found))
+
 (defun context-coloring-theme-highest-level (theme)
   "Return the highest level N of a face like
 `context-coloring-level-N-face' defined for THEME, or -1 if there
@@ -514,18 +524,6 @@ is none."
       (setq tail (cdr tail)))
     found))
 
-(defun context-coloring-setup-theme (theme)
-  "Sets up THEME if its colors are not already defined, else just
-sets `context-coloring-face-count' to the correct value for
-THEME."
-  (context-coloring-check-theme theme)
-  (let ((highest-level (context-coloring-theme-highest-level theme)))
-    (cond
-     ((> highest-level -1)
-      (setq context-coloring-face-count (+ highest-level 1)))
-     (t
-      (context-coloring-apply-theme theme)))))
-
 (defun context-coloring-apply-theme (theme)
   "Applies THEME's properties to its respective custom theme,
 which must already exist and which *should* already be enabled."
@@ -549,22 +547,37 @@ PROPERTIES is a property list specifiying the following 
details:
 `:colors': List of colors that this theme uses."
   (let ((aliases (plist-get properties :aliases)))
     (dolist (name (append `(,theme) aliases))
+      (when (context-coloring-theme-definedp name)
+        (warn "Colors for `%s' are already defined" name))
       (puthash name properties context-coloring-theme-hash-table)
-      ;; Compensate for already-enabled themes by applying their colors now.
-      (when (custom-theme-enabled-p name)
-        (context-coloring-setup-theme name)))))
+      ;; Set (or overwrite) colors.
+      (when (custom-theme-p name)
+        (context-coloring-apply-theme name)))))
 
 (defun context-coloring-load-theme (&optional rest)
-  (declare (obsolete
-            "themes are now loaded alongside custom themes automatically."
-            "4.1.0")))
+  (declare
+   (obsolete
+    "themes are now loaded alongside custom themes automatically."
+    "4.1.0")))
+
+(defun context-coloring-enable-theme (theme)
+  "Applies THEME if its colors are not already defined, else just
+sets `context-coloring-face-count' to the correct value for
+THEME."
+  (let ((highest-level (context-coloring-theme-highest-level theme)))
+    (cond
+     ((> highest-level -1)
+      (setq context-coloring-face-count (+ highest-level 1)))
+     (t
+      (context-coloring-apply-theme theme)))))
 
 (defadvice enable-theme (after context-coloring-enable-theme (theme) activate)
-  "Add colors to themes just-in-time."
+  "Enable colors for themes just-in-time.  We can't set faces for
+themes that might not exist yet."
   (when (and (not (eq theme 'user))          ; Called internally by 
`enable-theme'.
              (context-coloring-themep theme)
              (custom-theme-p theme))         ; Guard against non-existent 
themes.
-    (context-coloring-setup-theme theme)))
+    (context-coloring-enable-theme theme)))
 
 (context-coloring-define-theme
  'leuven
diff --git a/test/context-coloring-test.el b/test/context-coloring-test.el
index a5a11fb..168b6fa 100644
--- a/test/context-coloring-test.el
+++ b/test/context-coloring-test.el
@@ -268,6 +268,37 @@ is FOREGROUND."
   (context-coloring-test-assert-face 8 "#888888")
   (context-coloring-test-assert-face 9 "#999999"))
 
+(defun context-coloring-test-assert-theme-definedp (settings &optional negate)
+  "Assert that `context-coloring-theme-definedp' returns t for a
+theme with SETTINGS (or the inverse if NEGATE is non-nil)."
+  (let (theme)
+    (put theme 'theme-settings settings)
+    (when (funcall (if negate 'identity 'not) (context-coloring-theme-definedp 
theme))
+      (ert-fail (format (concat "Expected theme with settings `%s' "
+                                "%sto be considered to have defined a level, "
+                                "but it %s.")
+                        settings
+                        (if negate "not " "")
+                        (if negate "was" "wasn't"))))))
+
+(defun context-coloring-test-assert-not-theme-definedp (&rest arguments)
+  "Assert that `context-coloring-theme-definedp' does not return
+t for a theme with SETTINGS."
+  (apply 'context-coloring-test-assert-theme-definedp (append arguments '(t))))
+
+(ert-deftest context-coloring-test-theme-definedp ()
+  (context-coloring-test-assert-theme-definedp
+   '((theme-face context-coloring-level-0-face)))
+  (context-coloring-test-assert-theme-definedp
+   '((theme-face face)
+     (theme-face context-coloring-level-0-face)))
+  (context-coloring-test-assert-theme-definedp
+   '((theme-face context-coloring-level-0-face)
+     (theme-face face)))
+  (context-coloring-test-assert-not-theme-definedp
+   '((theme-face face)))
+  )
+
 (defun context-coloring-test-assert-theme-highest-level (settings 
expected-level)
   (let (theme)
     (put theme 'theme-settings settings)