1 ;;; hydra.el --- Make bindings that stick around
3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
5 ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
6 ;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
7 ;; URL: https://github.com/abo-abo/hydra
10 ;; Package-Requires: ((cl-lib "0.5"))
12 ;; This file is part of GNU Emacs.
14 ;; GNU Emacs is free software: you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation, either version 3 of the License, or
17 ;; (at your option) any later version.
19 ;; GNU Emacs is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
29 ;; This package can be used to tie related commands into a family of
30 ;; short bindings with a common prefix - a Hydra.
32 ;; Once you summon the Hydra (through the prefixed binding), all the
33 ;; heads can be called in succession with only a short extension.
34 ;; The Hydra is vanquished once Hercules, any binding that isn't the
35 ;; Hydra's head, arrives. Note that Hercules, besides vanquishing the
36 ;; Hydra, will still serve his orignal purpose, calling his proper
37 ;; command. This makes the Hydra very seamless, it's like a minor
38 ;; mode that disables itself automagically.
40 ;; Here's how to use the examples bundled with Hydra:
42 ;; (require 'hydra-examples)
43 ;; (hydra-create "C-M-y" hydra-example-move-window-splitter)
44 ;; (hydra-create "M-g" hydra-example-goto-error)
46 ;; You can expand the examples in-place, it still looks elegant:
48 ;; (hydra-create "<f2>"
49 ;; '(("g" text-scale-increase "zoom in")
50 ;; ("l" text-scale-decrease "zoom out")))
52 ;; The third element of each list is the optional doc string that will
53 ;; be displayed in the echo area when `hydra-is-helpful' is t.
55 ;; It's better to take the examples simply as templates and use
56 ;; `defhydra' instead of `hydra-create', since it's more flexible.
58 ;; (defhydra hydra-zoom (global-map "<f2>")
60 ;; ("g" text-scale-increase "in")
61 ;; ("l" text-scale-decrease "out"))
67 (defalias 'hydra-set-transient-map
68 (if (fboundp 'set-transient-map)
70 'set-temporary-overlay-map))
74 "Make bindings that stick around."
78 (defcustom hydra-is-helpful t
79 "When t, display a hint with possible bindings in the echo area."
83 (defface hydra-face-red
84 '((t (:foreground "#7F0055" :bold t)))
85 "Red Hydra heads will persist indefinitely."
88 (defface hydra-face-blue
89 '((t (:foreground "#758BC6" :bold t)))
90 "Blue Hydra heads will vanquish the Hydra.")
92 ;;* Universal Argument
93 (defvar hydra-base-map
94 (let ((map (make-sparse-keymap)))
95 (define-key map [?\C-u] 'hydra--universal-argument)
96 (define-key map [?-] 'hydra--negative-argument)
97 (define-key map [?0] 'hydra--digit-argument)
98 (define-key map [?1] 'hydra--digit-argument)
99 (define-key map [?2] 'hydra--digit-argument)
100 (define-key map [?3] 'hydra--digit-argument)
101 (define-key map [?4] 'hydra--digit-argument)
102 (define-key map [?5] 'hydra--digit-argument)
103 (define-key map [?6] 'hydra--digit-argument)
104 (define-key map [?7] 'hydra--digit-argument)
105 (define-key map [?8] 'hydra--digit-argument)
106 (define-key map [?9] 'hydra--digit-argument)
107 (define-key map [kp-0] 'hydra--digit-argument)
108 (define-key map [kp-1] 'hydra--digit-argument)
109 (define-key map [kp-2] 'hydra--digit-argument)
110 (define-key map [kp-3] 'hydra--digit-argument)
111 (define-key map [kp-4] 'hydra--digit-argument)
112 (define-key map [kp-5] 'hydra--digit-argument)
113 (define-key map [kp-6] 'hydra--digit-argument)
114 (define-key map [kp-7] 'hydra--digit-argument)
115 (define-key map [kp-8] 'hydra--digit-argument)
116 (define-key map [kp-9] 'hydra--digit-argument)
117 (define-key map [kp-subtract] 'hydra--negative-argument)
119 "Keymap that all Hydras inherit. See `universal-argument-map'.")
121 (defvar hydra-curr-map
123 "Keymap of the current Hydra called.")
125 (defun hydra--universal-argument (arg)
126 "Forward to (`universal-argument' ARG)."
128 (setq prefix-arg (if (consp arg)
129 (list (* 4 (car arg)))
133 (hydra-set-transient-map hydra-curr-map))
135 (defun hydra--digit-argument (arg)
136 "Forward to (`digit-argument' ARG)."
138 (let ((universal-argument-map hydra-curr-map))
139 (digit-argument arg)))
141 (defun hydra--negative-argument (arg)
142 "Forward to (`negative-argument' ARG)."
144 (let ((universal-argument-map hydra-curr-map))
145 (negative-argument arg)))
148 (defvar hydra-last nil
149 "The result of the last `hydra-set-transient-map' call.")
151 (defun hydra--callablep (x)
152 "Test if X is callable."
155 (memq (car x) '(function quote)))))
157 (defun hydra--color (h body-color)
158 "Return the color of a Hydra head H with BODY-COLOR."
161 (let ((plist (if (stringp (cl-caddr h))
164 (or (plist-get plist :color) body-color))))
166 (defun hydra--face (h body-color)
167 "Return the face for a Hydra head H with BODY-COLOR."
168 (cl-case (hydra--color h body-color)
169 (blue 'hydra-face-blue)
170 (red 'hydra-face-red)
171 (t (error "Unknown color for %S" h))))
173 (defun hydra--hint (docstring heads body-color)
174 "Generate a hint from DOCSTRING and HEADS and BODY-COLOR.
175 It's intended for the echo area, when a Hydra is active."
181 (if (stringp (cl-caddr h))
182 (concat "[%s]: " (cl-caddr h))
186 (hydra--face h body-color))))
189 (defun hydra-disable ()
190 "Disable the current Hydra."
193 ((functionp hydra-last)
194 (funcall hydra-last))
197 ((boundp 'overriding-terminal-local-map)
198 (setq overriding-terminal-local-map nil))
202 (while (and (consp (car emulation-mode-map-alists))
203 (consp (caar emulation-mode-map-alists))
204 (equal (cl-cdaar emulation-mode-map-alists) ',keymap))
205 (setq emulation-mode-map-alists
206 (cdr emulation-mode-map-alists))))))
208 (defun hydra--doc (body-key body-name heads)
209 "Generate a part of Hydra docstring.
210 BODY-KEY is the body key binding.
211 BODY-NAME is the symbol that identifies the Hydra.
212 HEADS is a list of heads."
214 "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
216 (format "a \"%s\"" body-key)
220 (format "\"%s\": `%S'" (car x) (cadr x)))
222 (format "The body can be accessed via `%S'." body-name)))
227 (defmacro hydra-create (body heads &optional method)
228 "Create a hydra with a BODY prefix and HEADS with METHOD.
229 This will result in `global-set-key' statements with the keys
230 being the concatenation of BODY and each head in HEADS. HEADS is
231 an list of (KEY FUNCTION &optional HINT).
233 After one of the HEADS is called via BODY+KEY, it and the other
234 HEADS can be called with only KEY (no need for BODY). This state
235 is broken once any key binding that is not in HEADS is called.
237 METHOD is a lambda takes two arguments: a KEY and a COMMAND.
238 It defaults to `global-set-key'.
239 When `(keymapp METHOD)`, it becomes:
241 (lambda (key command) (define-key METHOD key command))"
245 "hydra-" (replace-regexp-in-string " " "_" body)))
246 ,(cond ((hydra--callablep method)
257 (defmacro defhydra (name body &optional docstring &rest heads)
258 "Create a hydra named NAME with a prefix BODY.
260 NAME should be a symbol, it will be the prefix of all functions
263 BODY should be either:
265 (BODY-MAP &optional BODY-KEY &rest PLIST)
268 (lambda (KEY CMD) ...)
270 BODY-MAP should be a keymap; `global-map' is acceptable here.
271 BODY-KEY should be a string processable by `kbd'.
273 DOCSTRING will be displayed in the echo area to identify the
276 HEADS is a list of (KEY CMD &optional HINT &rest PLIST).
278 PLIST in both cases recognizes only the :color key so far, which
279 in turn can be either red or blue."
280 (unless (stringp docstring)
281 (setq heads (cons docstring heads))
282 (setq docstring "hydra"))
283 (when (keywordp (car body))
284 (setq body (cons nil (cons nil body))))
285 (let* ((keymap (copy-keymap hydra-base-map))
288 (define-key keymap (kbd (car x))
289 (intern (format "%S/%s" name
290 (if (symbolp (cadr x))
292 (concat "lambda-" (car x)))))))
294 (body-name (intern (format "%S/body" name)))
295 (body-key (unless (hydra--callablep body)
297 (body-color (if (hydra--callablep body)
299 (or (plist-get (cddr body) :color)
301 (method (if (hydra--callablep body)
304 (hint (hydra--hint docstring heads body-color))
305 (doc (hydra--doc body-key body-name heads)))
310 ,(format "%s\n\nCall the head: `%S'." doc (cadr head))
312 ,@(if (eq (hydra--color head body-color) 'blue)
314 ,@(unless (null (cadr head))
315 `((call-interactively #',(cadr head)))))
316 `((when hydra-is-helpful
319 (hydra-set-transient-map (setq hydra-curr-map ',keymap) t))
320 (call-interactively #',(cadr head))))))
322 ,@(unless (or (null body-key)
324 (hydra--callablep method))
325 `((unless (keymapp (lookup-key ,method (kbd ,body-key)))
326 (define-key ,method (kbd ,body-key) nil))))
330 (unless (or (null body-key) (null method))
332 (if (hydra--callablep method)
336 (vconcat (kbd body-key) (kbd (car head)))
337 (list 'function name))))
342 (when hydra-is-helpful
345 (hydra-set-transient-map ',keymap t))))))
350 ;;; outline-regexp: ";;\\*+"
353 ;;; hydra.el ends here