branch: master
commit 0a3cc60f5856eb4a38204b9075d67d058ba56bef
Author: Oleh Krehel <ohwoeo...@gmail.com>
Commit: Oleh Krehel <ohwoeo...@gmail.com>
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)
