New upstream version 0.13.6

1 files changed, 1267 insertions, 0 deletions

diff --git a/hydra.el b/hydra.el
new file mode 100644
index 0000000..09a0052
--- /dev/null
+++ b/hydra.el
@@ -0,0 +1,1267 @@
+;;; hydra.el --- Make bindings that stick around. -*- lexical-binding: t -*-
+
+;; Copyright (C) 2015  Free Software Foundation, Inc.
+
+;; Author: Oleh Krehel <ohwoeowho@gmail.com>
+;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
+;; URL: https://github.com/abo-abo/hydra
+;; Version: 0.13.6
+;; Keywords: bindings
+;; Package-Requires: ((cl-lib "0.5"))
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This package can be used to tie related commands into a family of
+;; short bindings with a common prefix - a Hydra.
+;;
+;; Once you summon the Hydra (through the prefixed binding), all the
+;; heads can be called in succession with only a short extension.
+;; The Hydra is vanquished once Hercules, any binding that isn't the
+;; Hydra's head, arrives.  Note that Hercules, besides vanquishing the
+;; 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 automagically.
+;;
+;; Here's an example Hydra, bound in the global map (you can use any
+;; keymap in place of `global-map'):
+;;
+;;     (defhydra hydra-zoom (global-map "<f2>")
+;;       "zoom"
+;;       ("g" text-scale-increase "in")
+;;       ("l" text-scale-decrease "out"))
+;;
+;; It allows to start a command chain either like this:
+;; "<f2> gg4ll5g", or "<f2> lgllg".
+;;
+;; Here's another approach, when you just want a "callable keymap":
+;;
+;;     (defhydra hydra-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"))
+;;
+;; This binds nothing so far, but if you follow up with:
+;;
+;;     (global-set-key (kbd "C-c C-v") 'hydra-toggle/body)
+;;
+;; you will have bound "C-c C-v a", "C-c C-v d" etc.
+;;
+;; Knowing that `defhydra' defines e.g. `hydra-toggle/body' command,
+;; you can nest Hydras if you wish, with `hydra-toggle/body' possibly
+;; becoming a blue head of another Hydra.
+;;
+;; If you want to learn all intricacies of using `defhydra' without
+;; having to figure it all out from this source code, check out the
+;; wiki: https://github.com/abo-abo/hydra/wiki. There's a wealth of
+;; information there. Everyone is welcome to bring the existing pages
+;; up to date and add new ones.
+;;
+;; Additionally, the file hydra-examples.el serves to demo most of the
+;; functionality.
+
+;;; Code:
+;;* Requires
+(require 'cl-lib)
+(require 'lv)
+
+(defvar hydra-curr-map nil
+  "The keymap of the current Hydra called.")
+
+(defvar hydra-curr-on-exit nil
+  "The on-exit predicate for the current Hydra.")
+
+(defvar hydra-curr-foreign-keys nil
+  "The current :foreign-keys behavior.")
+
+(defvar hydra-curr-body-fn nil
+  "The current hydra-.../body function.")
+
+(defvar hydra-deactivate nil
+  "If a Hydra head sets this to t, exit the Hydra.
+This will be done even if the head wasn't designated for exiting.")
+
+(defun hydra-set-transient-map (keymap on-exit &optional foreign-keys)
+  "Set KEYMAP to the highest priority.
+
+Call ON-EXIT when the KEYMAP is deactivated.
+
+FOREIGN-KEYS determines the deactivation behavior, when a command
+that isn't in KEYMAP is called:
+
+nil: deactivate KEYMAP and run the command.
+run: keep KEYMAP and run the command.
+warn: keep KEYMAP and issue a warning instead of running the command."
+  (if hydra-deactivate
+      (hydra-keyboard-quit)
+    (setq hydra-curr-map keymap)
+    (setq hydra-curr-on-exit on-exit)
+    (setq hydra-curr-foreign-keys foreign-keys)
+    (add-hook 'pre-command-hook 'hydra--clearfun)
+    (internal-push-keymap keymap 'overriding-terminal-local-map)))
+
+(defun hydra--clearfun ()
+  "Disable the current Hydra unless `this-command' is a head."
+  (unless (eq this-command 'hydra-pause-resume)
+    (when (or
+           (memq this-command '(handle-switch-frame
+                                keyboard-quit))
+           (null overriding-terminal-local-map)
+           (not (or (eq this-command
+                        (lookup-key hydra-curr-map (this-single-command-keys)))
+                    (cl-case hydra-curr-foreign-keys
+                      (warn
+                       (setq this-command 'hydra-amaranth-warn))
+                      (run
+                       t)
+                      (t nil)))))
+      (hydra-disable))))
+
+(defvar hydra--ignore nil
+  "When non-nil, don't call `hydra-curr-on-exit'.")
+
+(defvar hydra--input-method-function nil
+  "Store overridden `input-method-function' here.")
+
+(defun hydra-disable ()
+  "Disable the current Hydra."
+  (setq hydra-deactivate nil)
+  (remove-hook 'pre-command-hook 'hydra--clearfun)
+  (unless hydra--ignore
+    (if (fboundp 'remove-function)
+        (remove-function input-method-function #'hydra--imf)
+      (when hydra--input-method-function
+        (setq input-method-function hydra--input-method-function)
+        (setq hydra--input-method-function nil))))
+  (dolist (frame (frame-list))
+    (with-selected-frame frame
+      (when overriding-terminal-local-map
+        (internal-pop-keymap hydra-curr-map 'overriding-terminal-local-map))))
+  (unless hydra--ignore
+    (when hydra-curr-on-exit
+      (let ((on-exit hydra-curr-on-exit))
+        (setq hydra-curr-on-exit nil)
+        (funcall on-exit)))))
+
+(unless (fboundp 'internal-push-keymap)
+  (defun internal-push-keymap (keymap symbol)
+    (let ((map (symbol-value symbol)))
+      (unless (memq keymap map)
+        (unless (memq 'add-keymap-witness (symbol-value symbol))
+          (setq map (make-composed-keymap nil (symbol-value symbol)))
+          (push 'add-keymap-witness (cdr map))
+          (set symbol map))
+        (push keymap (cdr map))))))
+
+(unless (fboundp 'internal-pop-keymap)
+  (defun internal-pop-keymap (keymap symbol)
+    (let ((map (symbol-value symbol)))
+      (when (memq keymap map)
+        (setf (cdr map) (delq keymap (cdr map))))
+      (let ((tail (cddr map)))
+        (and (or (null tail) (keymapp tail))
+             (eq 'add-keymap-witness (nth 1 map))
+             (set symbol tail))))))
+
+(defun hydra-amaranth-warn ()
+  "Issue a warning that the current input was ignored."
+  (interactive)
+  (message "An amaranth Hydra can only exit through a blue head"))
+
+;;* Customize
+(defgroup hydra nil
+  "Make bindings that stick around."
+  :group 'bindings
+  :prefix "hydra-")
+
+(defcustom hydra-is-helpful t
+  "When t, display a hint with possible bindings in the echo area."
+  :type 'boolean
+  :group 'hydra)
+
+(defcustom hydra-default-hint ""
+  "Default :hint property to use for heads when not specified in
+the body or the head."
+  :type 'sexp
+  :group 'hydra)
+
+(defcustom hydra-lv t
+  "When non-nil, `lv-message' (not `message') will be used to display hints."
+  :type 'boolean)
+
+(defcustom hydra-verbose nil
+  "When non-nil, hydra will issue some non essential style warnings."
+  :type 'boolean)
+
+(defcustom hydra-key-format-spec "%s"
+  "Default `format'-style specifier for _a_  syntax in docstrings.
+When nil, you can specify your own at each location like this: _ 5a_.")
+
+(defcustom hydra-doc-format-spec "%s"
+  "Default `format'-style specifier for ?a?  syntax in docstrings.")
+
+(make-obsolete-variable
+ 'hydra-key-format-spec
+ "Since the docstrings are aligned by hand anyway, this isn't very useful."
+ "0.13.1")
+
+(defface hydra-face-red
+  '((t (:foreground "#FF0000" :bold t)))
+  "Red Hydra heads don't exit the Hydra.
+Every other command exits the Hydra."
+  :group 'hydra)
+
+(defface hydra-face-blue
+  '((((class color) (background light))
+     :foreground "#0000FF" :bold t)
+    (((class color) (background dark))
+     :foreground "#8ac6f2" :bold t))
+  "Blue Hydra heads exit the Hydra.
+Every other command exits as well.")
+
+(defface hydra-face-amaranth
+  '((t (:foreground "#E52B50" :bold t)))
+  "Amaranth body has red heads and warns on intercepting non-heads.
+Exitable only through a blue head.")
+
+(defface hydra-face-pink
+  '((t (:foreground "#FF6EB4" :bold t)))
+  "Pink body has red heads and runs intercepted non-heads.
+Exitable only through a blue head.")
+
+(defface hydra-face-teal
+  '((t (:foreground "#367588" :bold t)))
+  "Teal body has blue heads and warns on intercepting non-heads.
+Exitable only through a blue head.")
+
+;;* Fontification
+(defun hydra-add-font-lock ()
+  "Fontify `defhydra' statements."
+  (font-lock-add-keywords
+   'emacs-lisp-mode
+   '(("(\\(defhydra\\)\\_> +\\(.*?\\)\\_>"
+      (1 font-lock-keyword-face)
+      (2 font-lock-type-face))
+     ("(\\(defhydradio\\)\\_> +\\(.*?\\)\\_>"
+      (1 font-lock-keyword-face)
+      (2 font-lock-type-face)))))
+
+;;* Find Function
+(eval-after-load 'find-func
+  '(defadvice find-function-search-for-symbol
+    (around hydra-around-find-function-search-for-symbol-advice
+     (symbol type library) activate)
+    "Navigate to hydras with `find-function-search-for-symbol'."
+    ad-do-it
+    ;; The orignial function returns (cons (current-buffer) (point))
+    ;; if it found the point.
+    (unless (cdr ad-return-value)
+      (with-current-buffer (find-file-noselect library)
+        (let ((sn (symbol-name symbol)))
+          (when (and (null type)
+                     (string-match "\\`\\(hydra-[a-z-A-Z0-9]+\\)/\\(.*\\)\\'" sn)
+                     (re-search-forward (concat "(defhydra " (match-string 1 sn))
+                                        nil t))
+            (goto-char (match-beginning 0)))
+          (cons (current-buffer) (point)))))))
+
+;;* Universal Argument
+(defvar hydra-base-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map [?\C-u] 'hydra--universal-argument)
+    (define-key map [?-] 'hydra--negative-argument)
+    (define-key map [?0] 'hydra--digit-argument)
+    (define-key map [?1] 'hydra--digit-argument)
+    (define-key map [?2] 'hydra--digit-argument)
+    (define-key map [?3] 'hydra--digit-argument)
+    (define-key map [?4] 'hydra--digit-argument)
+    (define-key map [?5] 'hydra--digit-argument)
+    (define-key map [?6] 'hydra--digit-argument)
+    (define-key map [?7] 'hydra--digit-argument)
+    (define-key map [?8] 'hydra--digit-argument)
+    (define-key map [?9] 'hydra--digit-argument)
+    (define-key map [kp-0] 'hydra--digit-argument)
+    (define-key map [kp-1] 'hydra--digit-argument)
+    (define-key map [kp-2] 'hydra--digit-argument)
+    (define-key map [kp-3] 'hydra--digit-argument)
+    (define-key map [kp-4] 'hydra--digit-argument)
+    (define-key map [kp-5] 'hydra--digit-argument)
+    (define-key map [kp-6] 'hydra--digit-argument)
+    (define-key map [kp-7] 'hydra--digit-argument)
+    (define-key map [kp-8] 'hydra--digit-argument)
+    (define-key map [kp-9] 'hydra--digit-argument)
+    (define-key map [kp-subtract] 'hydra--negative-argument)
+    map)
+  "Keymap that all Hydras inherit.  See `universal-argument-map'.")
+
+(defun hydra--universal-argument (arg)
+  "Forward to (`universal-argument' ARG)."
+  (interactive "P")
+  (setq prefix-arg (if (consp arg)
+                       (list (* 4 (car arg)))
+                     (if (eq arg '-)
+                         (list -4)
+                       '(4)))))
+
+(defun hydra--digit-argument (arg)
+  "Forward to (`digit-argument' ARG)."
+  (interactive "P")
+  (let* ((char (if (integerp last-command-event)
+                   last-command-event
+                 (get last-command-event 'ascii-character)))
+         (digit (- (logand char ?\177) ?0)))
+    (setq prefix-arg (cond ((integerp arg)
+                            (+ (* arg 10)
+                               (if (< arg 0)
+                                   (- digit)
+                                 digit)))
+                           ((eq arg '-)
+                            (if (zerop digit)
+                                '-
+                              (- digit)))
+                           (t
+                            digit)))))
+
+(defun hydra--negative-argument (arg)
+  "Forward to (`negative-argument' ARG)."
+  (interactive "P")
+  (setq prefix-arg (cond ((integerp arg) (- arg))
+                         ((eq arg '-) nil)
+                         (t '-))))
+
+;;* Repeat
+(defvar hydra-repeat--prefix-arg nil
+  "Prefix arg to use with `hydra-repeat'.")
+
+(defvar hydra-repeat--command nil
+  "Command to use with `hydra-repeat'.")
+
+(defun hydra-repeat (&optional arg)
+  "Repeat last command with last prefix arg.
+When ARG is non-nil, use that instead."
+  (interactive "p")
+  (if (eq arg 1)
+      (unless (string-match "hydra-repeat$" (symbol-name last-command))
+        (setq hydra-repeat--command last-command)
+        (setq hydra-repeat--prefix-arg last-prefix-arg))
+    (setq hydra-repeat--prefix-arg arg))
+  (setq current-prefix-arg hydra-repeat--prefix-arg)
+  (funcall hydra-repeat--command))
+
+;;* Misc internals
+(defun hydra--callablep (x)
+  "Test if X is callable."
+  (or (functionp x)
+      (and (consp x)
+           (memq (car x) '(function quote)))))
+
+(defun hydra--make-callable (x)
+  "Generate a callable symbol from X.
+If X is a function symbol or a lambda, return it.  Otherwise, it
+should be a single statement.  Wrap it in an interactive lambda."
+  (cond ((or (symbolp x) (functionp x))
+         x)
+        ((and (consp x) (eq (car x) 'function))
+         (cadr x))
+        (t
+         `(lambda ()
+            (interactive)
+            ,x))))
+
+(defun hydra-plist-get-default (plist prop default)
+  "Extract a value from a property list.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2...).
+
+Return the value corresponding to PROP, or DEFAULT if PROP is not
+one of the properties on the list."
+  (if (memq prop plist)
+      (plist-get plist prop)
+    default))
+
+(defun hydra--head-property (h prop &optional default)
+  "Return for Hydra head H the value of property PROP.
+Return DEFAULT if PROP is not in H."
+  (hydra-plist-get-default (cl-cdddr h) prop default))
+
+(defun hydra--body-foreign-keys (body)
+  "Return what BODY does with a non-head binding."
+  (or
+   (plist-get (cddr body) :foreign-keys)
+   (let ((color (plist-get (cddr body) :color)))
+     (cl-case color
+       ((amaranth teal) 'warn)
+       (pink 'run)))))
+
+(defun hydra--body-exit (body)
+  "Return the exit behavior of BODY."
+  (or
+   (plist-get (cddr body) :exit)
+   (let ((color (plist-get (cddr body) :color)))
+     (cl-case color
+       ((blue teal) t)
+       (t nil)))))
+
+(defalias 'hydra--imf #'list)
+
+(defun hydra-default-pre ()
+  "Default setup that happens in each head before :pre."
+  (when (eq input-method-function 'key-chord-input-method)
+    (if (fboundp 'add-function)
+        (add-function :override input-method-function #'hydra--imf)
+      (unless hydra--input-method-function
+        (setq hydra--input-method-function input-method-function)
+        (setq input-method-function nil)))))
+
+(defvar hydra-timeout-timer (timer-create)
+  "Timer for `hydra-timeout'.")
+
+(defvar hydra-message-timer (timer-create)
+  "Timer for the hint.")
+
+(defvar hydra--work-around-dedicated t
+  "When non-nil, assume there's no bug in `pop-to-buffer'.
+`pop-to-buffer' should not select a dedicated window.")
+
+(defun hydra-keyboard-quit ()
+  "Quitting function similar to `keyboard-quit'."
+  (interactive)
+  (hydra-disable)
+  (cancel-timer hydra-timeout-timer)
+  (cancel-timer hydra-message-timer)
+  (setq hydra-curr-map nil)
+  (unless (and hydra--ignore
+               (null hydra--work-around-dedicated))
+    (if hydra-lv
+        (lv-delete-window)
+      (message "")))
+  nil)
+
+(defvar hydra-head-format "[%s]: "
+  "The formatter for each head of a plain docstring.")
+
+(defvar hydra-key-doc-function 'hydra-key-doc-function-default
+  "The function for formatting key-doc pairs.")
+
+(defun hydra-key-doc-function-default (key key-width doc doc-width)
+  "Doc"
+  (format (format "%%%ds: %%%ds" key-width (- -1 doc-width))
+          key doc))
+
+(defun hydra--to-string (x)
+  (if (stringp x)
+      x
+    (eval x)))
+
+(defun hydra--hint (body heads)
+  "Generate a hint for the echo area.
+BODY, and HEADS are parameters to `defhydra'."
+  (let (alist)
+    (dolist (h heads)
+      (let ((val (assoc (cadr h) alist))
+            (pstr (hydra-fontify-head h body)))
+        (unless (null (cl-caddr h))
+          (if val
+              (setf (cadr val)
+                    (concat (cadr val) " " pstr))
+            (push
+             (cons (cadr h)
+                   (cons pstr (cl-caddr h)))
+             alist)))))
+    (let ((keys (nreverse (mapcar #'cdr alist)))
+          (n-cols (plist-get (cddr body) :columns))
+          res)
+      (setq res
+            (if n-cols
+                (let ((n-rows (1+ (/ (length keys) n-cols)))
+                      (max-key-len (apply #'max (mapcar (lambda (x) (length (car x))) keys)))
+                      (max-doc-len (apply #'max (mapcar (lambda (x)
+                                                          (length (hydra--to-string (cdr x)))) keys))))
+                  `(concat
+                    "\n"
+                    (mapconcat #'identity
+                               (mapcar
+                                (lambda (x)
+                                  (mapconcat
+                                   (lambda (y)
+                                     (and y
+                                          (funcall hydra-key-doc-function
+                                                   (car y)
+                                                   ,max-key-len
+                                                   (hydra--to-string (cdr y))
+                                                   ,max-doc-len))) x ""))
+                                ',(hydra--matrix keys n-cols n-rows))
+                               "\n")))
+
+
+              `(concat
+                (mapconcat
+                 (lambda (x)
+                   (let ((str (hydra--to-string (cdr x))))
+                     (format
+                      (if (> (length str) 0)
+                          (concat hydra-head-format str)
+                        "%s")
+                      (car x))))
+                 ',keys
+                 ", ")
+                ,(if keys "." ""))))
+      (if (cl-every #'stringp
+                    (mapcar 'cddr alist))
+          (eval res)
+        res))))
+
+(defvar hydra-fontify-head-function nil
+  "Possible replacement for `hydra-fontify-head-default'.")
+
+(defun hydra-fontify-head-default (head body)
+  "Produce a pretty string from HEAD and BODY.
+HEAD's binding is returned as a string with a colored face."
+  (let* ((foreign-keys (hydra--body-foreign-keys body))
+         (head-exit (hydra--head-property head :exit))
+         (head-color
+          (if head-exit
+              (if (eq foreign-keys 'warn)
+                  'teal
+                'blue)
+            (cl-case foreign-keys
+              (warn 'amaranth)
+              (run 'pink)
+              (t 'red)))))
+    (when (and (null (cadr head))
+               (not head-exit))
+      (hydra--complain "nil cmd can only be blue"))
+    (propertize (if (string= (car head) "%")
+                    "%%"
+                  (car head))
+                'face
+                (or (hydra--head-property head :face)
+                    (cl-case head-color
+                      (blue 'hydra-face-blue)
+                      (red 'hydra-face-red)
+                      (amaranth 'hydra-face-amaranth)
+                      (pink 'hydra-face-pink)
+                      (teal 'hydra-face-teal)
+                      (t (error "Unknown color for %S" head)))))))
+
+(defun hydra-fontify-head-greyscale (head _body)
+  "Produce a pretty string from HEAD and BODY.
+HEAD's binding is returned as a string wrapped with [] or {}."
+  (format
+   (if (hydra--head-property head :exit)
+       "[%s]"
+     "{%s}") (car head)))
+
+(defun hydra-fontify-head (head body)
+  "Produce a pretty string from HEAD and BODY."
+  (funcall (or hydra-fontify-head-function 'hydra-fontify-head-default)
+           head body))
+
+(defun hydra--strip-align-markers (str)
+  "Remove ^ from STR, unless they're escaped: \\^."
+  (let ((start 0))
+    (while (setq start (string-match "\\\\?\\^" str start))
+      (if (eq (- (match-end 0) (match-beginning 0)) 2)
+          (progn
+            (setq str (replace-match "^" nil nil str))
+            (cl-incf start))
+        (setq str (replace-match "" nil nil str))))
+    str))
+
+(defvar hydra-docstring-keys-translate-alist
+  '(("↑" . "<up>")
+    ("↓" . "<down>")
+    ("→" . "<right>")
+    ("←" . "<left>")
+    ("⌫" . "DEL")
+    ("⌦" . "<deletechar>")
+    ("⏎" . "RET")))
+
+(defconst hydra-width-spec-regex " ?-?[0-9]*?"
+  "Regex for the width spec in keys and %` quoted sexps.")
+
+(defvar hydra-key-regex "\\[\\|]\\|[-[:alnum:] ~.,;:/|?<>={}*+#%@!&^↑↓←→⌫⌦⏎'`()\"$]+?"
+  "Regex for the key quoted in the docstring.")
+
+(defun hydra--format (_name body docstring heads)
+  "Generate a `format' statement from STR.
+\"%`...\" expressions are extracted into \"%S\".
+_NAME, BODY, DOCSTRING and HEADS are parameters of `defhydra'.
+The expressions can be auto-expanded according to NAME."
+  (setq docstring (hydra--strip-align-markers docstring))
+  (setq docstring (replace-regexp-in-string "___" "_β_" docstring))
+  (let ((rest (if (eq (plist-get (cddr body) :hint) 'none)
+                  ""
+                (hydra--hint body heads)))
+        (start 0)
+        varlist
+        offset)
+    (while (setq start
+                 (string-match
+                  (format
+                   "\\(?:%%\\( ?-?[0-9]*s?\\)\\(`[a-z-A-Z/0-9]+\\|(\\)\\)\\|\\(?:[_?]\\(%s\\)\\(%s\\)[_?]\\)"
+                   hydra-width-spec-regex
+                   hydra-key-regex)
+                  docstring start))
+      (cond ((eq ?? (aref (match-string 0 docstring) 0))
+             (let* ((key (match-string 4 docstring))
+                    (head (assoc key heads)))
+               (if head
+                   (progn
+                     (push (nth 2 head) varlist)
+                     (setq docstring
+                           (replace-match
+                            (or
+                             hydra-doc-format-spec
+                             (concat "%" (match-string 3 docstring) "s"))
+                            t nil docstring)))
+                 (setq start (match-end 0))
+                 (warn "Unrecognized key: ?%s?" key))))
+            ((eq ?_ (aref (match-string 0 docstring) 0))
+             (let* ((key (match-string 4 docstring))
+                    (key (if (equal key "β") "_" key))
+                    normal-key
+                    (head (or (assoc key heads)
+                              (when (setq normal-key
+                                          (cdr (assoc
+                                                key hydra-docstring-keys-translate-alist)))
+                                (assoc normal-key heads)))))
+               (if head
+                   (progn
+                     (push (hydra-fontify-head (if normal-key
+                                                   (cons key (cdr head))
+                                                 head)
+                                               body)
+                           varlist)
+                     (let ((replacement
+                            (or
+                             hydra-key-format-spec
+                             (concat "%" (match-string 3 docstring) "s"))))
+                       (setq docstring
+                             (replace-match replacement t nil docstring))
+                       (setq start (+ start (length replacement)))))
+                 (setq start (match-end 0))
+                 (warn "Unrecognized key: _%s_" key))))
+
+            (t
+             (let* ((varp (if (eq ?` (aref (match-string 2 docstring) 0)) 1 0))
+                    (spec (match-string 1 docstring))
+                    (lspec (length spec)))
+               (setq offset
+                     (with-temp-buffer
+                       (insert (substring docstring (+ 1 start varp
+                                                       (length spec))))
+                       (goto-char (point-min))
+                       (push (read (current-buffer)) varlist)
+                       (- (point) (point-min))))
+               (when (or (zerop lspec)
+                         (/= (aref spec (1- (length spec))) ?s))
+                 (setq spec (concat spec "S")))
+               (setq docstring
+                     (concat
+                      (substring docstring 0 start)
+                      "%" spec
+                      (substring docstring (+ start offset 1 lspec varp))))))))
+    (if (eq ?\n (aref docstring 0))
+        `(concat (format ,(substring docstring 1) ,@(nreverse varlist))
+                 ,rest)
+      (let ((r `(replace-regexp-in-string
+                 " +$" ""
+                 (concat ,docstring ": "
+                         (replace-regexp-in-string
+                          "\\(%\\)" "\\1\\1" ,rest)))))
+        (if (stringp rest)
+            `(format ,(eval r))
+          `(format ,r))))))
+
+(defun hydra--complain (format-string &rest args)
+  "Forward to (`message' FORMAT-STRING ARGS) unless `hydra-verbose' is nil."
+  (if hydra-verbose
+      (apply #'error format-string args)
+    (apply #'message format-string args)))
+
+(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)))
+
+(defun hydra--call-interactively (cmd name)
+  "Generate a `call-interactively' statement for CMD.
+Set `this-command' to NAME."
+  (if (and (symbolp name)
+           (not (memq name '(nil body))))
+      `(progn
+         (setq this-command ',name)
+         (call-interactively #',cmd))
+    `(call-interactively #',cmd)))
+
+(defun hydra--make-defun (name body doc head
+                          keymap body-pre body-before-exit
+                          &optional body-after-exit)
+  "Make a defun wrapper, using NAME, BODY, DOC, HEAD, and KEYMAP.
+NAME and BODY are the arguments to `defhydra'.
+DOC was generated with `hydra--doc'.
+HEAD is one of the HEADS passed to `defhydra'.
+BODY-PRE is added to the start of the wrapper.
+BODY-BEFORE-EXIT will be called before the hydra quits.
+BODY-AFTER-EXIT is added to the end of the wrapper."
+  (let ((cmd-name (hydra--head-name head name))
+        (cmd (when (car head)
+               (hydra--make-callable
+                (cadr head))))
+        (doc (if (car head)
+                 (format "%s\n\nCall the head: `%S'." doc (cadr head))
+               doc))
+        (hint (intern (format "%S/hint" name)))
+        (body-foreign-keys (hydra--body-foreign-keys body))
+        (body-timeout (plist-get body :timeout))
+        (body-idle (plist-get body :idle)))
+    `(defun ,cmd-name ()
+       ,doc
+       (interactive)
+       (hydra-default-pre)
+       ,@(when body-pre (list body-pre))
+       ,@(if (hydra--head-property head :exit)
+             `((hydra-keyboard-quit)
+               (setq hydra-curr-body-fn ',(intern (format "%S/body" name)))
+               ,@(if body-after-exit
+                     `((unwind-protect
+                            ,(when cmd
+                               (hydra--call-interactively cmd (cadr head)))
+                         ,body-after-exit))
+                   (when cmd
+                     `(,(hydra--call-interactively cmd (cadr head))))))
+           (delq
+            nil
+            `((let ((hydra--ignore ,(not (eq (cadr head) 'body))))
+                (hydra-keyboard-quit)
+                (setq hydra-curr-body-fn ',(intern (format "%S/body" name))))
+              ,(when cmd
+                 `(condition-case err
+                      ,(hydra--call-interactively cmd (cadr head))
+                    ((quit error)
+                     (message "%S" err)
+                     (unless hydra-lv
+                       (sit-for 0.8)))))
+              ,(if (and body-idle (eq (cadr head) 'body))
+                   `(hydra-idle-message ,body-idle ,hint ',name)
+                 `(hydra-show-hint ,hint ',name))
+              (hydra-set-transient-map
+               ,keymap
+               (lambda () (hydra-keyboard-quit) ,body-before-exit)
+               ,(when body-foreign-keys
+                  (list 'quote body-foreign-keys)))
+              ,body-after-exit
+              ,(when body-timeout
+                 `(hydra-timeout ,body-timeout))))))))
+
+(defvar hydra-props-alist nil)
+
+(defun hydra-set-property (name key val)
+  "Set hydra property.
+NAME is the symbolic name of the hydra.
+KEY and VAL are forwarded to `plist-put'."
+  (let ((entry (assoc name hydra-props-alist))
+        plist)
+    (when (null entry)
+      (add-to-list 'hydra-props-alist (list name))
+      (setq entry (assoc name hydra-props-alist)))
+    (setq plist (cdr entry))
+    (setcdr entry (plist-put plist key val))))
+
+(defun hydra-get-property (name key)
+  "Get hydra property.
+NAME is the symbolic name of the hydra.
+KEY is forwarded to `plist-get'."
+  (let ((entry (assoc name hydra-props-alist)))
+    (when entry
+      (plist-get (cdr entry) key))))
+
+(defun hydra-show-hint (hint caller)
+  (let ((verbosity (plist-get (cdr (assoc caller hydra-props-alist))
+                              :verbosity)))
+    (cond ((eq verbosity 0))
+          ((eq verbosity 1)
+           (message (eval hint)))
+          (t
+           (when hydra-is-helpful
+             (if hydra-lv
+                 (lv-message (eval hint))
+               (message (eval hint))))))))
+
+(defmacro hydra--make-funcall (sym)
+  "Transform SYM into a `funcall' to call it."
+  `(when (and ,sym (symbolp ,sym))
+     (setq ,sym `(funcall #',,sym))))
+
+(defun hydra--head-name (h name)
+  "Return the symbol for head H of hydra with NAME."
+  (let ((str (format "%S/%s" name
+                     (cond ((symbolp (cadr h))
+                            (cadr h))
+                           ((and (consp (cadr h))
+                                 (eq (cl-caadr h) 'function))
+                            (cadr (cadr h)))
+                           (t
+                            (concat "lambda-" (car h)))))))
+    (when (and (hydra--head-property h :exit)
+               (not (memq (cadr h) '(body nil))))
+      (setq str (concat str "-and-exit")))
+    (intern str)))
+
+(defun hydra--delete-duplicates (heads)
+  "Return HEADS without entries that have the same CMD part.
+In duplicate HEADS, :cmd-name is modified to whatever they duplicate."
+  (let ((ali '(((hydra-repeat . nil) . hydra-repeat)))
+        res entry)
+    (dolist (h heads)
+      (if (setq entry (assoc (cons (cadr h)
+                                   (hydra--head-property h :exit))
+                             ali))
+          (setf (cl-cdddr h) (plist-put (cl-cdddr h) :cmd-name (cdr entry)))
+        (push (cons (cons (cadr h)
+                          (hydra--head-property h :exit))
+                    (plist-get (cl-cdddr h) :cmd-name))
+              ali)
+        (push h res)))
+    (nreverse res)))
+
+(defun hydra--pad (lst n)
+  "Pad LST with nil until length N."
+  (let ((len (length lst)))
+    (if (= len n)
+        lst
+      (append lst (make-list (- n len) nil)))))
+
+(defmacro hydra-multipop (lst n)
+  "Return LST's first N elements while removing them."
+  `(if (<= (length ,lst) ,n)
+       (prog1 ,lst
+         (setq ,lst nil))
+     (prog1 ,lst
+       (setcdr
+        (nthcdr (1- ,n) (prog1 ,lst (setq ,lst (nthcdr ,n ,lst))))
+        nil))))
+
+(defun hydra--matrix (lst rows cols)
+  "Create a matrix from elements of LST.
+The matrix size is ROWS times COLS."
+  (let ((ls (copy-sequence lst))
+        res)
+    (dotimes (_c cols)
+      (push (hydra--pad (hydra-multipop ls rows) rows) res))
+    (nreverse res)))
+
+(defun hydra--cell (fstr names)
+  "Format a rectangular cell based on FSTR and NAMES.
+FSTR is a format-style string with two string inputs: one for the
+doc and one for the symbol name.
+NAMES is a list of variables."
+  (let ((len (cl-reduce
+              (lambda (acc it) (max (length (symbol-name it)) acc))
+              names
+              :initial-value 0)))
+    (mapconcat
+     (lambda (sym)
+       (if sym
+           (format fstr
+                   (documentation-property sym 'variable-documentation)
+                   (let ((name (symbol-name sym)))
+                     (concat name (make-string (- len (length name)) ?^)))
+                   sym)
+         ""))
+     names
+     "\n")))
+
+(defun hydra--vconcat (strs &optional joiner)
+  "Glue STRS vertically.  They must be the same height.
+JOINER is a function similar to `concat'."
+  (setq joiner (or joiner #'concat))
+  (mapconcat
+   (lambda (s)
+     (if (string-match " +$" s)
+         (replace-match "" nil nil s)
+       s))
+   (apply #'cl-mapcar joiner
+          (mapcar
+           (lambda (s) (split-string s "\n"))
+           strs))
+   "\n"))
+
+(defvar hydra-cell-format "% -20s %% -8`%s"
+  "The default format for docstring cells.")
+
+(defun hydra--table (names rows cols &optional cell-formats)
+  "Format a `format'-style table from variables in NAMES.
+The size of the table is ROWS times COLS.
+CELL-FORMATS are `format' strings for each column.
+If CELL-FORMATS is a string, it's used for all columns.
+If CELL-FORMATS is nil, `hydra-cell-format' is used for all columns."
+  (setq cell-formats
+        (cond ((null cell-formats)
+               (make-list cols hydra-cell-format))
+              ((stringp cell-formats)
+               (make-list cols cell-formats))
+              (t
+               cell-formats)))
+  (hydra--vconcat
+   (cl-mapcar
+    #'hydra--cell
+    cell-formats
+    (hydra--matrix names rows cols))
+   (lambda (&rest x)
+     (mapconcat #'identity x "    "))))
+
+(defun hydra-reset-radios (names)
+  "Set varibles NAMES to their defaults.
+NAMES should be defined by `defhydradio' or similar."
+  (dolist (n names)
+    (set n (aref (get n 'range) 0))))
+
+(defun hydra-idle-message (secs hint name)
+  "In SECS seconds display HINT."
+  (cancel-timer hydra-message-timer)
+  (setq hydra-message-timer (timer-create))
+  (timer-set-time hydra-message-timer
+                  (timer-relative-time (current-time) secs))
+  (timer-set-function
+   hydra-message-timer
+   (lambda ()
+     (hydra-show-hint hint name)
+     (cancel-timer hydra-message-timer)))
+  (timer-activate hydra-message-timer))
+
+(defun hydra-timeout (secs &optional function)
+  "In SECS seconds call FUNCTION, then function `hydra-keyboard-quit'.
+Cancel the previous `hydra-timeout'."
+  (cancel-timer hydra-timeout-timer)
+  (setq hydra-timeout-timer (timer-create))
+  (timer-set-time hydra-timeout-timer
+                  (timer-relative-time (current-time) secs))
+  (timer-set-function
+   hydra-timeout-timer
+   `(lambda ()
+      ,(when function
+         `(funcall ,function))
+      (hydra-keyboard-quit)))
+  (timer-activate hydra-timeout-timer))
+
+;;* Macros
+;;;###autoload
+(defmacro defhydra (name body &optional docstring &rest heads)
+  "Create a Hydra - a family of functions with prefix NAME.
+
+NAME should be a symbol, it will be the prefix of all functions
+defined here.
+
+BODY has the format:
+
+    (BODY-MAP BODY-KEY &rest BODY-PLIST)
+
+DOCSTRING will be displayed in the echo area to identify the
+Hydra.  When DOCSTRING starts with a newline, special Ruby-style
+substitution will be performed by `hydra--format'.
+
+Functions are created on basis of HEADS, each of which has the
+format:
+
+    (KEY CMD &optional HINT &rest PLIST)
+
+BODY-MAP is a keymap; `global-map' is used quite often.  Each
+function generated from HEADS will be bound in BODY-MAP to
+BODY-KEY + KEY (both are strings passed to `kbd'), and will set
+the transient map so that all following heads can be called
+though KEY only.  BODY-KEY can be an empty string.
+
+CMD is a callable expression: either an interactive function
+name, or an interactive lambda, or a single sexp (it will be
+wrapped in an interactive lambda).
+
+HINT is a short string that identifies its head.  It will be
+printed beside KEY in the echo erea if `hydra-is-helpful' is not
+nil.  If you don't even want the KEY to be printed, set HINT
+explicitly to nil.
+
+The heads inherit their PLIST from BODY-PLIST and are allowed to
+override some keys.  The keys recognized are :exit and :bind.
+:exit can be:
+
+- nil (default): this head will continue the Hydra state.
+- t: this head will stop the Hydra state.
+
+:bind can be:
+- nil: this head will not be bound in BODY-MAP.
+- a lambda taking KEY and CMD used to bind a head.
+
+It is possible to omit both BODY-MAP and BODY-KEY if you don't
+want to bind anything.  In that case, typically you will bind the
+generated NAME/body command.  This command is also the return
+result of `defhydra'."
+  (declare (indent defun))
+  (cond ((stringp docstring))
+        ((and (consp docstring)
+              (memq (car docstring) '(hydra--table concat format)))
+         (setq docstring (concat "\n" (eval docstring))))
+        (t
+         (setq heads (cons docstring heads))
+         (setq docstring "hydra")))
+  (when (keywordp (car body))
+    (setq body (cons nil (cons nil body))))
+  (condition-case-unless-debug err
+      (let* ((keymap (copy-keymap hydra-base-map))
+             (keymap-name (intern (format "%S/keymap" name)))
+             (body-name (intern (format "%S/body" name)))
+             (body-key (cadr body))
+             (body-plist (cddr body))
+             (body-map (or (car body)
+                           (plist-get body-plist :bind)))
+             (body-pre (plist-get body-plist :pre))
+             (body-body-pre (plist-get body-plist :body-pre))
+             (body-before-exit (or (plist-get body-plist :post)
+                                   (plist-get body-plist :before-exit)))
+             (body-after-exit (plist-get body-plist :after-exit))
+             (body-inherit (plist-get body-plist :inherit))
+             (body-foreign-keys (hydra--body-foreign-keys body))
+             (body-exit (hydra--body-exit body)))
+        (dolist (base body-inherit)
+          (setq heads (append heads (copy-sequence (eval base)))))
+        (dolist (h heads)
+          (let ((len (length h)))
+            (cond ((< len 2)
+                   (error "Each head should have at least two items: %S" h))
+                  ((= len 2)
+                   (setcdr (cdr h)
+                           (list
+                            (hydra-plist-get-default
+                             body-plist :hint hydra-default-hint)))
+                   (setcdr (nthcdr 2 h) (list :exit body-exit)))
+                  (t
+                   (let ((hint (cl-caddr h)))
+                     (unless (or (null hint)
+                                 (stringp hint)
+                                 (consp hint))
+                       (let ((inherited-hint
+                              (hydra-plist-get-default
+                               body-plist :hint hydra-default-hint)))
+                         (setcdr (cdr h) (cons
+                                          (if (eq 'none inherited-hint)
+                                              nil
+                                            inherited-hint)
+                                          (cddr h))))))
+                   (let ((hint-and-plist (cddr h)))
+                     (if (null (cdr hint-and-plist))
+                         (setcdr hint-and-plist (list :exit body-exit))
+                       (let* ((plist (cl-cdddr h))
+                              (h-color (plist-get plist :color)))
+                         (if h-color
+                             (progn
+                               (plist-put plist :exit
+                                          (cl-case h-color
+                                            ((blue teal) t)
+                                            (t nil)))
+                               (cl-remf (cl-cdddr h) :color))
+                           (let ((h-exit (hydra-plist-get-default plist :exit 'default)))
+                             (plist-put plist :exit
+                                        (if (eq h-exit 'default)
+                                            body-exit
+                                          h-exit))))))))))
+          (plist-put (cl-cdddr h) :cmd-name (hydra--head-name h name))
+          (when (null (cadr h)) (plist-put (cl-cdddr h) :exit t)))
+        (let ((doc (hydra--doc body-key body-name heads))
+              (heads-nodup (hydra--delete-duplicates heads)))
+          (mapc
+           (lambda (x)
+             (define-key keymap (kbd (car x))
+               (plist-get (cl-cdddr x) :cmd-name)))
+           heads)
+          (hydra--make-funcall body-pre)
+          (hydra--make-funcall body-body-pre)
+          (hydra--make-funcall body-before-exit)
+          (hydra--make-funcall body-after-exit)
+          (when (memq body-foreign-keys '(run warn))
+            (unless (cl-some
+                     (lambda (h)
+                       (hydra--head-property h :exit))
+                     heads)
+              (error
+               "An %S Hydra must have at least one blue head in order to exit"
+               body-foreign-keys)))
+          `(progn
+             ;; create keymap
+             (set (defvar ,keymap-name
+                    nil
+                    ,(format "Keymap for %S." name))
+                  ',keymap)
+             ;; declare heads
+             (set (defvar ,(intern (format "%S/heads" name))
+                    nil
+                    ,(format "Heads for %S." name))
+                  ',(mapcar (lambda (h)
+                              (let ((j (copy-sequence h)))
+                                (cl-remf (cl-cdddr j) :cmd-name)
+                                j))
+                            heads))
+             (set
+              (defvar ,(intern (format "%S/hint" name)) nil
+                ,(format "Dynamic hint for %S." name))
+              ',(hydra--format name body docstring heads))
+             ;; create defuns
+             ,@(mapcar
+                (lambda (head)
+                  (hydra--make-defun name body doc head keymap-name
+                                     body-pre
+                                     body-before-exit
+                                     body-after-exit))
+                heads-nodup)
+             ;; free up keymap prefix
+             ,@(unless (or (null body-key)
+                           (null body-map)
+                           (hydra--callablep body-map))
+                 `((unless (keymapp (lookup-key ,body-map (kbd ,body-key)))
+                     (define-key ,body-map (kbd ,body-key) nil))))
+             ;; bind keys
+             ,@(delq nil
+                     (mapcar
+                      (lambda (head)
+                        (let ((name (hydra--head-property head :cmd-name)))
+                          (when (and (cadr head)
+                                     (or body-key body-map))
+                            (let ((bind (hydra--head-property head :bind body-map))
+                                  (final-key
+                                   (if body-key
+                                       (vconcat (kbd body-key) (kbd (car head)))
+                                     (kbd (car head)))))
+                              (cond ((null bind) nil)
+                                    ((hydra--callablep bind)
+                                     `(funcall ,bind ,final-key (function ,name)))
+                                    ((and (symbolp bind)
+                                          (if (boundp bind)
+                                              (keymapp (symbol-value bind))
+                                            t))
+                                     `(define-key ,bind ,final-key (quote ,name)))
+                                    (t
+                                     (error "Invalid :bind property `%S' for head %S" bind head)))))))
+                      heads))
+             ,(hydra--make-defun
+               name body doc '(nil body)
+               keymap-name
+               (or body-body-pre body-pre) body-before-exit
+               '(setq prefix-arg current-prefix-arg)))))
+    (error
+     (hydra--complain "Error in defhydra %S: %s" name (cdr err))
+     nil)))
+
+(defmacro defhydradio (name _body &rest heads)
+  "Create radios with prefix NAME.
+_BODY specifies the options; there are none currently.
+HEADS have the format:
+
+    (TOGGLE-NAME &optional VALUE DOC)
+
+TOGGLE-NAME will be used along with NAME to generate a variable
+name and a function that cycles it with the same name.  VALUE
+should be an array.  The first element of VALUE will be used to
+inialize the variable.
+VALUE defaults to [nil t].
+DOC defaults to TOGGLE-NAME split and capitalized."
+  (declare (indent defun))
+  `(progn
+     ,@(apply #'append
+              (mapcar (lambda (h)
+                        (hydra--radio name h))
+                      heads))
+     (defvar ,(intern (format "%S/names" name))
+       ',(mapcar (lambda (h) (intern (format "%S/%S" name (car h))))
+                 heads))))
+
+(defun hydra--radio (parent head)
+  "Generate a hydradio with PARENT from HEAD."
+  (let* ((name (car head))
+         (full-name (intern (format "%S/%S" parent name)))
+         (doc (cadr head))
+         (val (or (cl-caddr head) [nil t])))
+    `((defvar ,full-name ,(hydra--quote-maybe (aref val 0)) ,doc)
+      (put ',full-name 'range ,val)
+      (defun ,full-name ()
+        (hydra--cycle-radio ',full-name)))))
+
+(defun hydra--quote-maybe (x)
+  "Quote X if it's a symbol."
+  (cond ((null x)
+         nil)
+        ((symbolp x)
+         (list 'quote x))
+        (t
+         x)))
+
+(defun hydra--cycle-radio (sym)
+  "Set SYM to the next value in its range."
+  (let* ((val (symbol-value sym))
+         (range (get sym 'range))
+         (i 0)
+         (l (length range)))
+    (setq i (catch 'done
+              (while (< i l)
+                (if (equal (aref range i) val)
+                    (throw 'done (1+ i))
+                  (cl-incf i)))
+              (error "Val not in range for %S" sym)))
+    (set sym
+         (aref range
+               (if (>= i l)
+                   0
+                 i)))))
+
+(defvar hydra-pause-ring (make-ring 10)
+  "Ring for paused hydras.")
+
+(defun hydra-pause-resume ()
+  "Quit the current hydra and save it to the stack.
+If there's no active hydra, pop one from the stack and call its body.
+If the stack is empty, call the last hydra's body."
+  (interactive)
+  (cond (hydra-curr-map
+         (ring-insert hydra-pause-ring hydra-curr-body-fn)
+         (hydra-keyboard-quit))
+        ((zerop (ring-length hydra-pause-ring))
+         (funcall hydra-curr-body-fn))
+        (t
+         (funcall (ring-remove hydra-pause-ring 0)))))
+
+;; Local Variables:
+;; outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|###autoload\\)\\|("
+;; indent-tabs-mode: nil
+;; End:
+
+(provide 'hydra)
+
+;;; hydra.el ends here