[elpa] master 0a3cc60 30/72: Add compat color-less syntax

[Oleh Krehel]

branch: master
commit 0a3cc60f5856eb4a38204b9075d67d058ba56bef
Author: Oleh Krehel <address@hidden>
Commit: Oleh Krehel <address@hidden>

    Add compat color-less syntax
    
    * hydra.el (hydra--head-color): Adapt compat switches.
    (hydra--body-color): Adapt compat switches.
    (hydra--handle-nonhead): Move verbatim from `defhydra'.
    (defhydra): Move verbatim to `hydra--handle-nonhead'.
    
    * README.md: Update with two tables.
    
    * hydra-test.el: Add compat tests.
    
    New compat switches are:
    
    - ":exit t" for ":color blue"
    - ":nonheads warn" for ":color amaranth"
    - ":nonheads warn :exit t" for ":color teal"
    - ":nonheads run" for ":color pink"
    
    See the compat tests to get the intuition of how both ways translate
    between each other.
    
    Fixes #27.
---
 README.md     |   31 +++++++++++++++++
 hydra-test.el |   82 +++++++++++++++++++++++++++++++++++++++++++++
 hydra.el      |  104 +++++++++++++++++++++++++++++++++++----------------------
 3 files changed, 177 insertions(+), 40 deletions(-)

diff --git a/README.md b/README.md
index 960684a..dbe8abb 100644
--- a/README.md
+++ b/README.md
@@ -277,3 +277,34 @@ Since version `0.10.0`, setting `hydra-lv` to `t` (the 
default setting) will mak
 window right above the Echo Area for hints. This has the advantage that you 
can immediately see
 any `message` output from the functions that you call, since Hydra no longer 
uses `message` to display
 the hint. You can still have the old behavior by setting `hydra-lv` to `nil`.
+
+## Color table
+
+
+Body     | Head      | Executing NON-HEADS   | Executing HEADS
+Color    | Inherited |                       |
+         | Color     |                       |
+---------|-----------|-----------------------|-----------------
+amaranth | red       | Disallow and Continue | Continue
+teal     | blue      | Disallow and Continue | Quit
+pink     | red       | Allow and Continue    | Continue
+red      | red       | Allow and Quit        | Continue
+blue     | blue      | Allow and Quit        | Quit
+
+## Color to toggle correspondence
+
+By popular demand, an alternative syntax has been implemented that translates 
to colors without
+using them in the syntax. `:exit` can be used both in body (heads will 
inherit) and in heads
+(possible to override body). `:exit` is nil by default, corresponding to `red` 
head; you don't need
+to set it explicitly to nil.  `:nonheads` can be used only in body and can be 
either nil (default),
+`warn` or `run`.
+
+| color    | toggle                 |
+|----------+------------------------|
+| red      |                        |
+| blue     | :exit t                |
+| amaranth | :nonheads warn         |
+| teal     | :nonheads warn :exit t |
+| pink     | :nonheads run          |
+
+
diff --git a/hydra-test.el b/hydra-test.el
index 96f02da..31519dc 100644
--- a/hydra-test.el
+++ b/hydra-test.el
@@ -591,6 +591,88 @@ The body can be accessed via `hydra-vi/body'."
                (setq hydra-test/num 0)
                (setq hydra-test/str "foo"))))))
 
+(ert-deftest hydra-blue-compat ()
+  (should
+   (equal
+    (macroexpand
+     '(defhydra hydra-toggle (:color blue)
+       "toggle"
+       ("t" toggle-truncate-lines "truncate")
+       ("f" auto-fill-mode "fill")
+       ("a" abbrev-mode "abbrev")
+       ("q" nil "cancel")))
+    (macroexpand
+     '(defhydra hydra-toggle (:exit t)
+       "toggle"
+       ("t" toggle-truncate-lines "truncate")
+       ("f" auto-fill-mode "fill")
+       ("a" abbrev-mode "abbrev")
+       ("q" nil "cancel"))))))
+
+(ert-deftest hydra-amaranth-compat ()
+  (unless (version< emacs-version "24.4")
+    (should
+     (equal
+      (macroexpand
+       '(defhydra hydra-vi
+         (:pre
+          (set-cursor-color "#e52b50")
+          :post
+          (set-cursor-color "#ffffff")
+          :color amaranth)
+         "vi"
+         ("j" next-line)
+         ("k" previous-line)
+         ("q" nil "quit")))
+      (macroexpand
+       '(defhydra hydra-vi
+         (:pre
+          (set-cursor-color "#e52b50")
+          :post
+          (set-cursor-color "#ffffff")
+          :nonheads warn)
+         "vi"
+         ("j" next-line)
+         ("k" previous-line)
+         ("q" nil "quit")))))))
+
+(ert-deftest hydra-pink-compat ()
+  (should
+   (equal
+    (macroexpand
+     '(defhydra hydra-zoom (global-map "<f2>"
+                            :color pink)
+       "zoom"
+       ("g" text-scale-increase "in")
+       ("l" text-scale-decrease "out")
+       ("q" nil "quit")))
+    (macroexpand
+     '(defhydra hydra-zoom (global-map "<f2>"
+                            :nonheads run)
+       "zoom"
+       ("g" text-scale-increase "in")
+       ("l" text-scale-decrease "out")
+       ("q" nil "quit"))))))
+
+(ert-deftest hydra-teal-compat ()
+  (should
+   (equal
+    (macroexpand
+     '(defhydra hydra-zoom (global-map "<f2>"
+                            :color teal)
+       "zoom"
+       ("g" text-scale-increase "in")
+       ("l" text-scale-decrease "out")
+       ("q" nil "quit")))
+    (macroexpand
+     '(defhydra hydra-zoom (global-map "<f2>"
+                            :nonheads warn
+                            :exit t)
+       "zoom"
+       ("g" text-scale-increase "in")
+       ("l" text-scale-decrease "out")
+       ("q" nil "quit"))))))
+
 (provide 'hydra-test)
 
 ;;; hydra-test.el ends here
diff --git a/hydra.el b/hydra.el
index a3024c4..67fe34c 100644
--- a/hydra.el
+++ b/hydra.el
@@ -225,18 +225,37 @@ Return DEFAULT if PROP is not in H."
 
 (defun hydra--head-color (h body-color)
   "Return the color of a Hydra head H with BODY-COLOR."
-  (let ((col (hydra--head-property h :color)))
+  (let ((color (hydra--head-property h :color))
+        (exit (hydra--head-property h :exit 'default))
+        (nonheads (plist-get (cddr body) :nonheads)))
     (cond ((null (cadr h))
            'blue)
-          ((null col)
+          ((eq exit t)
+           'blue)
+          ((null exit)
+           (cond ((eq nonheads 'warn)
+                  'amaranth)
+                 ((eq nonheads 'run)
+                  'pink)
+                 (t
+                  'red)))
+          ((null color)
            body-color)
           (t
-           col))))
+           color))))
 
 (defun hydra--body-color (body)
   "Return the color of BODY.
 BODY is the second argument to `defhydra'"
-  (or (plist-get (cddr body) :color) 'red))
+  (let ((color (plist-get (cddr body) :color))
+        (exit (plist-get (cddr body) :exit))
+        (nonheads (plist-get (cddr body) :nonheads)))
+    (cond ((eq nonheads 'warn)
+           (if exit 'teal 'amaranth))
+          ((eq nonheads 'run) 'pink)
+          (exit 'blue)
+          (color color)
+          (t 'red))))
 
 (defun hydra--face (h body-color)
   "Return the face for a Hydra head H with BODY-COLOR."
@@ -418,6 +437,46 @@ BODY-COLOR, BODY-PRE, BODY-POST, and OTHER-POST are used 
as well."
           (message "Pink Hydra can't currently handle prefixes, continuing"))
       (message "Pink Hydra could not resolve: %S" keys))))
 
+(defun hydra--handle-nonhead (body heads keymap hint-name)
+  (let ((body-color (hydra--body-color body))
+        (body-post (plist-get (cddr body) :post)))
+    (when (memq body-color '(amaranth pink teal))
+      (if (cl-some `(lambda (h)
+                      (eq (hydra--head-color h ',body-color) 'blue))
+                   heads)
+          (progn
+            ;; (when (cl-some `(lambda (h)
+            ;;                   (eq (hydra--head-color h ',body-color) 'red))
+            ;;                heads)
+            ;;   (warn
+            ;;    "%S body color: upgrading all red heads to %S"
+            ;;    body-color body-color))
+            (define-key keymap [t]
+              `(lambda ()
+                 (interactive)
+                 ,(cond
+                   ((eq body-color 'amaranth)
+                    '(message "An amaranth Hydra can only exit through a blue 
head"))
+                   ((eq body-color 'teal)
+                    '(message "A teal Hydra can only exit through a blue 
head"))
+                   (t
+                    '(hydra-pink-fallback)))
+                 (hydra-set-transient-map hydra-curr-map t)
+                 (when hydra-is-helpful
+                   (unless hydra-lv
+                     (sit-for 0.8))
+                   (,hint-name)))))
+        (error
+         "An %S Hydra must have at least one blue head in order to exit"
+         body-color))
+      (when hydra-keyboard-quit
+        (define-key keymap hydra-keyboard-quit
+          `(lambda ()
+             (interactive)
+             (hydra-disable)
+             (hydra-cleanup)
+             ,body-post))))))
+
 ;;* Macros
 ;;** defhydra
 ;;;###autoload
@@ -503,42 +562,7 @@ result of `defhydra'."
       (setq body-pre `(funcall #',body-pre)))
     (when (and body-post (symbolp body-post))
       (setq body-post `(funcall #',body-post)))
-    (when (memq body-color '(amaranth pink teal))
-      (if (cl-some `(lambda (h)
-                      (eq (hydra--head-color h ',body-color) 'blue))
-                   heads)
-          (progn
-            (when (cl-some `(lambda (h)
-                              (eq (hydra--head-color h ',body-color) 'red))
-                           heads)
-              (warn
-               "%S body color: upgrading all red heads to %S"
-               body-color body-color))
-            (define-key keymap [t]
-              `(lambda ()
-                 (interactive)
-                 ,@(cond
-                    ((eq body-color 'amaranth)
-                     '((message "An amaranth Hydra can only exit through a 
blue head")))
-                    ((eq body-color 'teal)
-                     '((message "A teal Hydra can only exit through a blue 
head")))
-                    (t
-                     '((hydra-pink-fallback))))
-                 (hydra-set-transient-map hydra-curr-map t)
-                 (when hydra-is-helpful
-                   (unless hydra-lv
-                     (sit-for 0.8))
-                   (,hint-name)))))
-        (error
-         "An %S Hydra must have at least one blue head in order to exit"
-         body-color))
-      (when hydra-keyboard-quit
-        (define-key keymap hydra-keyboard-quit
-          `(lambda ()
-             (interactive)
-             (hydra-disable)
-             (hydra-cleanup)
-             ,body-post))))
+    (hydra--handle-nonhead body heads keymap hint-name)
     `(progn
        ,@(cl-mapcar
           (lambda (head name)