[elpa] master 5242aad 48/72: Fix :exit t / :exit nil inheritance issue

[Oleh Krehel]

branch: master
commit 5242aad74913d5040954f1bfca0859fa02528175
Author: Oleh Krehel <address@hidden>
Commit: Oleh Krehel <address@hidden>

    Fix :exit t / :exit nil inheritance issue
    
    * hydra-test.el (hydra-compat-colors): Add test.
    
    * hydra.el (hydra--aggregate-color): New defun.
    (hydra--head-color): Update.
    
    Fixes #46.
---
 hydra-test.el |   18 +++++++++++++
 hydra.el      |   78 +++++++++++++++++++++++++++++++++++++++++++-------------
 2 files changed, 78 insertions(+), 18 deletions(-)

diff --git a/hydra-test.el b/hydra-test.el
index 2a6b579..8386847 100644
--- a/hydra-test.el
+++ b/hydra-test.el
@@ -711,6 +711,24 @@ _f_ auto-fill-mode:    %`auto-fill-function
                        (buffer-narrowed-p)))
              "[[q]]: cancel"))))
 
+(ert-deftest hydra-compat-colors ()
+  (should (equal (hydra--head-color
+                  '("e" (message "Exiting now") "blue")
+                  '(nil nil :color blue))
+                 'blue))
+  (should (equal (hydra--head-color
+                  '("c" (message "Continuing") "red" :color red)
+                  '(nil nil :color blue))
+                 'red))
+  (should (equal (hydra--head-color
+                  '("e" (message "Exiting now") "blue")
+                  '(nil nil :exit t))
+                 'blue))
+  (should (equal (hydra--head-color
+                  '("c" (message "Continuing") "red" :exit nil)
+                  '(nil nil :exit t))
+                 'red)))
+
 (provide 'hydra-test)
 
 ;;; hydra-test.el ends here
diff --git a/hydra.el b/hydra.el
index 7658c76..1708fe7 100644
--- a/hydra.el
+++ b/hydra.el
@@ -239,26 +239,68 @@ Return DEFAULT if PROP is not in H."
         (plist-get plist prop)
       default)))
 
+(defun hydra--aggregate-color (head-color body-color)
+  "Return the resulting head color for HEAD-COLOR and BODY-COLOR."
+  (cond ((eq head-color 'red)
+         (cl-case body-color
+           (red 'red)
+           (blue 'red)
+           (amaranth 'amaranth)
+           (pink 'pink)
+           (cyan 'amaranth)))
+        ((eq head-color 'blue)
+         (cl-case body-color
+           (red 'blue)
+           (blue 'blue)
+           (amaranth 'teal)
+           (pink 'blue)
+           (cyan 'teal)))
+        (t
+         (error "Can't aggregate head %S to body %S"
+                head-color body-color))))
+
 (defun hydra--head-color (h body)
   "Return the color of a Hydra head H with BODY."
-  (let ((color (hydra--head-property h :color))
-        (exit (or (plist-get (cddr body) :exit)
-                  (hydra--head-property h :exit 'default)))
-        (nonheads (plist-get (cddr body) :nonheads)))
-    (cond ((null (cadr h))
-           'blue)
-          ((eq exit t)
-           'blue)
-          ((eq nonheads 'run)
-           'pink)
-          ((eq nonheads 'warn)
-           (if (eq exit t)
-               'teal
-             'amaranth))
-          ((null color)
-           (hydra--body-color body))
-          (t
-           color))))
+  (let* ((exit (hydra--head-property h :exit 'default))
+         (color (hydra--head-property h :color))
+         (head-color
+          (cond ((eq exit 'default)
+                 (cl-case color
+                   (blue 'blue)
+                   (red 'red)
+                   (t
+                    (unless (null color)
+                      (error "Use only :blue or :red for heads: %S" h)))))
+                ((null exit)
+                 (if color
+                     (error "Don't mix :color and :exit - they are aliases: 
%S" h)
+                   'red))
+                ((eq exit t)
+                 (if color
+                     (error "Don't mix :color and :exit - they are aliases: 
%S" h)
+                   'blue))
+                (t
+                 (error "Unknown :exit %S" exit)))))
+    (let ((nonheads (plist-get (cddr body) :nonheads))
+          (body-exit (plist-get (cddr body) :exit)))
+      (cond ((null (cadr h))
+             (if head-color
+                 (error "Extra properties for head with nil body: %S" h)
+               'blue))
+            ((null head-color)
+             (hydra--body-color body))
+            ((null nonheads)
+             head-color)
+            ((eq nonheads 'run)
+             (if (eq head-color 'red)
+                 'pink
+               'blue))
+            ((eq nonheads 'warn)
+             (if (eq head-color 'red)
+                 'amaranth
+               'teal))
+            (t
+             (error "Unexpected %S %S" h body))))))
 
 (defun hydra--body-color (body)
   "Return the color of BODY.