Distinguish red and blue hydra heads

abo-abo · abo-abo · commit 6f142e342a42 · 2015-02-01T21:30:27.000+01:00
* hydra.el (hydra-face-red): New face.
(hydra-face-blue): New face.

(hydra--color): Each head now has a color: red is persistent, blue is
single-use. Head color inherits body color if it's not explicitly
overridden. Body color is red unless explicitly stated.

(hydra--face): Return face that corresponds to color.
(hydra--hint): New function, moved out of `defhydra'.
(hydra-disable): New function, moved out of `defhydra'.
(hydra--doc): New function, moved out of `defhydra'.

(defhydra): Commands that will vanquish the Hydra should be colored with
`hydra-face-blue'. The ones that will make the Hydra persist should be
colored with `hydra-face-red'.
Add autoload, move some code outside, Test HEAD's second element with
`null' instead of `functionp'.

* hydra-test.el (defhydra-red-error): Rename from `defhydra'.
(hydra-blue-toggle): Add test.

* README.md: Update.

Example:

    (global-set-key
     (kbd "C-c C-v")
     (defhydra toggle ()
       "toggle"
       ("t" toggle-truncate-lines "truncate" :color blue)
       ("f" auto-fill-mode "fill" :color blue)
       ("a" abbrev-mode "abbrev" :color blue)
       ("q" nil "cancel")))

Alternatively, since heads inherit color from the body:

    (global-set-key
     (kbd "C-c C-v")
     (defhydra toggle (:color blue)
       "toggle"
       ("a" abbrev-mode "abbrev")
       ("d" toggle-debug-on-error "debug")
       ("f" auto-fill-mode "fill")
       ("t" toggle-truncate-lines "truncate")
       ("w" whitespace-mode "whitespace")
       ("q" nil "cancel")))
diff --git a/README.md b/README.md
@@ -4,6 +4,8 @@ This is a package for GNU Emacs that can be used to tie related
 commands into a family of short bindings with a common prefix - a
 Hydra.
 
+![hydra](http://oremacs.com/download/Hydra.png)
+
 Once you summon the Hydra through the prefixed binding (the body + any
 one head), all heads can be called in succession with only a short
 extension.
@@ -14,6 +16,8 @@ Hydra, will still serve his orignal purpose, calling his proper
 command.  This makes the Hydra very seamless, it's like a minor mode
 that disables itself auto-magically.
 
+## Simplified usage
+
 Here's how to quickly bind the examples bundled with Hydra:
 
 ```cl
@@ -23,6 +27,8 @@ Here's how to quickly bind the examples bundled with Hydra:
 (hydra-create "<f2>" hydra-example-text-scale)
 ```
 
+## Using Hydra for global bindings
+
 But it's much better to just take the examples as a template and write
 down everything explicitly:
 
@@ -51,7 +57,8 @@ it like this:
   ("l" text-scale-decrease "out")))
 ```
 
-If you like key chords so much that you don't want to touch the global map at all, you can e.g.:
+If you like key chords so much that you don't want to touch the global
+map at all, you can e.g.:
 
 ```
 (key-chord-define-global
@@ -68,9 +75,7 @@ You can also substitute `global-map` with any other keymap, like
 
 See the [introductory blog post](http://oremacs.com/2015/01/20/introducing-hydra/) for more information.
 
-![hydra](http://oremacs.com/download/Hydra.png)
-
-## Using Hydra to define bindings other than global ones
+## Using Hydra for major-mode or minor-mode bindings
 
 Here's an example:
 
@@ -104,3 +109,57 @@ can even add comments to the heads like this:
 
 With this, you'll see `zoom: [g]: in, [l]: out.` in your echo area,
 once the zoom Hydra becomes active.
+
+## Colorful Hydras
+
+Since version `0.5.0`, Hydra's heads all have a color associated with them:
+
+- *red* (default) means the calling this head will not vanquish the Hydra
+- *blue* means that the Hydra will be vanquished after calling this head
+
+In all the older examples, all heads are red by default. You can specify blue heads like this:
+
+```cl
+(global-set-key
+ (kbd "C-c C-v")
+ (defhydra toggle ()
+   "toggle"
+   ("a" abbrev-mode "abbrev" :color blue)
+   ("d" toggle-debug-on-error "debug" :color blue)
+   ("f" auto-fill-mode "fill" :color blue)
+   ("t" toggle-truncate-lines "truncate" :color blue)
+   ("w" whitespace-mode "whitespace" :color blue)
+   ("q" nil "cancel")))
+```
+
+Or, since the heads can inherit the color from the body, the following is equivalent:
+
+```cl
+(global-set-key
+ (kbd "C-c C-v")
+ (defhydra toggle (:color blue)
+   "toggle"
+   ("a" abbrev-mode "abbrev")
+   ("d" toggle-debug-on-error "debug")
+   ("f" auto-fill-mode "fill")
+   ("t" toggle-truncate-lines "truncate")
+   ("w" whitespace-mode "whitespace")
+   ("q" nil "cancel")))
+```
+
+The above Hydra is very similar to this code:
+
+```cl
+(global-set-key (kbd "C-c C-v t") 'toggle-truncate-lines)
+(global-set-key (kbd "C-c C-v f") 'auto-fill-mode)
+(global-set-key (kbd "C-c C-v a") 'abbrev-mode)
+```
+
+However, there are two important differences:
+
+- you get a hint like this right after <kbd>C-c C-v</kbd>:
+
+        toggle: [t]: truncate, [f]: fill, [a]: abbrev, [q]: cancel.
+
+- you can cancel <kbd>C-c C-v</kbd> with a command while executing that command, instead of e.g.
+getting an error `C-c C-v C-n is undefined` for <kbd>C-c C-v C-n</kbd>.
diff --git a/hydra-test.el b/hydra-test.el
@@ -1,6 +1,6 @@
 (require 'ert)
 
-(ert-deftest defhydra ()
+(ert-deftest defhydra-red-error ()
   (should
    (equal
     (macroexpand
@@ -109,4 +109,94 @@ The body can be accessed via `hydra-error/body'."
                  (106 . hydra-error/next-error)
                  (104 . hydra-error/first-error)) t)))))))
 
+(ert-deftest hydra-blue-toggle ()
+  (should
+   (equal
+    (macroexpand
+     '(defhydra toggle (:color blue)
+       "toggle"
+       ("t" toggle-truncate-lines "truncate")
+       ("f" auto-fill-mode "fill")
+       ("a" abbrev-mode "abbrev")
+       ("q" nil "cancel")))
+    '(progn
+      (defun toggle/toggle-truncate-lines ()
+        "Create a hydra with no body and the heads:
+
+\"t\":    `toggle-truncate-lines',
+\"f\":    `auto-fill-mode',
+\"a\":    `abbrev-mode',
+\"q\":    `nil'
+
+The body can be accessed via `toggle/body'.
+
+Call the head: `toggle-truncate-lines'."
+        (interactive)
+        (hydra-disable)
+        (call-interactively #'toggle-truncate-lines))
+      (defun toggle/auto-fill-mode ()
+        "Create a hydra with no body and the heads:
+
+\"t\":    `toggle-truncate-lines',
+\"f\":    `auto-fill-mode',
+\"a\":    `abbrev-mode',
+\"q\":    `nil'
+
+The body can be accessed via `toggle/body'.
+
+Call the head: `auto-fill-mode'."
+        (interactive)
+        (hydra-disable)
+        (call-interactively #'auto-fill-mode))
+      (defun toggle/abbrev-mode ()
+        "Create a hydra with no body and the heads:
+
+\"t\":    `toggle-truncate-lines',
+\"f\":    `auto-fill-mode',
+\"a\":    `abbrev-mode',
+\"q\":    `nil'
+
+The body can be accessed via `toggle/body'.
+
+Call the head: `abbrev-mode'."
+        (interactive)
+        (hydra-disable)
+        (call-interactively #'abbrev-mode))
+      (defun toggle/nil ()
+        "Create a hydra with no body and the heads:
+
+\"t\":    `toggle-truncate-lines',
+\"f\":    `auto-fill-mode',
+\"a\":    `abbrev-mode',
+\"q\":    `nil'
+
+The body can be accessed via `toggle/body'.
+
+Call the head: `nil'."
+        (interactive)
+        (hydra-disable))
+      (defun toggle/body ()
+        "Create a hydra with no body and the heads:
+
+\"t\":    `toggle-truncate-lines',
+\"f\":    `auto-fill-mode',
+\"a\":    `abbrev-mode',
+\"q\":    `nil'
+
+The body can be accessed via `toggle/body'."
+        (interactive)
+        (when hydra-is-helpful
+          (message #("toggle: [t]: truncate, [f]: fill, [a]: abbrev, [q]: cancel."
+                     9 10 (face hydra-face-blue)
+                     24 25 (face hydra-face-blue)
+                     35 36 (face hydra-face-blue)
+                     48 49 (face hydra-face-blue))))
+        (setq hydra-last
+              (hydra-set-transient-map
+               '(keymap (113 . toggle/nil)
+                 (97 . toggle/abbrev-mode)
+                 (102 . toggle/auto-fill-mode)
+                 (116 . toggle/toggle-truncate-lines))
+               t)))))))
+
 (provide 'hydra-test)
diff --git a/hydra.el b/hydra.el
@@ -5,7 +5,7 @@
 ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
 ;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
 ;; URL: https://github.com/abo-abo/hydra
-;; Version: 0.4.1
+;; Version: 0.5.0
 ;; Keywords: bindings
 ;; Package-Requires: ((cl-lib "0.5"))
 
@@ -73,6 +73,15 @@
   :type 'boolean
   :group 'hydra)
 
+(defface hydra-face-red
+    '((t (:foreground "#7F0055" :bold t)))
+  "Red Hydra heads will persist indefinitely."
+  :group 'hydra)
+
+(defface hydra-face-blue
+    '((t (:foreground "#758BC6" :bold t)))
+  "Blue Hydra heads will vanquish the Hydra.")
+
 (defalias 'hydra-set-transient-map
   (if (fboundp 'set-transient-map)
       'set-transient-map
@@ -111,11 +120,70 @@ When `(keymapp METHOD)`, it becomes:
      ,@(eval heads)))
 
 (defun hydra--callablep (x)
-  "Test if X looks like it's callable."
+  "Test if X is callable."
   (or (functionp x)
       (and (consp x)
            (memq (car x) '(function quote)))))
 
+(defun hydra--color (h body-color)
+  "Return the color of a Hydra head H with BODY-COLOR."
+  (if (null (cadr h))
+      'blue
+    (let ((plist (if (stringp (cl-caddr h))
+                     (cl-cdddr h)
+                   (cddr h))))
+      (or (plist-get plist :color) body-color))))
+
+(defun hydra--face (h body-color)
+  "Return the face for a Hydra head H with BODY-COLOR."
+  (cl-case (hydra--color h body-color)
+    (blue 'hydra-face-blue)
+    (red 'hydra-face-red)
+    (t (error "Unknown color for %S" h))))
+
+(defun hydra--hint (docstring heads)
+  "Generate a hint from DOCSTRING and HEADS.
+It's intended for the echo area, when a Hydra is active."
+  (format "%s: %s."
+          docstring
+          (mapconcat
+           (lambda (h)
+             (format
+              (if (stringp (cl-caddr h))
+                  (concat "[%s]: " (cl-caddr h))
+                "%s")
+              (propertize
+               (car h) 'face
+               (hydra--face h body-color))))
+           heads ", ")))
+
+(defun hydra-disable ()
+  "Disable the current Hydra."
+  (if (functionp hydra-last)
+      (funcall hydra-last)
+    (while (and (consp (car emulation-mode-map-alists))
+                (consp (caar emulation-mode-map-alists))
+                (equal (cl-cdaar emulation-mode-map-alists) ',keymap))
+      (setq emulation-mode-map-alists
+            (cdr emulation-mode-map-alists)))))
+
+(defun hydra--doc (body-key body-name heads)
+  "Generate a part of Hydra docstring.
+BODY-KEY is the body key binding.
+BODY-NAME is the symbol that identifies the Hydra.
+HEADS is a list of heads."
+  (format
+   "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
+   (if body-key
+       (format "a \"%s\"" body-key)
+     "no")
+   (mapconcat
+    (lambda (x)
+      (format "\"%s\":    `%S'" (car x) (cadr x)))
+    heads ",\n")
+   (format "The body can be accessed via `%S'." body-name)))
+
+;;;###autoload
 (defmacro defhydra (name body &optional docstring &rest heads)
   "Create a hydra named NAME with a prefix BODY.
 
@@ -124,7 +192,7 @@ defined here.
 
 BODY should be either:
 
-    (BODY-MAP &optional BODY-KEY)
+    (BODY-MAP &optional BODY-KEY &rest PLIST)
 or:
 
     (lambda (KEY CMD) ...)
@@ -135,10 +203,15 @@ BODY-KEY should be a string processable by `kbd'.
 DOCSTRING will be displayed in the echo area to identify the
 hydra.
 
-HEADS is a list of (KEY CMD &optional HINT)."
+HEADS is a list of (KEY CMD &optional HINT &rest PLIST).
+
+PLIST in both cases recognizes only the :color key so far, which
+in turn can be either red or blue."
   (unless (stringp docstring)
     (setq heads (cons docstring heads))
     (setq docstring "hydra"))
+  (when (keywordp (car body))
+    (setq body (cons nil (cons nil body))))
   (let* ((keymap (make-sparse-keymap))
          (names (mapcar
                  (lambda (x)
@@ -148,43 +221,25 @@ HEADS is a list of (KEY CMD &optional HINT)."
          (body-name (intern (format "%S/body" name)))
          (body-key (unless (hydra--callablep body)
                      (cadr body)))
+         (body-color (if (hydra--callablep body)
+                         'red
+                       (or (plist-get (cddr body) :color)
+                           'red)))
          (method (if (hydra--callablep body)
                      body
                    (car body)))
-         (hint (format "%s: %s."
-                       docstring
-                       (mapconcat
-                        (lambda (h)
-                          (format
-                           (if (cl-caddr h)
-                               (concat "[%s]: " (cl-caddr h))
-                             "%s")
-                           (propertize (car h) 'face 'font-lock-keyword-face)))
-                        heads ", ")))
-         (doc (format
-               "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
-               (if body-key
-                   (format "a \"%s\"" body-key)
-                 "no")
-               (mapconcat
-                (lambda (x)
-                  (format "\"%s\":    `%S'" (car x) (cadr x)))
-                heads ",\n")
-               (format "The body can be accessed via `%S'." body-name))))
+         (hint (hydra--hint docstring heads))
+         (doc (hydra--doc body-key body-name heads)))
     `(progn
        ,@(cl-mapcar
           (lambda (head name)
             `(defun ,name ()
                ,(format "%s\n\nCall the head: `%S'." doc (cadr head))
                (interactive)
-               ,@(if (null (cadr head))
-                     `((if (functionp hydra-last)
-                           (funcall hydra-last)
-                         (while (and (consp (car emulation-mode-map-alists))
-                                     (consp (caar emulation-mode-map-alists))
-                                     (equal (cl-cdaar emulation-mode-map-alists) ',keymap))
-                           (setq emulation-mode-map-alists
-                                 (cdr emulation-mode-map-alists)))))
+               ,@(if (eq (hydra--color head body-color) 'blue)
+                     `((hydra-disable)
+                       ,@(unless (null (cadr head))
+                                 `((call-interactively #',(cadr head)))))
                      `((call-interactively #',(cadr head))
                        (when hydra-is-helpful
                          (message ,hint))
