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 (defalias 'hydra-set-transient-map
83 (if (fboundp 'set-transient-map)
85 (lambda (map _keep-pred &optional on-exit)
87 (set-temporary-overlay-map map (hydra--pred on-exit))))))
89 (defun hydra--pred (on-exit)
90 "Generate a predicate on whether to continue the Hydra state.
91 Call ON-EXIT for clean-up.
92 This is a compatibility code for Emacs older than 24.4."
94 (if (lookup-key hydra-curr-map (this-command-keys-vector))
98 `(funcall ,(hydra--make-callable on-exit)))
103 "Make bindings that stick around."
107 (defcustom hydra-is-helpful t
108 "When t, display a hint with possible bindings in the echo area."
112 (defcustom hydra-keyboard-quit "
\a"
113 "This binding will quit an amaranth Hydra.
114 It's the only other way to quit it besides though a blue head.
115 It's possible to set this to nil.")
117 (defcustom hydra-lv t
118 "When non-nil, `lv-message' (not `message') will be used to display hints."
121 (defcustom hydra-verbose nil
122 "When non-nil, hydra will issue some non essential style warnings."
125 (defcustom hydra-key-format-spec "%s"
126 "Default `format'-style specifier for _a_ syntax in docstrings.
127 When nil, you can specify your own at each location like this: _ 5a_.")
129 (defface hydra-face-red
130 '((t (:foreground "#FF0000" :bold t)))
131 "Red Hydra heads will persist indefinitely."
134 (defface hydra-face-blue
135 '((t (:foreground "#0000FF" :bold t)))
136 "Blue Hydra heads will vanquish the Hydra.")
138 (defface hydra-face-amaranth
139 '((t (:foreground "#E52B50" :bold t)))
140 "Amaranth body has red heads and warns on intercepting non-heads.
141 Vanquishable only through a blue head.")
143 (defface hydra-face-pink
144 '((t (:foreground "#FF6EB4" :bold t)))
145 "Pink body has red heads and on intercepting non-heads calls them without quitting.
146 Vanquishable only through a blue head.")
148 (defface hydra-face-teal
149 '((t (:foreground "#367588" :bold t)))
150 "Teal body has blue heads an warns on intercepting non-heads.
151 Vanquishable only through a blue head.")
154 (defun hydra-add-font-lock ()
155 "Fontify `defhydra' statements."
156 (font-lock-add-keywords
158 '(("(\\(defhydra\\)\\_> +\\(.*?\\)\\_>"
159 (1 font-lock-keyword-face)
160 (2 font-lock-type-face))
161 ("(\\(defhydradio\\)\\_> +\\(.*?\\)\\_>"
162 (1 font-lock-keyword-face)
163 (2 font-lock-type-face)))))
165 ;;* Universal Argument
166 (defvar hydra-base-map
167 (let ((map (make-sparse-keymap)))
168 (define-key map [?\C-u] 'hydra--universal-argument)
169 (define-key map [?-] 'hydra--negative-argument)
170 (define-key map [?0] 'hydra--digit-argument)
171 (define-key map [?1] 'hydra--digit-argument)
172 (define-key map [?2] 'hydra--digit-argument)
173 (define-key map [?3] 'hydra--digit-argument)
174 (define-key map [?4] 'hydra--digit-argument)
175 (define-key map [?5] 'hydra--digit-argument)
176 (define-key map [?6] 'hydra--digit-argument)
177 (define-key map [?7] 'hydra--digit-argument)
178 (define-key map [?8] 'hydra--digit-argument)
179 (define-key map [?9] 'hydra--digit-argument)
180 (define-key map [kp-0] 'hydra--digit-argument)
181 (define-key map [kp-1] 'hydra--digit-argument)
182 (define-key map [kp-2] 'hydra--digit-argument)
183 (define-key map [kp-3] 'hydra--digit-argument)
184 (define-key map [kp-4] 'hydra--digit-argument)
185 (define-key map [kp-5] 'hydra--digit-argument)
186 (define-key map [kp-6] 'hydra--digit-argument)
187 (define-key map [kp-7] 'hydra--digit-argument)
188 (define-key map [kp-8] 'hydra--digit-argument)
189 (define-key map [kp-9] 'hydra--digit-argument)
190 (define-key map [kp-subtract] 'hydra--negative-argument)
191 (define-key map [switch-frame] 'hydra--handle-switch-frame)
193 "Keymap that all Hydras inherit. See `universal-argument-map'.")
195 (defvar hydra-curr-map
197 "Keymap of the current Hydra called.")
199 (defun hydra--handle-switch-frame (evt)
200 "Quit hydra and call old switch-frame event handler."
202 (hydra-keyboard-quit)
203 (funcall (lookup-key (current-global-map) [switch-frame]) evt))
205 (defun hydra--universal-argument (arg)
206 "Forward to (`universal-argument' ARG)."
208 (setq prefix-arg (if (consp arg)
209 (list (* 4 (car arg)))
213 (hydra-set-transient-map hydra-curr-map t))
215 (defun hydra--digit-argument (arg)
216 "Forward to (`digit-argument' ARG)."
218 (let ((universal-argument-map hydra-curr-map))
219 (digit-argument arg)))
221 (defun hydra--negative-argument (arg)
222 "Forward to (`negative-argument' ARG)."
224 (let ((universal-argument-map hydra-curr-map))
225 (negative-argument arg)))
227 (defvar hydra-repeat--prefix-arg nil
228 "Prefix arg to use with `hydra-repeat'.")
230 (defvar hydra-repeat--command nil
231 "Command to use with `hydra-repeat'.")
233 (defun hydra-repeat ()
234 "Repeat last command with last prefix arg."
236 (unless (string-match "hydra-repeat$" (symbol-name last-command))
237 (setq hydra-repeat--command last-command)
238 (setq hydra-repeat--prefix-arg (or last-prefix-arg 1)))
239 (setq current-prefix-arg hydra-repeat--prefix-arg)
240 (funcall hydra-repeat--command))
243 (defvar hydra-last nil
244 "The result of the last `hydra-set-transient-map' call.")
246 (defun hydra--callablep (x)
247 "Test if X is callable."
250 (memq (car x) '(function quote)))))
252 (defun hydra--make-callable (x)
253 "Generate a callable symbol from X.
254 If X is a function symbol or a lambda, return it. Otherwise, it
255 should be a single statement. Wrap it in an interactive lambda."
256 (if (or (symbolp x) (functionp x))
262 (defun hydra-plist-get-default (plist prop default)
263 "Extract a value from a property list.
264 PLIST is a property list, which is a list of the form
265 \(PROP1 VALUE1 PROP2 VALUE2...).
267 Return the value corresponding to PROP, or DEFAULT if PROP is not
268 one of the properties on the list."
269 (if (memq prop plist)
270 (plist-get plist prop)
273 (defun hydra--head-property (h prop &optional default)
274 "Return for Hydra head H the value of property PROP.
275 Return DEFAULT if PROP is not in H."
276 (hydra-plist-get-default (cl-cdddr h) prop default))
278 (defun hydra--aggregate-color (head-color body-color)
279 "Return the resulting head color for HEAD-COLOR and BODY-COLOR."
280 (cond ((eq head-color 'red)
287 ((eq head-color 'blue)
295 (error "Can't aggregate head %S to body %S"
296 head-color body-color))))
298 (defun hydra--head-color (h body)
299 "Return the color of a Hydra head H with BODY."
300 (let* ((exit (hydra--head-property h :exit 'default))
301 (color (hydra--head-property h :color))
302 (foreign-keys (hydra--body-foreign-keys body))
304 (cond ((eq exit 'default)
310 (error "Use only :blue or :red for heads: %S" h)))))
313 (error "Don't mix :color and :exit - they are aliases: %S" h)
314 (cl-case foreign-keys
320 (error "Don't mix :color and :exit - they are aliases: %S" h)
323 (error "Unknown :exit %S" exit)))))
324 (cond ((null (cadr h))
327 "Doubly specified blue head - nil cmd is already blue: %S" h))
330 (hydra--body-color body))
333 ((eq foreign-keys 'run)
334 (if (eq head-color 'red)
337 ((eq foreign-keys 'warn)
338 (if (memq head-color '(red amaranth))
342 (error "Unexpected %S %S" h body)))))
344 (defun hydra--body-foreign-keys (body)
345 "Return what BODY does with a non-head binding."
347 (plist-get (cddr body) :foreign-keys)
348 (let ((color (plist-get (cddr body) :color)))
350 ((amaranth teal) 'warn)
353 (defun hydra--body-color (body)
354 "Return the color of BODY.
355 BODY is the second argument to `defhydra'"
356 (let ((color (plist-get (cddr body) :color))
357 (exit (plist-get (cddr body) :exit))
358 (foreign-keys (plist-get (cddr body) :foreign-keys)))
359 (cond ((eq foreign-keys 'warn)
360 (if exit 'teal 'amaranth))
361 ((eq foreign-keys 'run) 'pink)
366 (defun hydra--face (h body)
367 "Return the face for a Hydra head H with BODY."
368 (cl-case (hydra--head-color h body)
369 (blue 'hydra-face-blue)
370 (red 'hydra-face-red)
371 (amaranth 'hydra-face-amaranth)
372 (pink 'hydra-face-pink)
373 (teal 'hydra-face-teal)
374 (t (error "Unknown color for %S" h))))
376 (defun hydra-cleanup ()
377 "Clean up after a Hydra."
378 (when (window-live-p lv-wnd)
379 (let ((buf (window-buffer lv-wnd)))
380 (delete-window lv-wnd)
383 (defun hydra-keyboard-quit ()
384 "Quitting function similar to `keyboard-quit'."
388 (cancel-timer hydra-timer)
393 (defun hydra-disable ()
394 "Disable the current Hydra."
397 ((functionp hydra-last)
398 (funcall hydra-last))
400 ;; Emacs 24.3 or older
401 ((< emacs-minor-version 4)
402 (setq emulation-mode-map-alists
407 (equal (cdar x) hydra-curr-map)))
408 emulation-mode-map-alists)))
412 (setq overriding-terminal-local-map nil))))
414 (defun hydra--unalias-var (str prefix)
415 "Return the symbol named STR if it's bound as a variable.
416 Otherwise, add PREFIX to the symbol name."
417 (let ((sym (intern-soft str)))
420 (intern (concat prefix "/" str)))))
422 (defun hydra--hint (body heads)
423 "Generate a hint for the echo area.
424 BODY, and HEADS are parameters to `defhydra'."
427 (let ((val (assoc (cadr h) alist))
428 (pstr (hydra-fontify-head h body)))
429 (unless (null (cl-caddr h))
432 (concat (cadr val) " " pstr))
435 (cons pstr (cl-caddr h)))
440 (if (> (length (cdr x)) 0)
441 (concat "[%s]: " (cdr x))
444 (nreverse (mapcar #'cdr alist))
447 (defvar hydra-fontify-head-function nil
448 "Possible replacement for `hydra-fontify-head-default'.")
450 (defun hydra-fontify-head-default (head body)
451 "Produce a pretty string from HEAD and BODY.
452 HEAD's binding is returned as a string with a colored face."
453 (propertize (car head) 'face (hydra--face head body)))
455 (defun hydra-fontify-head-greyscale (head body)
456 "Produce a pretty string from HEAD and BODY.
457 HEAD's binding is returned as a string wrapped with [] or {}."
458 (let ((color (hydra--head-color head body)))
462 "{%s}") (car head))))
464 (defun hydra-fontify-head (head body)
465 "Produce a pretty string from HEAD and BODY."
466 (funcall (or hydra-fontify-head-function 'hydra-fontify-head-default)
469 (defun hydra--format (_name body docstring heads)
470 "Generate a `format' statement from STR.
471 \"%`...\" expressions are extracted into \"%S\".
472 NAME, BODY, DOCSTRING and HEADS are parameters of `defhydra'.
473 The expressions can be auto-expanded according to NAME."
474 (setq docstring (replace-regexp-in-string "\\^" "" docstring))
475 (let ((rest (hydra--hint body heads))
481 "\\(?:%\\( ?-?[0-9]*s?\\)\\(`[a-z-A-Z/0-9]+\\|(\\)\\)\\|\\(?:_\\( ?-?[0-9]*\\)\\([a-z-~A-Z;:0-9/|?<>={}]+\\)_\\)"
483 (cond ((eq ?_ (aref (match-string 0 docstring) 0))
484 (let* ((key (match-string 4 docstring))
485 (head (assoc key heads)))
488 (push (hydra-fontify-head head body) varlist)
492 hydra-key-format-spec
493 (concat "%" (match-string 3 docstring) "s"))
495 (error "Unrecognized key: _%s_" key))))
498 (let* ((varp (if (eq ?` (aref (match-string 2 docstring) 0)) 1 0))
499 (spec (match-string 1 docstring))
500 (lspec (length spec)))
503 (insert (substring docstring (+ 1 start varp
505 (goto-char (point-min))
506 (push (read (current-buffer)) varlist)
507 (- (point) (point-min))))
508 (when (or (zerop lspec)
509 (/= (aref spec (1- (length spec))) ?s))
510 (setq spec (concat spec "S")))
513 (substring docstring 0 start)
515 (substring docstring (+ start offset 1 lspec varp))))))))
516 (if (eq ?\n (aref docstring 0))
517 `(concat (format ,(substring docstring 1) ,@(nreverse varlist))
519 `(format ,(concat docstring ": " rest ".")))))
521 (defun hydra--message (name body docstring heads)
522 "Generate code to display the hint in the preferred echo area.
523 Set `hydra-lv' to choose the echo area.
524 NAME, BODY, DOCSTRING, and HEADS are parameters of `defhydra'."
525 (let ((format-expr (hydra--format name body docstring heads)))
527 (lv-message ,format-expr)
528 (message ,format-expr))))
530 (defun hydra--complain (format-string &rest args)
531 "Forward to (`message' FORMAT-STRING ARGS) unless `hydra-verbose' is nil."
533 (apply #'warn format-string args)))
535 (defun hydra--doc (body-key body-name heads)
536 "Generate a part of Hydra docstring.
537 BODY-KEY is the body key binding.
538 BODY-NAME is the symbol that identifies the Hydra.
539 HEADS is a list of heads."
541 "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
543 (format "a \"%s\"" body-key)
547 (format "\"%s\": `%S'" (car x) (cadr x)))
549 (format "The body can be accessed via `%S'." body-name)))
551 (defun hydra--make-defun (name body doc head
552 keymap body-pre body-post &optional other-post)
553 "Make a defun wrapper, using NAME, BODY, DOC, HEAD, and KEYMAP.
554 NAME and BODY are the arguments to `defhydra'.
555 DOC was generated with `hydra--doc'.
556 HEAD is one of the HEADS passed to `defhydra'.
557 BODY-PRE and BODY-POST are pre-processed in `defhydra'.
558 OTHER-POST is an optional extension to the :post key of BODY."
559 (let ((name (hydra--head-name head name body))
560 (cmd (when (car head)
561 (hydra--make-callable
563 (color (when (car head)
564 (hydra--head-color head body)))
566 (format "%s\n\nCall the head: `%S'." doc (cadr head))
568 (hint (intern (format "%S/hint" name)))
569 (body-color (hydra--body-color body))
570 (body-timeout (plist-get body :timeout)))
574 ,@(when body-pre (list body-pre))
576 ,@(when (memq color '(blue teal)) '((hydra-cleanup)))
577 (catch 'hydra-disable
579 (if (memq color '(blue teal))
580 `(,(when cmd `(call-interactively #',cmd))
585 (call-interactively #',cmd))
591 (when hydra-is-helpful
594 (hydra-set-transient-map
595 (setq hydra-curr-map ',keymap)
598 (not (memq body-color
599 '(amaranth pink teal)))
601 `(lambda () (hydra-cleanup) ,body-post)
602 `(lambda () (hydra-cleanup)))))
608 (hydra--make-callable body-post))))))))))))
610 (defun hydra-pink-fallback ()
611 "On intercepting a non-head, try to run it."
612 (let ((keys (this-command-keys))
614 (when (equal keys [backspace])
616 (setq kb (key-binding keys))
620 (call-interactively kb)
625 (message "Pink Hydra can't currently handle prefixes, continuing"))
626 (message "Pink Hydra could not resolve: %S" keys))))
628 (defun hydra--modify-keymap (keymap def)
629 "In KEYMAP, add DEF to each sub-keymap."
634 (if (eq (car map) 'keymap)
641 (recur (cdr map)))))))
644 (defun hydra--handle-nonhead (keymap name body heads)
645 "Setup KEYMAP for intercepting non-head bindings.
646 NAME, BODY and HEADS are parameters to `defhydra'."
647 (let ((body-color (hydra--body-color body))
648 (body-post (plist-get (cddr body) :post)))
650 (when (symbolp body-post)
651 (setq body-post `(funcall #',body-post)))
652 (when hydra-keyboard-quit
653 (define-key keymap hydra-keyboard-quit #'hydra-keyboard-quit)))
654 (when (memq body-color '(amaranth pink teal))
655 (if (cl-some (lambda (h)
656 (memq (hydra--head-color h body) '(blue teal)))
662 (hydra--modify-keymap
668 ((memq body-color '(amaranth teal))
669 '(message "An amaranth Hydra can only exit through a blue head"))
671 '(hydra-pink-fallback)))
672 (hydra-set-transient-map hydra-curr-map t)
673 (when hydra-is-helpful
676 (,(intern (format "%S/hint" name))))))))))
677 (unless (eq body-color 'teal)
679 "An %S Hydra must have at least one blue head in order to exit"
682 (defun hydra--head-name (h name body)
683 "Return the symbol for head H of hydra with NAME and BODY."
684 (let ((str (format "%S/%s" name
685 (if (symbolp (cadr h))
687 (concat "lambda-" (car h))))))
688 (when (and (memq (hydra--head-color h body) '(blue teal))
689 (not (memq (cadr h) '(body nil))))
690 (setq str (concat str "-and-exit")))
693 (defun hydra--delete-duplicates (heads)
694 "Return HEADS without entries that have the same CMD part.
695 In duplicate HEADS, :cmd-name is modified to whatever they duplicate."
696 (let ((ali '(((hydra-repeat . red) . hydra-repeat)))
699 (if (setq entry (assoc (cons (cadr h)
700 (hydra--head-color h '(nil nil)))
702 (setf (cl-cdddr h) (plist-put (cl-cdddr h) :cmd-name (cdr entry)))
703 (push (cons (cons (cadr h)
704 (hydra--head-color h '(nil nil)))
705 (plist-get (cl-cdddr h) :cmd-name))
710 (defun hydra--pad (lst n)
711 "Pad LST with nil until length N."
712 (let ((len (length lst)))
715 (append lst (make-list (- n len) nil)))))
717 (defun hydra--matrix (lst rows cols)
718 "Create a matrix from elements of LST.
719 The matrix size is ROWS times COLS."
720 (let ((ls (copy-sequence lst))
723 (push (hydra--pad (hydra-multipop ls rows) rows) res))
726 (defun hydra--cell (fstr names)
727 "Format a rectangular cell based on FSTR and NAMES.
728 FSTR is a format-style string with two string inputs: one for the
729 doc and one for the symbol name.
730 NAMES is a list of variables."
731 (let ((len (cl-reduce
732 (lambda (acc it) (max (length (symbol-name it)) acc))
739 (documentation-property sym 'variable-documentation)
740 (let ((name (symbol-name sym)))
741 (concat name (make-string (- len (length name)) ?^)))
747 (defun hydra--vconcat (strs &optional joiner)
748 "Glue STRS vertically. They must be the same height.
749 JOINER is a function similar to `concat'."
750 (setq joiner (or joiner #'concat))
753 (if (string-match " +$" s)
754 (replace-match "" nil nil s)
756 (apply #'cl-mapcar joiner
758 (lambda (s) (split-string s "\n"))
762 (defcustom hydra-cell-format "% -20s %% -8`%s"
763 "The default format for docstring cells."
766 (defun hydra--table (names rows cols &optional cell-formats)
767 "Format a `format'-style table from variables in NAMES.
768 The size of the table is ROWS times COLS.
769 CELL-FORMATS are `format' strings for each column.
770 If CELL-FORMATS is a string, it's used for all columns.
771 If CELL-FORMATS is nil, `hydra-cell-format' is used for all columns."
773 (cond ((null cell-formats)
774 (make-list cols hydra-cell-format))
775 ((stringp cell-formats)
776 (make-list cols cell-formats))
783 (hydra--matrix names rows cols))
785 (mapconcat #'identity x " "))))
787 (defun hydra-reset-radios (names)
788 "Set varibles NAMES to their defaults.
789 NAMES should be defined by `defhydradio' or similar."
791 (set n (aref (get n 'range) 0))))
793 (defvar hydra-timer (timer-create)
794 "Timer for `hydra-timeout'.")
796 (defun hydra-timeout (secs &optional function)
797 "In SECS seconds call FUNCTION, then `hydra-keyboard-quit'.
798 Cancel the previous `hydra-timeout'."
799 (cancel-timer hydra-timer)
800 (setq hydra-timer (timer-create))
801 (timer-set-time hydra-timer
802 (timer-relative-time (current-time) secs))
807 `(funcall ,function))
808 (hydra-keyboard-quit)))
809 (timer-activate hydra-timer))
814 (defmacro defhydra (name body &optional docstring &rest heads)
815 "Create a Hydra - a family of functions with prefix NAME.
817 NAME should be a symbol, it will be the prefix of all functions
822 (BODY-MAP BODY-KEY &rest PLIST)
824 DOCSTRING will be displayed in the echo area to identify the
827 Functions are created on basis of HEADS, each of which has the
830 (KEY CMD &optional HINT &rest PLIST)
832 BODY-MAP is a keymap; `global-map' is used quite often. Each
833 function generated from HEADS will be bound in BODY-MAP to
834 BODY-KEY + KEY (both are strings passed to `kbd'), and will set
835 the transient map so that all following heads can be called
838 CMD is a callable expression: either an interactive function
839 name, or an interactive lambda, or a single sexp (it will be
840 wrapped in an interactive lambda).
842 HINT is a short string that identifies its head. It will be
843 printed beside KEY in the echo erea if `hydra-is-helpful' is not
844 nil. If you don't even want the KEY to be printed, set HINT
847 The heads inherit their PLIST from the body and are allowed to
848 override each key. The keys recognized are :color and :bind.
851 - red (default): this head will continue the Hydra state.
852 - blue: this head will stop the Hydra state.
853 - amaranth (applies to body only): similar to red, but no binding
854 except a blue head can stop the Hydra state.
857 - nil: this head will not be bound in BODY-MAP.
858 - a lambda taking KEY and CMD used to bind a head
860 It is possible to omit both BODY-MAP and BODY-KEY if you don't
861 want to bind anything. In that case, typically you will bind the
862 generated NAME/body command. This command is also the return
863 result of `defhydra'."
864 (declare (indent defun))
865 (cond ((stringp docstring))
866 ((and (consp docstring)
867 (memq (car docstring) '(hydra--table concat format)))
868 (setq docstring (concat "\n" (eval docstring))))
870 (setq heads (cons docstring heads))
871 (setq docstring "hydra")))
872 (when (keywordp (car body))
873 (setq body (cons nil (cons nil body))))
874 (let ((keymap (copy-keymap hydra-base-map))
875 (body-name (intern (format "%S/body" name)))
876 (body-key (cadr body))
877 (body-pre (plist-get (cddr body) :pre))
878 (body-body-pre (plist-get (cddr body) :body-pre))
879 (body-post (plist-get (cddr body) :post))
880 (method (or (plist-get body :bind)
883 (when (symbolp body-post)
884 (setq body-post `(funcall #',body-post)))
885 (setq heads (cons (list hydra-keyboard-quit #'hydra-keyboard-quit nil :exit t)
888 (let ((len (length h)))
890 (error "Each head should have at least two items: %S" h))
894 (hydra-plist-get-default (cddr body) :hint "")))
896 (list :cmd-name (hydra--head-name h name body))))
898 (let ((hint (cl-caddr h)))
899 (unless (or (null hint)
901 (setcdr (cdr h) (cons
902 (hydra-plist-get-default (cddr body) :hint "")
906 ,(hydra--head-name h name body)
907 ,@(cl-cdddr h))))))))
908 (let ((doc (hydra--doc body-key body-name heads))
909 (heads-nodup (hydra--delete-duplicates heads)))
912 (define-key keymap (kbd (car x))
913 (plist-get (cl-cdddr x) :cmd-name)))
915 (when (and body-pre (symbolp body-pre))
916 (setq body-pre `(funcall #',body-pre)))
917 (when (and body-body-pre (symbolp body-body-pre))
918 (setq body-body-pre `(funcall #',body-body-pre)))
919 (hydra--handle-nonhead keymap name body heads)
923 (hydra--make-defun name body doc head keymap
926 ,@(unless (or (null body-key)
928 (hydra--callablep method))
929 `((unless (keymapp (lookup-key ,method (kbd ,body-key)))
930 (define-key ,method (kbd ,body-key) nil))))
934 (let ((name (hydra--head-property head :cmd-name)))
935 (when (and (cadr head)
936 (not (eq (cadr head) 'hydra-keyboard-quit))
937 (or body-key method))
938 (let ((bind (hydra--head-property head :bind 'default))
941 (vconcat (kbd body-key) (kbd (car head)))
943 (cond ((null bind) nil)
947 (if (hydra--callablep method)
952 (list 'function name)))
954 ((hydra--callablep bind)
955 `(funcall (function ,bind)
960 (error "Invalid :bind property %S" head)))))))
962 (defun ,(intern (format "%S/hint" name)) ()
963 ,(hydra--message name body docstring heads))
965 name body doc '(nil body)
967 (or body-body-pre body-pre) body-post
968 '(setq prefix-arg current-prefix-arg))))))
970 (defmacro defhydradio (name _body &rest heads)
971 "Create radios with prefix NAME.
972 BODY specifies the options; there are none currently.
973 HEADS have the format:
975 (TOGGLE-NAME &optional VALUE DOC)
977 TOGGLE-NAME will be used along with NAME to generate a variable
978 name and a function that cycles it with the same name. VALUE
979 should be an array. The first element of VALUE will be used to
980 inialize the variable.
981 VALUE defaults to [nil t].
982 DOC defaults to TOGGLE-NAME split and capitalized."
983 (declare (indent defun))
987 (hydra--radio name h))
989 (defvar ,(intern (format "%S/names" name))
990 ',(mapcar (lambda (h) (intern (format "%S/%S" name (car h))))
993 (defmacro hydra-multipop (lst n)
994 "Return LST's first N elements while removing them."
995 `(if (<= (length ,lst) ,n)
1000 (nthcdr (1- ,n) (prog1 ,lst (setq ,lst (nthcdr ,n ,lst))))
1003 (defun hydra--radio (parent head)
1004 "Generate a hydradio with PARENT from HEAD."
1005 (let* ((name (car head))
1006 (full-name (intern (format "%S/%S" parent name)))
1008 (val (or (cl-caddr head) [nil t])))
1009 `((defvar ,full-name ,(hydra--quote-maybe (aref val 0)) ,doc)
1010 (put ',full-name 'range ,val)
1011 (defun ,full-name ()
1012 (hydra--cycle-radio ',full-name)))))
1014 (defun hydra--quote-maybe (x)
1015 "Quote X if it's a symbol."
1023 (defun hydra--cycle-radio (sym)
1024 "Set SYM to the next value in its range."
1025 (let* ((val (symbol-value sym))
1026 (range (get sym 'range))
1029 (setq i (catch 'done
1031 (if (equal (aref range i) val)
1032 (throw 'done (1+ i))
1034 (error "Val not in range for %S" sym)))
1043 ;;; Local Variables:
1044 ;;; outline-regexp: ";;\\*+"
1047 ;;; hydra.el ends here