1 ;;; hydra.el --- Make bindings that stick around. -*- lexical-binding: t -*-
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 an example Hydra, bound in the global map (you can use any
41 ;; keymap in place of `global-map'):
43 ;; (defhydra hydra-zoom (global-map "<f2>")
45 ;; ("g" text-scale-increase "in")
46 ;; ("l" text-scale-decrease "out"))
48 ;; It allows to start a command chain either like this:
49 ;; "<f2> gg4ll5g", or "<f2> lgllg".
51 ;; Here's another approach, when you just want a "callable keymap":
53 ;; (defhydra hydra-toggle (:color blue)
55 ;; ("a" abbrev-mode "abbrev")
56 ;; ("d" toggle-debug-on-error "debug")
57 ;; ("f" auto-fill-mode "fill")
58 ;; ("t" toggle-truncate-lines "truncate")
59 ;; ("w" whitespace-mode "whitespace")
60 ;; ("q" nil "cancel"))
62 ;; This binds nothing so far, but if you follow up with:
64 ;; (global-set-key (kbd "C-c C-v") 'hydra-toggle/body)
66 ;; you will have bound "C-c C-v a", "C-c C-v d" etc.
68 ;; Knowing that `defhydra' defines e.g. `hydra-toggle/body' command,
69 ;; you can nest Hydras if you wish, with `hydra-toggle/body' possibly
70 ;; becoming a blue head of another Hydra.
72 ;; Initially, Hydra shipped with a simplified `hydra-create' macro, to
73 ;; which you could hook up the examples from hydra-examples.el. It's
74 ;; better to take the examples simply as templates and use `defhydra'
75 ;; instead of `hydra-create', since it's more flexible.
82 (defvar hydra-curr-map nil
83 "The keymap of the current Hydra called.")
85 (defvar hydra-curr-on-exit nil
86 "The on-exit predicate for the current Hydra.")
88 (defvar hydra-curr-foreign-keys nil
89 "The current :foreign-keys behavior.")
91 (defvar hydra-curr-body-fn nil
92 "The current hydra-.../body function.")
94 (defvar hydra-deactivate nil
95 "If a Hydra head sets this to t, exit the Hydra.
96 This will be done even if the head wasn't designated for exiting.")
98 (defun hydra-set-transient-map (keymap on-exit &optional foreign-keys)
99 "Set KEYMAP to the highest priority.
101 Call ON-EXIT when the KEYMAP is deactivated.
103 FOREIGN-KEYS determines the deactivation behavior, when a command
104 that isn't in KEYMAP is called:
106 nil: deactivate KEYMAP and run the command.
107 run: keep KEYMAP and run the command.
108 warn: keep KEYMAP and issue a warning instead of running the command."
110 (hydra-keyboard-quit)
111 (setq hydra-curr-map keymap)
112 (setq hydra-curr-on-exit on-exit)
113 (setq hydra-curr-foreign-keys foreign-keys)
114 (add-hook 'pre-command-hook 'hydra--clearfun)
115 (internal-push-keymap keymap 'overriding-terminal-local-map)))
117 (defun hydra--clearfun ()
118 "Disable the current Hydra unless `this-command' is a head."
119 (unless (eq this-command 'hydra-pause-resume)
121 (memq this-command '(handle-switch-frame
123 (null overriding-terminal-local-map)
124 (not (or (eq this-command
125 (lookup-key hydra-curr-map (this-single-command-keys)))
126 (cl-case hydra-curr-foreign-keys
128 (setq this-command 'hydra-amaranth-warn))
134 (defvar hydra--ignore nil
135 "When non-nil, don't call `hydra-curr-on-exit'.")
137 (defvar hydra--input-method-function nil
138 "Store overridden `input-method-function' here.")
140 (defun hydra-disable ()
141 "Disable the current Hydra."
142 (setq hydra-deactivate nil)
143 (remove-hook 'pre-command-hook 'hydra--clearfun)
144 (if (fboundp 'remove-function)
145 (remove-function input-method-function #'hydra--imf)
146 (when hydra--input-method-function
147 (setq input-method-function hydra--input-method-function)
148 (setq hydra--input-method-function nil)))
149 (dolist (frame (frame-list))
150 (with-selected-frame frame
151 (when overriding-terminal-local-map
152 (internal-pop-keymap hydra-curr-map 'overriding-terminal-local-map))))
153 (unless hydra--ignore
154 (when hydra-curr-on-exit
155 (let ((on-exit hydra-curr-on-exit))
156 (setq hydra-curr-on-exit nil)
157 (funcall on-exit)))))
159 (unless (fboundp 'internal-push-keymap)
160 (defun internal-push-keymap (keymap symbol)
161 (let ((map (symbol-value symbol)))
162 (unless (memq keymap map)
163 (unless (memq 'add-keymap-witness (symbol-value symbol))
164 (setq map (make-composed-keymap nil (symbol-value symbol)))
165 (push 'add-keymap-witness (cdr map))
167 (push keymap (cdr map))))))
169 (unless (fboundp 'internal-pop-keymap)
170 (defun internal-pop-keymap (keymap symbol)
171 (let ((map (symbol-value symbol)))
172 (when (memq keymap map)
173 (setf (cdr map) (delq keymap (cdr map))))
174 (let ((tail (cddr map)))
175 (and (or (null tail) (keymapp tail))
176 (eq 'add-keymap-witness (nth 1 map))
177 (set symbol tail))))))
179 (defun hydra-amaranth-warn ()
180 "Issue a warning that the current input was ignored."
182 (message "An amaranth Hydra can only exit through a blue head"))
186 "Make bindings that stick around."
190 (defcustom hydra-is-helpful t
191 "When t, display a hint with possible bindings in the echo area."
195 (defcustom hydra-lv t
196 "When non-nil, `lv-message' (not `message') will be used to display hints."
199 (defcustom hydra-verbose nil
200 "When non-nil, hydra will issue some non essential style warnings."
203 (defcustom hydra-key-format-spec "%s"
204 "Default `format'-style specifier for _a_ syntax in docstrings.
205 When nil, you can specify your own at each location like this: _ 5a_.")
207 (make-obsolete-variable
208 'hydra-key-format-spec
209 "Since the docstrings are aligned by hand anyway, this isn't very useful."
212 (defface hydra-face-red
213 '((t (:foreground "#FF0000" :bold t)))
214 "Red Hydra heads don't exit the Hydra.
215 Every other command exits the Hydra."
218 (defface hydra-face-blue
219 '((((class color) (background light))
220 :foreground "#0000FF" :bold t)
221 (((class color) (background dark))
222 :foreground "#8ac6f2" :bold t))
223 "Blue Hydra heads exit the Hydra.
224 Every other command exits as well.")
226 (defface hydra-face-amaranth
227 '((t (:foreground "#E52B50" :bold t)))
228 "Amaranth body has red heads and warns on intercepting non-heads.
229 Exitable only through a blue head.")
231 (defface hydra-face-pink
232 '((t (:foreground "#FF6EB4" :bold t)))
233 "Pink body has red heads and runs intercepted non-heads.
234 Exitable only through a blue head.")
236 (defface hydra-face-teal
237 '((t (:foreground "#367588" :bold t)))
238 "Teal body has blue heads and warns on intercepting non-heads.
239 Exitable only through a blue head.")
242 (defun hydra-add-font-lock ()
243 "Fontify `defhydra' statements."
244 (font-lock-add-keywords
246 '(("(\\(defhydra\\)\\_> +\\(.*?\\)\\_>"
247 (1 font-lock-keyword-face)
248 (2 font-lock-type-face))
249 ("(\\(defhydradio\\)\\_> +\\(.*?\\)\\_>"
250 (1 font-lock-keyword-face)
251 (2 font-lock-type-face)))))
254 (eval-after-load 'find-func
255 '(defadvice find-function-search-for-symbol
256 (around hydra-around-find-function-search-for-symbol-advice
257 (symbol type library) activate)
258 "Navigate to hydras with `find-function-search-for-symbol'."
260 ;; The orignial function returns (cons (current-buffer) (point))
261 ;; if it found the point.
262 (unless (cdr ad-return-value)
263 (with-current-buffer (find-file-noselect library)
264 (let ((sn (symbol-name symbol)))
265 (when (and (null type)
266 (string-match "\\`\\(hydra-[a-z-A-Z0-9]+\\)/\\(.*\\)\\'" sn)
267 (re-search-forward (concat "(defhydra " (match-string 1 sn))
269 (goto-char (match-beginning 0)))
270 (cons (current-buffer) (point)))))))
272 ;;* Universal Argument
273 (defvar hydra-base-map
274 (let ((map (make-sparse-keymap)))
275 (define-key map [?\C-u] 'hydra--universal-argument)
276 (define-key map [?-] 'hydra--negative-argument)
277 (define-key map [?0] 'hydra--digit-argument)
278 (define-key map [?1] 'hydra--digit-argument)
279 (define-key map [?2] 'hydra--digit-argument)
280 (define-key map [?3] 'hydra--digit-argument)
281 (define-key map [?4] 'hydra--digit-argument)
282 (define-key map [?5] 'hydra--digit-argument)
283 (define-key map [?6] 'hydra--digit-argument)
284 (define-key map [?7] 'hydra--digit-argument)
285 (define-key map [?8] 'hydra--digit-argument)
286 (define-key map [?9] 'hydra--digit-argument)
287 (define-key map [kp-0] 'hydra--digit-argument)
288 (define-key map [kp-1] 'hydra--digit-argument)
289 (define-key map [kp-2] 'hydra--digit-argument)
290 (define-key map [kp-3] 'hydra--digit-argument)
291 (define-key map [kp-4] 'hydra--digit-argument)
292 (define-key map [kp-5] 'hydra--digit-argument)
293 (define-key map [kp-6] 'hydra--digit-argument)
294 (define-key map [kp-7] 'hydra--digit-argument)
295 (define-key map [kp-8] 'hydra--digit-argument)
296 (define-key map [kp-9] 'hydra--digit-argument)
297 (define-key map [kp-subtract] 'hydra--negative-argument)
299 "Keymap that all Hydras inherit. See `universal-argument-map'.")
301 (defun hydra--universal-argument (arg)
302 "Forward to (`universal-argument' ARG)."
304 (setq prefix-arg (if (consp arg)
305 (list (* 4 (car arg)))
310 (defun hydra--digit-argument (arg)
311 "Forward to (`digit-argument' ARG)."
313 (let* ((char (if (integerp last-command-event)
315 (get last-command-event 'ascii-character)))
316 (digit (- (logand char ?\177) ?0)))
317 (setq prefix-arg (cond ((integerp arg)
329 (defun hydra--negative-argument (arg)
330 "Forward to (`negative-argument' ARG)."
332 (setq prefix-arg (cond ((integerp arg) (- arg))
337 (defvar hydra-repeat--prefix-arg nil
338 "Prefix arg to use with `hydra-repeat'.")
340 (defvar hydra-repeat--command nil
341 "Command to use with `hydra-repeat'.")
343 (defun hydra-repeat (&optional arg)
344 "Repeat last command with last prefix arg.
345 When ARG is non-nil, use that instead."
348 (unless (string-match "hydra-repeat$" (symbol-name last-command))
349 (setq hydra-repeat--command last-command)
350 (setq hydra-repeat--prefix-arg last-prefix-arg))
351 (setq hydra-repeat--prefix-arg arg))
352 (setq current-prefix-arg hydra-repeat--prefix-arg)
353 (funcall hydra-repeat--command))
356 (defun hydra--callablep (x)
357 "Test if X is callable."
360 (memq (car x) '(function quote)))))
362 (defun hydra--make-callable (x)
363 "Generate a callable symbol from X.
364 If X is a function symbol or a lambda, return it. Otherwise, it
365 should be a single statement. Wrap it in an interactive lambda."
366 (cond ((or (symbolp x) (functionp x))
368 ((and (consp x) (eq (car x) 'function))
375 (defun hydra-plist-get-default (plist prop default)
376 "Extract a value from a property list.
377 PLIST is a property list, which is a list of the form
378 \(PROP1 VALUE1 PROP2 VALUE2...).
380 Return the value corresponding to PROP, or DEFAULT if PROP is not
381 one of the properties on the list."
382 (if (memq prop plist)
383 (plist-get plist prop)
386 (defun hydra--head-property (h prop &optional default)
387 "Return for Hydra head H the value of property PROP.
388 Return DEFAULT if PROP is not in H."
389 (hydra-plist-get-default (cl-cdddr h) prop default))
391 (defun hydra--body-foreign-keys (body)
392 "Return what BODY does with a non-head binding."
394 (plist-get (cddr body) :foreign-keys)
395 (let ((color (plist-get (cddr body) :color)))
397 ((amaranth teal) 'warn)
400 (defun hydra--body-exit (body)
401 "Return the exit behavior of BODY."
403 (plist-get (cddr body) :exit)
404 (let ((color (plist-get (cddr body) :color)))
409 (defalias 'hydra--imf #'list)
411 (defun hydra-default-pre ()
412 "Default setup that happens in each head before :pre."
413 (when (eq input-method-function 'key-chord-input-method)
414 (if (fboundp 'add-function)
415 (add-function :override input-method-function #'hydra--imf)
416 (unless hydra--input-method-function
417 (setq hydra--input-method-function input-method-function)
418 (setq input-method-function nil)))))
420 (defvar hydra-timeout-timer (timer-create)
421 "Timer for `hydra-timeout'.")
423 (defvar hydra-message-timer (timer-create)
424 "Timer for the hint.")
426 (defvar hydra--work-around-dedicated t
427 "When non-nil, assume there's no bug in `pop-to-buffer'.
428 `pop-to-buffer' should not select a dedicated window.")
430 (defun hydra-keyboard-quit ()
431 "Quitting function similar to `keyboard-quit'."
434 (cancel-timer hydra-timeout-timer)
435 (cancel-timer hydra-message-timer)
436 (setq hydra-curr-map nil)
437 (unless (and hydra--ignore
438 (null hydra--work-around-dedicated))
444 (defvar hydra-head-format "[%s]: "
445 "The formatter for each head of a plain docstring.")
447 (defvar hydra-key-doc-function 'hydra-key-doc-function-default
448 "The function for formatting key-doc pairs.")
450 (defun hydra-key-doc-function-default (key key-width doc doc-width)
452 (format (format "%%%ds: %%%ds" key-width (- -1 doc-width))
455 (defun hydra--to-string (x)
460 (defun hydra--hint (body heads)
461 "Generate a hint for the echo area.
462 BODY, and HEADS are parameters to `defhydra'."
465 (let ((val (assoc (cadr h) alist))
466 (pstr (hydra-fontify-head h body)))
467 (unless (null (cl-caddr h))
470 (concat (cadr val) " " pstr))
473 (cons pstr (cl-caddr h)))
475 (let ((keys (nreverse (mapcar #'cdr alist)))
476 (n-cols (plist-get (cddr body) :columns))
480 (let ((n-rows (1+ (/ (length keys) n-cols)))
481 (max-key-len (apply #'max (mapcar (lambda (x) (length (car x))) keys)))
482 (max-doc-len (apply #'max (mapcar (lambda (x)
483 (length (hydra--to-string (cdr x)))) keys))))
486 (mapconcat #'identity
492 (funcall hydra-key-doc-function
495 (hydra--to-string (cdr y))
496 ,max-doc-len))) x ""))
497 ',(hydra--matrix keys n-cols n-rows))
504 (let ((str (hydra--to-string (cdr x))))
506 (if (> (length str) 0)
507 (concat hydra-head-format str)
513 (if (cl-every #'stringp
514 (mapcar 'cddr alist))
518 (defvar hydra-fontify-head-function nil
519 "Possible replacement for `hydra-fontify-head-default'.")
521 (defun hydra-fontify-head-default (head body)
522 "Produce a pretty string from HEAD and BODY.
523 HEAD's binding is returned as a string with a colored face."
524 (let* ((foreign-keys (hydra--body-foreign-keys body))
525 (head-exit (hydra--head-property head :exit))
528 (if (eq foreign-keys 'warn)
531 (cl-case foreign-keys
535 (when (and (null (cadr head))
537 (hydra--complain "nil cmd can only be blue"))
538 (propertize (if (string= (car head) "%")
542 (or (hydra--head-property head :face)
544 (blue 'hydra-face-blue)
545 (red 'hydra-face-red)
546 (amaranth 'hydra-face-amaranth)
547 (pink 'hydra-face-pink)
548 (teal 'hydra-face-teal)
549 (t (error "Unknown color for %S" head)))))))
551 (defun hydra-fontify-head-greyscale (head _body)
552 "Produce a pretty string from HEAD and BODY.
553 HEAD's binding is returned as a string wrapped with [] or {}."
555 (if (hydra--head-property head :exit)
559 (defun hydra-fontify-head (head body)
560 "Produce a pretty string from HEAD and BODY."
561 (funcall (or hydra-fontify-head-function 'hydra-fontify-head-default)
564 (defun hydra--strip-align-markers (str)
565 "Remove ^ from STR, unless they're escaped: \\^."
567 (while (setq start (string-match "\\\\?\\^" str start))
568 (if (eq (- (match-end 0) (match-beginning 0)) 2)
570 (setq str (replace-match "^" nil nil str))
572 (setq str (replace-match "" nil nil str))))
575 (defun hydra--format (_name body docstring heads)
576 "Generate a `format' statement from STR.
577 \"%`...\" expressions are extracted into \"%S\".
578 _NAME, BODY, DOCSTRING and HEADS are parameters of `defhydra'.
579 The expressions can be auto-expanded according to NAME."
580 (setq docstring (hydra--strip-align-markers docstring))
581 (setq docstring (replace-regexp-in-string "___" "_β_" docstring))
582 (let ((rest (hydra--hint body heads))
588 "\\(?:%\\( ?-?[0-9]*s?\\)\\(`[a-z-A-Z/0-9]+\\|(\\)\\)\\|\\(?:_\\( ?-?[0-9]*?\\)\\(\\[\\|]\\|[-[:alnum:] ~.,;:/|?<>={}*+#%@!&]+?\\)_\\)"
590 (cond ((eq ?_ (aref (match-string 0 docstring) 0))
591 (let* ((key (match-string 4 docstring))
592 (key (if (equal key "β") "_" key))
593 (head (assoc key heads)))
596 (push (hydra-fontify-head head body) varlist)
600 hydra-key-format-spec
601 (concat "%" (match-string 3 docstring) "s"))
603 (error "Unrecognized key: _%s_" key))))
606 (let* ((varp (if (eq ?` (aref (match-string 2 docstring) 0)) 1 0))
607 (spec (match-string 1 docstring))
608 (lspec (length spec)))
611 (insert (substring docstring (+ 1 start varp
613 (goto-char (point-min))
614 (push (read (current-buffer)) varlist)
615 (- (point) (point-min))))
616 (when (or (zerop lspec)
617 (/= (aref spec (1- (length spec))) ?s))
618 (setq spec (concat spec "S")))
621 (substring docstring 0 start)
623 (substring docstring (+ start offset 1 lspec varp))))))))
624 (if (eq ?\n (aref docstring 0))
625 `(concat (format ,(substring docstring 1) ,@(nreverse varlist))
627 (let ((r `(replace-regexp-in-string
629 (concat ,docstring ": "
630 (replace-regexp-in-string
631 "\\(%\\)" "\\1\\1" ,rest)))))
636 (defun hydra--complain (format-string &rest args)
637 "Forward to (`message' FORMAT-STRING ARGS) unless `hydra-verbose' is nil."
639 (apply #'error format-string args)
640 (apply #'message format-string args)))
642 (defun hydra--doc (body-key body-name heads)
643 "Generate a part of Hydra docstring.
644 BODY-KEY is the body key binding.
645 BODY-NAME is the symbol that identifies the Hydra.
646 HEADS is a list of heads."
648 "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
650 (format "a \"%s\"" body-key)
654 (format "\"%s\": `%S'" (car x) (cadr x)))
656 (format "The body can be accessed via `%S'." body-name)))
658 (defun hydra--call-interactively (cmd name)
659 "Generate a `call-interactively' statement for CMD.
660 Set `this-command' to NAME."
661 (if (and (symbolp name)
662 (not (memq name '(nil body))))
664 (setq this-command ',name)
665 (call-interactively #',cmd))
666 `(call-interactively #',cmd)))
668 (defun hydra--make-defun (name body doc head
669 keymap body-pre body-before-exit
670 &optional body-after-exit)
671 "Make a defun wrapper, using NAME, BODY, DOC, HEAD, and KEYMAP.
672 NAME and BODY are the arguments to `defhydra'.
673 DOC was generated with `hydra--doc'.
674 HEAD is one of the HEADS passed to `defhydra'.
675 BODY-PRE is added to the start of the wrapper.
676 BODY-BEFORE-EXIT will be called before the hydra quits.
677 BODY-AFTER-EXIT is added to the end of the wrapper."
678 (let ((cmd-name (hydra--head-name head name))
679 (cmd (when (car head)
680 (hydra--make-callable
683 (format "%s\n\nCall the head: `%S'." doc (cadr head))
685 (hint (intern (format "%S/hint" name)))
686 (body-foreign-keys (hydra--body-foreign-keys body))
687 (body-timeout (plist-get body :timeout))
688 (body-idle (plist-get body :idle)))
693 ,@(when body-pre (list body-pre))
694 ,@(if (hydra--head-property head :exit)
695 `((hydra-keyboard-quit)
696 (setq hydra-curr-body-fn ',(intern (format "%S/body" name)))
697 ,@(if body-after-exit
700 (hydra--call-interactively cmd (cadr head)))
703 `(,(hydra--call-interactively cmd (cadr head))))))
706 `((let ((hydra--ignore ,(not (eq (cadr head) 'body))))
707 (hydra-keyboard-quit)
708 (setq hydra-curr-body-fn ',(intern (format "%S/body" name))))
711 ,(hydra--call-interactively cmd (cadr head))
716 ,(if (and body-idle (eq (cadr head) 'body))
717 `(hydra-idle-message ,body-idle ,hint)
718 `(when hydra-is-helpful
720 (lv-message (eval ,hint))
721 (message (eval ,hint)))))
722 (hydra-set-transient-map
724 (lambda () (hydra-keyboard-quit) ,body-before-exit)
725 ,(when body-foreign-keys
726 (list 'quote body-foreign-keys)))
729 `(hydra-timeout ,body-timeout))))))))
731 (defmacro hydra--make-funcall (sym)
732 "Transform SYM into a `funcall' to call it."
733 `(when (and ,sym (symbolp ,sym))
734 (setq ,sym `(funcall #',,sym))))
736 (defun hydra--head-name (h name)
737 "Return the symbol for head H of hydra with NAME."
738 (let ((str (format "%S/%s" name
739 (cond ((symbolp (cadr h))
741 ((and (consp (cadr h))
742 (eq (cl-caadr h) 'function))
745 (concat "lambda-" (car h)))))))
746 (when (and (hydra--head-property h :exit)
747 (not (memq (cadr h) '(body nil))))
748 (setq str (concat str "-and-exit")))
751 (defun hydra--delete-duplicates (heads)
752 "Return HEADS without entries that have the same CMD part.
753 In duplicate HEADS, :cmd-name is modified to whatever they duplicate."
754 (let ((ali '(((hydra-repeat . nil) . hydra-repeat)))
757 (if (setq entry (assoc (cons (cadr h)
758 (hydra--head-property h :exit))
760 (setf (cl-cdddr h) (plist-put (cl-cdddr h) :cmd-name (cdr entry)))
761 (push (cons (cons (cadr h)
762 (hydra--head-property h :exit))
763 (plist-get (cl-cdddr h) :cmd-name))
768 (defun hydra--pad (lst n)
769 "Pad LST with nil until length N."
770 (let ((len (length lst)))
773 (append lst (make-list (- n len) nil)))))
775 (defmacro hydra-multipop (lst n)
776 "Return LST's first N elements while removing them."
777 `(if (<= (length ,lst) ,n)
782 (nthcdr (1- ,n) (prog1 ,lst (setq ,lst (nthcdr ,n ,lst))))
785 (defun hydra--matrix (lst rows cols)
786 "Create a matrix from elements of LST.
787 The matrix size is ROWS times COLS."
788 (let ((ls (copy-sequence lst))
791 (push (hydra--pad (hydra-multipop ls rows) rows) res))
794 (defun hydra--cell (fstr names)
795 "Format a rectangular cell based on FSTR and NAMES.
796 FSTR is a format-style string with two string inputs: one for the
797 doc and one for the symbol name.
798 NAMES is a list of variables."
799 (let ((len (cl-reduce
800 (lambda (acc it) (max (length (symbol-name it)) acc))
807 (documentation-property sym 'variable-documentation)
808 (let ((name (symbol-name sym)))
809 (concat name (make-string (- len (length name)) ?^)))
815 (defun hydra--vconcat (strs &optional joiner)
816 "Glue STRS vertically. They must be the same height.
817 JOINER is a function similar to `concat'."
818 (setq joiner (or joiner #'concat))
821 (if (string-match " +$" s)
822 (replace-match "" nil nil s)
824 (apply #'cl-mapcar joiner
826 (lambda (s) (split-string s "\n"))
830 (defvar hydra-cell-format "% -20s %% -8`%s"
831 "The default format for docstring cells.")
833 (defun hydra--table (names rows cols &optional cell-formats)
834 "Format a `format'-style table from variables in NAMES.
835 The size of the table is ROWS times COLS.
836 CELL-FORMATS are `format' strings for each column.
837 If CELL-FORMATS is a string, it's used for all columns.
838 If CELL-FORMATS is nil, `hydra-cell-format' is used for all columns."
840 (cond ((null cell-formats)
841 (make-list cols hydra-cell-format))
842 ((stringp cell-formats)
843 (make-list cols cell-formats))
850 (hydra--matrix names rows cols))
852 (mapconcat #'identity x " "))))
854 (defun hydra-reset-radios (names)
855 "Set varibles NAMES to their defaults.
856 NAMES should be defined by `defhydradio' or similar."
858 (set n (aref (get n 'range) 0))))
860 (defun hydra-idle-message (secs hint)
861 "In SECS seconds display HINT."
862 (cancel-timer hydra-message-timer)
863 (setq hydra-message-timer (timer-create))
864 (timer-set-time hydra-message-timer
865 (timer-relative-time (current-time) secs))
869 (when hydra-is-helpful
871 (lv-message (eval hint))
872 (message (eval hint))))
873 (cancel-timer hydra-message-timer)))
874 (timer-activate hydra-message-timer))
876 (defun hydra-timeout (secs &optional function)
877 "In SECS seconds call FUNCTION, then function `hydra-keyboard-quit'.
878 Cancel the previous `hydra-timeout'."
879 (cancel-timer hydra-timeout-timer)
880 (setq hydra-timeout-timer (timer-create))
881 (timer-set-time hydra-timeout-timer
882 (timer-relative-time (current-time) secs))
887 `(funcall ,function))
888 (hydra-keyboard-quit)))
889 (timer-activate hydra-timeout-timer))
893 (defmacro defhydra (name body &optional docstring &rest heads)
894 "Create a Hydra - a family of functions with prefix NAME.
896 NAME should be a symbol, it will be the prefix of all functions
901 (BODY-MAP BODY-KEY &rest BODY-PLIST)
903 DOCSTRING will be displayed in the echo area to identify the
904 Hydra. When DOCSTRING starts with a newline, special Ruby-style
905 substitution will be performed by `hydra--format'.
907 Functions are created on basis of HEADS, each of which has the
910 (KEY CMD &optional HINT &rest PLIST)
912 BODY-MAP is a keymap; `global-map' is used quite often. Each
913 function generated from HEADS will be bound in BODY-MAP to
914 BODY-KEY + KEY (both are strings passed to `kbd'), and will set
915 the transient map so that all following heads can be called
916 though KEY only. BODY-KEY can be an empty string.
918 CMD is a callable expression: either an interactive function
919 name, or an interactive lambda, or a single sexp (it will be
920 wrapped in an interactive lambda).
922 HINT is a short string that identifies its head. It will be
923 printed beside KEY in the echo erea if `hydra-is-helpful' is not
924 nil. If you don't even want the KEY to be printed, set HINT
927 The heads inherit their PLIST from BODY-PLIST and are allowed to
928 override some keys. The keys recognized are :exit and :bind.
931 - nil (default): this head will continue the Hydra state.
932 - t: this head will stop the Hydra state.
935 - nil: this head will not be bound in BODY-MAP.
936 - a lambda taking KEY and CMD used to bind a head.
938 It is possible to omit both BODY-MAP and BODY-KEY if you don't
939 want to bind anything. In that case, typically you will bind the
940 generated NAME/body command. This command is also the return
941 result of `defhydra'."
942 (declare (indent defun))
943 (cond ((stringp docstring))
944 ((and (consp docstring)
945 (memq (car docstring) '(hydra--table concat format)))
946 (setq docstring (concat "\n" (eval docstring))))
948 (setq heads (cons docstring heads))
949 (setq docstring "hydra")))
950 (when (keywordp (car body))
951 (setq body (cons nil (cons nil body))))
952 (condition-case-unless-debug err
953 (let* ((keymap (copy-keymap hydra-base-map))
954 (keymap-name (intern (format "%S/keymap" name)))
955 (body-name (intern (format "%S/body" name)))
956 (body-key (cadr body))
957 (body-plist (cddr body))
958 (body-map (or (car body)
959 (plist-get body-plist :bind)))
960 (body-pre (plist-get body-plist :pre))
961 (body-body-pre (plist-get body-plist :body-pre))
962 (body-before-exit (or (plist-get body-plist :post)
963 (plist-get body-plist :before-exit)))
964 (body-after-exit (plist-get body-plist :after-exit))
965 (body-inherit (plist-get body-plist :inherit))
966 (body-foreign-keys (hydra--body-foreign-keys body))
967 (body-exit (hydra--body-exit body)))
968 (dolist (base body-inherit)
969 (setq heads (append heads (copy-sequence (eval base)))))
971 (let ((len (length h)))
973 (error "Each head should have at least two items: %S" h))
977 (hydra-plist-get-default body-plist :hint "")))
978 (setcdr (nthcdr 2 h) (list :exit body-exit)))
980 (let ((hint (cl-caddr h)))
981 (unless (or (null hint)
983 (stringp (eval hint)))
984 (setcdr (cdr h) (cons
985 (hydra-plist-get-default body-plist :hint "")
987 (let ((hint-and-plist (cddr h)))
988 (if (null (cdr hint-and-plist))
989 (setcdr hint-and-plist (list :exit body-exit))
990 (let* ((plist (cl-cdddr h))
991 (h-color (plist-get plist :color)))
994 (plist-put plist :exit
998 (cl-remf (cl-cdddr h) :color))
999 (let ((h-exit (hydra-plist-get-default plist :exit 'default)))
1000 (plist-put plist :exit
1001 (if (eq h-exit 'default)
1004 (plist-put (cl-cdddr h) :cmd-name (hydra--head-name h name))
1005 (when (null (cadr h)) (plist-put (cl-cdddr h) :exit t)))
1006 (let ((doc (hydra--doc body-key body-name heads))
1007 (heads-nodup (hydra--delete-duplicates heads)))
1010 (define-key keymap (kbd (car x))
1011 (plist-get (cl-cdddr x) :cmd-name)))
1013 (hydra--make-funcall body-pre)
1014 (hydra--make-funcall body-body-pre)
1015 (hydra--make-funcall body-before-exit)
1016 (hydra--make-funcall body-after-exit)
1017 (when (memq body-foreign-keys '(run warn))
1020 (hydra--head-property h :exit))
1023 "An %S Hydra must have at least one blue head in order to exit"
1024 body-foreign-keys)))
1027 (set (defvar ,keymap-name
1029 ,(format "Keymap for %S." name))
1032 (set (defvar ,(intern (format "%S/heads" name))
1034 ,(format "Heads for %S." name))
1035 ',(mapcar (lambda (h)
1036 (let ((j (copy-sequence h)))
1037 (cl-remf (cl-cdddr j) :cmd-name)
1041 (defvar ,(intern (format "%S/hint" name)) nil
1042 ,(format "Dynamic hint for %S." name))
1043 ',(hydra--format name body docstring heads))
1047 (hydra--make-defun name body doc head keymap-name
1052 ;; free up keymap prefix
1053 ,@(unless (or (null body-key)
1055 (hydra--callablep body-map))
1056 `((unless (keymapp (lookup-key ,body-map (kbd ,body-key)))
1057 (define-key ,body-map (kbd ,body-key) nil))))
1062 (let ((name (hydra--head-property head :cmd-name)))
1063 (when (and (cadr head)
1064 (or body-key body-map))
1065 (let ((bind (hydra--head-property head :bind body-map))
1068 (vconcat (kbd body-key) (kbd (car head)))
1070 (cond ((null bind) nil)
1071 ((hydra--callablep bind)
1072 `(funcall ,bind ,final-key (function ,name)))
1073 ((and (symbolp bind)
1075 (keymapp (symbol-value bind))
1077 `(define-key ,bind ,final-key (quote ,name)))
1079 (error "Invalid :bind property `%S' for head %S" bind head)))))))
1082 name body doc '(nil body)
1084 (or body-body-pre body-pre) body-before-exit
1085 '(setq prefix-arg current-prefix-arg)))))
1087 (hydra--complain "Error in defhydra %S: %s" name (cdr err))
1090 (defmacro defhydradio (name _body &rest heads)
1091 "Create radios with prefix NAME.
1092 _BODY specifies the options; there are none currently.
1093 HEADS have the format:
1095 (TOGGLE-NAME &optional VALUE DOC)
1097 TOGGLE-NAME will be used along with NAME to generate a variable
1098 name and a function that cycles it with the same name. VALUE
1099 should be an array. The first element of VALUE will be used to
1100 inialize the variable.
1101 VALUE defaults to [nil t].
1102 DOC defaults to TOGGLE-NAME split and capitalized."
1103 (declare (indent defun))
1107 (hydra--radio name h))
1109 (defvar ,(intern (format "%S/names" name))
1110 ',(mapcar (lambda (h) (intern (format "%S/%S" name (car h))))
1113 (defun hydra--radio (parent head)
1114 "Generate a hydradio with PARENT from HEAD."
1115 (let* ((name (car head))
1116 (full-name (intern (format "%S/%S" parent name)))
1118 (val (or (cl-caddr head) [nil t])))
1119 `((defvar ,full-name ,(hydra--quote-maybe (aref val 0)) ,doc)
1120 (put ',full-name 'range ,val)
1121 (defun ,full-name ()
1122 (hydra--cycle-radio ',full-name)))))
1124 (defun hydra--quote-maybe (x)
1125 "Quote X if it's a symbol."
1133 (defun hydra--cycle-radio (sym)
1134 "Set SYM to the next value in its range."
1135 (let* ((val (symbol-value sym))
1136 (range (get sym 'range))
1139 (setq i (catch 'done
1141 (if (equal (aref range i) val)
1142 (throw 'done (1+ i))
1144 (error "Val not in range for %S" sym)))
1153 (defvar hydra-pause-ring (make-ring 10)
1154 "Ring for paused hydras.")
1156 (defun hydra-pause-resume ()
1157 "Quit the current hydra and save it to the stack.
1158 If there's no active hydra, pop one from the stack and call its body.
1159 If the stack is empty, call the last hydra's body."
1161 (cond (hydra-curr-map
1162 (ring-insert hydra-pause-ring hydra-curr-body-fn)
1163 (hydra-keyboard-quit))
1164 ((zerop (ring-length hydra-pause-ring))
1165 (funcall hydra-curr-body-fn))
1167 (funcall (ring-remove hydra-pause-ring 0)))))
1170 ;; outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|###autoload\\)\\|("
1171 ;; indent-tabs-mode: nil
1176 ;;; hydra.el ends here