]> code.delx.au - gnu-emacs-elpa/blob - packages/hydra/hydra.el
Merge commit '68bcaa8d8df5518217a3833fd1bb400c8225fe02' from hydra
[gnu-emacs-elpa] / packages / hydra / hydra.el
1 ;;; hydra.el --- Make bindings that stick around
2
3 ;; Copyright (C) 2015 Free Software Foundation, Inc.
4
5 ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
6 ;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
7 ;; URL: https://github.com/abo-abo/hydra
8 ;; Version: 0.8.0
9 ;; Keywords: bindings
10 ;; Package-Requires: ((cl-lib "0.5"))
11
12 ;; This file is part of GNU Emacs.
13
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.
18
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.
23
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/>.
26
27 ;;; Commentary:
28 ;;
29 ;; This package can be used to tie related commands into a family of
30 ;; short bindings with a common prefix - a Hydra.
31 ;;
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.
39 ;;
40 ;; Here's how to use the examples bundled with Hydra:
41 ;;
42 ;; (require 'hydra-examples)
43 ;; (hydra-create "C-M-y" hydra-example-move-window-splitter)
44 ;; (hydra-create "M-g" hydra-example-goto-error)
45 ;;
46 ;; You can expand the examples in-place, it still looks elegant:
47 ;;
48 ;; (hydra-create "<f2>"
49 ;; '(("g" text-scale-increase "zoom in")
50 ;; ("l" text-scale-decrease "zoom out")))
51 ;;
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.
54 ;;
55 ;; It's better to take the examples simply as templates and use
56 ;; `defhydra' instead of `hydra-create', since it's more flexible.
57 ;;
58 ;; (defhydra hydra-zoom (global-map "<f2>")
59 ;; "zoom"
60 ;; ("g" text-scale-increase "in")
61 ;; ("l" text-scale-decrease "out"))
62
63 ;;; Code:
64 ;;* Requires
65 (require 'cl-lib)
66
67 (defalias 'hydra-set-transient-map
68 (if (fboundp 'set-transient-map)
69 'set-transient-map
70 'set-temporary-overlay-map))
71
72 ;;* Customize
73 (defgroup hydra nil
74 "Make bindings that stick around."
75 :group 'bindings
76 :prefix "hydra-")
77
78 (defcustom hydra-is-helpful t
79 "When t, display a hint with possible bindings in the echo area."
80 :type 'boolean
81 :group 'hydra)
82
83 (defface hydra-face-red
84 '((t (:foreground "#7F0055" :bold t)))
85 "Red Hydra heads will persist indefinitely."
86 :group 'hydra)
87
88 (defface hydra-face-blue
89 '((t (:foreground "#758BC6" :bold t)))
90 "Blue Hydra heads will vanquish the Hydra.")
91
92 (defface hydra-face-amaranth
93 '((t (:foreground "#E52B50" :bold t)))
94 "Amaranth Hydra can exit only through a blue head.")
95
96 ;;* Universal Argument
97 (defvar hydra-base-map
98 (let ((map (make-sparse-keymap)))
99 (define-key map [?\C-u] 'hydra--universal-argument)
100 (define-key map [?-] 'hydra--negative-argument)
101 (define-key map [?0] 'hydra--digit-argument)
102 (define-key map [?1] 'hydra--digit-argument)
103 (define-key map [?2] 'hydra--digit-argument)
104 (define-key map [?3] 'hydra--digit-argument)
105 (define-key map [?4] 'hydra--digit-argument)
106 (define-key map [?5] 'hydra--digit-argument)
107 (define-key map [?6] 'hydra--digit-argument)
108 (define-key map [?7] 'hydra--digit-argument)
109 (define-key map [?8] 'hydra--digit-argument)
110 (define-key map [?9] 'hydra--digit-argument)
111 (define-key map [kp-0] 'hydra--digit-argument)
112 (define-key map [kp-1] 'hydra--digit-argument)
113 (define-key map [kp-2] 'hydra--digit-argument)
114 (define-key map [kp-3] 'hydra--digit-argument)
115 (define-key map [kp-4] 'hydra--digit-argument)
116 (define-key map [kp-5] 'hydra--digit-argument)
117 (define-key map [kp-6] 'hydra--digit-argument)
118 (define-key map [kp-7] 'hydra--digit-argument)
119 (define-key map [kp-8] 'hydra--digit-argument)
120 (define-key map [kp-9] 'hydra--digit-argument)
121 (define-key map [kp-subtract] 'hydra--negative-argument)
122 map)
123 "Keymap that all Hydras inherit. See `universal-argument-map'.")
124
125 (defvar hydra-curr-map
126 (make-sparse-keymap)
127 "Keymap of the current Hydra called.")
128
129 (defun hydra--universal-argument (arg)
130 "Forward to (`universal-argument' ARG)."
131 (interactive "P")
132 (setq prefix-arg (if (consp arg)
133 (list (* 4 (car arg)))
134 (if (eq arg '-)
135 (list -4)
136 '(4))))
137 (hydra-set-transient-map hydra-curr-map t))
138
139 (defun hydra--digit-argument (arg)
140 "Forward to (`digit-argument' ARG)."
141 (interactive "P")
142 (let ((universal-argument-map hydra-curr-map))
143 (digit-argument arg)))
144
145 (defun hydra--negative-argument (arg)
146 "Forward to (`negative-argument' ARG)."
147 (interactive "P")
148 (let ((universal-argument-map hydra-curr-map))
149 (negative-argument arg)))
150
151 ;;* Misc internals
152 (defvar hydra-last nil
153 "The result of the last `hydra-set-transient-map' call.")
154
155 (defun hydra--callablep (x)
156 "Test if X is callable."
157 (or (functionp x)
158 (and (consp x)
159 (memq (car x) '(function quote)))))
160
161 (defun hydra--color (h body-color)
162 "Return the color of a Hydra head H with BODY-COLOR."
163 (if (null (cadr h))
164 'blue
165 (let ((plist (if (stringp (cl-caddr h))
166 (cl-cdddr h)
167 (cddr h))))
168 (or (plist-get plist :color) body-color))))
169
170 (defun hydra--face (h body-color)
171 "Return the face for a Hydra head H with BODY-COLOR."
172 (cl-case (hydra--color h body-color)
173 (blue 'hydra-face-blue)
174 (red 'hydra-face-red)
175 (amaranth 'hydra-face-amaranth)
176 (t (error "Unknown color for %S" h))))
177
178 (defun hydra--hint (docstring heads body-color)
179 "Generate a hint from DOCSTRING and HEADS and BODY-COLOR.
180 It's intended for the echo area, when a Hydra is active."
181 (format "%s: %s."
182 docstring
183 (mapconcat
184 (lambda (h)
185 (format
186 (if (stringp (cl-caddr h))
187 (concat "[%s]: " (cl-caddr h))
188 "%s")
189 (propertize
190 (car h) 'face
191 (hydra--face h body-color))))
192 heads ", ")))
193
194 (defun hydra-disable ()
195 "Disable the current Hydra."
196 (cond
197 ;; Emacs 25
198 ((functionp hydra-last)
199 (funcall hydra-last))
200
201 ;; Emacs 24.4.1
202 ((boundp 'overriding-terminal-local-map)
203 (setq overriding-terminal-local-map nil))
204
205 ;; older
206 (t
207 (while (and (consp (car emulation-mode-map-alists))
208 (consp (caar emulation-mode-map-alists))
209 (equal (cl-cdaar emulation-mode-map-alists) ',keymap))
210 (setq emulation-mode-map-alists
211 (cdr emulation-mode-map-alists))))))
212
213 (defun hydra--doc (body-key body-name heads)
214 "Generate a part of Hydra docstring.
215 BODY-KEY is the body key binding.
216 BODY-NAME is the symbol that identifies the Hydra.
217 HEADS is a list of heads."
218 (format
219 "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
220 (if body-key
221 (format "a \"%s\"" body-key)
222 "no")
223 (mapconcat
224 (lambda (x)
225 (format "\"%s\": `%S'" (car x) (cadr x)))
226 heads ",\n")
227 (format "The body can be accessed via `%S'." body-name)))
228
229 ;;* Macros
230 ;;** hydra-create
231 ;;;###autoload
232 (defmacro hydra-create (body heads &optional method)
233 "Create a hydra with a BODY prefix and HEADS with METHOD.
234 This will result in `global-set-key' statements with the keys
235 being the concatenation of BODY and each head in HEADS. HEADS is
236 an list of (KEY FUNCTION &optional HINT).
237
238 After one of the HEADS is called via BODY+KEY, it and the other
239 HEADS can be called with only KEY (no need for BODY). This state
240 is broken once any key binding that is not in HEADS is called.
241
242 METHOD is a lambda takes two arguments: a KEY and a COMMAND.
243 It defaults to `global-set-key'.
244 When `(keymapp METHOD)`, it becomes:
245
246 (lambda (key command) (define-key METHOD key command))"
247 (declare (indent 1))
248 `(defhydra ,(intern
249 (concat
250 "hydra-" (replace-regexp-in-string " " "_" body)))
251 ,(cond ((hydra--callablep method)
252 method)
253 ((null method)
254 `(global-map ,body))
255 (t
256 (list method body)))
257 "hydra"
258 ,@(eval heads)))
259
260 ;;** defhydra
261 ;;;###autoload
262 (defmacro defhydra (name body &optional docstring &rest heads)
263 "Create a hydra named NAME with a prefix BODY.
264
265 NAME should be a symbol, it will be the prefix of all functions
266 defined here.
267
268 BODY should be either:
269
270 (BODY-MAP &optional BODY-KEY &rest PLIST)
271 or:
272
273 (lambda (KEY CMD) ...)
274
275 BODY-MAP should be a keymap; `global-map' is acceptable here.
276 BODY-KEY should be a string processable by `kbd'.
277
278 DOCSTRING will be displayed in the echo area to identify the
279 hydra.
280
281 HEADS is a list of (KEY CMD &optional HINT &rest PLIST).
282
283 PLIST in both cases recognizes only the :color key so far, which
284 in turn can be either red or blue."
285 (unless (stringp docstring)
286 (setq heads (cons docstring heads))
287 (setq docstring "hydra"))
288 (when (keywordp (car body))
289 (setq body (cons nil (cons nil body))))
290 (let* ((keymap (copy-keymap hydra-base-map))
291 (names (mapcar
292 (lambda (x)
293 (define-key keymap (kbd (car x))
294 (intern (format "%S/%s" name
295 (if (symbolp (cadr x))
296 (cadr x)
297 (concat "lambda-" (car x)))))))
298 heads))
299 (body-name (intern (format "%S/body" name)))
300 (body-key (unless (hydra--callablep body)
301 (cadr body)))
302 (body-color (if (hydra--callablep body)
303 'red
304 (or (plist-get (cddr body) :color)
305 'red)))
306 (body-pre (plist-get (cddr body) :pre))
307 (body-post (plist-get (cddr body) :post))
308 (method (if (hydra--callablep body)
309 body
310 (car body)))
311 (hint (hydra--hint docstring heads body-color))
312 (doc (hydra--doc body-key body-name heads)))
313 (when (and (or body-pre body-post)
314 (version< emacs-version "24.4"))
315 (error "At least Emacs 24.4 is needed for :pre and :post"))
316 (when (eq body-color 'amaranth)
317 (if (cl-some `(lambda (h)
318 (eq (hydra--color h ',body-color) 'blue))
319 heads)
320 (define-key keymap [t]
321 `(lambda ()
322 (interactive)
323 (message "An amaranth Hydra can only exit through a blue head")
324 (hydra-set-transient-map hydra-curr-map t)
325 (when hydra-is-helpful
326 (sit-for 0.8)
327 (message ,hint))))
328 (error "An amaranth Hydra must have at least one blue head in order to exit")))
329 `(progn
330 ,@(cl-mapcar
331 (lambda (head name)
332 `(defun ,name ()
333 ,(format "%s\n\nCall the head: `%S'." doc (cadr head))
334 (interactive)
335 ,@(if body-pre (list body-pre))
336 ,@(if (eq (hydra--color head body-color) 'blue)
337 `((hydra-disable)
338 ,@(unless (null (cadr head))
339 `((call-interactively #',(cadr head))))
340 ,@(if body-post (list body-post)))
341 `((catch 'hydra-disable
342 (hydra-disable)
343 (condition-case err
344 (prog1 t
345 (call-interactively #',(cadr head)))
346 ((debug error)
347 (message "%S" err)
348 (sit-for 0.8)
349 nil))
350 (when hydra-is-helpful
351 (message ,hint))
352 (setq hydra-last
353 (hydra-set-transient-map
354 (setq hydra-curr-map ',keymap)
355 t
356 ,@(if body-post `((lambda () ,body-post))))))))))
357 heads names)
358 ,@(unless (or (null body-key)
359 (null method)
360 (hydra--callablep method))
361 `((unless (keymapp (lookup-key ,method (kbd ,body-key)))
362 (define-key ,method (kbd ,body-key) nil))))
363 ,@(delq nil
364 (cl-mapcar
365 (lambda (head name)
366 (unless (or (null body-key) (null method))
367 (list
368 (if (hydra--callablep method)
369 'funcall
370 'define-key)
371 method
372 (vconcat (kbd body-key) (kbd (car head)))
373 (list 'function name))))
374 heads names))
375 (defun ,body-name ()
376 ,doc
377 (interactive)
378 ,@(if body-pre (list body-pre))
379 (when hydra-is-helpful
380 (message ,hint))
381 (setq hydra-last
382 (hydra-set-transient-map
383 ',keymap
384 t
385 ,@(if body-post `((lambda () ,body-post)))))))))
386
387 (provide 'hydra)
388
389 ;;; Local Variables:
390 ;;; outline-regexp: ";;\\*+"
391 ;;; End:
392
393 ;;; hydra.el ends here