code.delx.au - gnu-emacs-elpa/blob - packages/hydra/hydra.el

   1 ;;; hydra.el --- Make bindings that stick around. -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2015  Free Software Foundation, Inc.
   4
   5 ;; Author: Oleh Krehel <ohwoeowho@gmail.com>
   6 ;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
   7 ;; URL: https://github.com/abo-abo/hydra
   8 ;; Version: 0.13.2
   9 ;; Keywords: bindings
  10 ;; Package-Requires: ((cl-lib "0.5"))
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; This package can be used to tie related commands into a family of
  30 ;; short bindings with a common prefix - a Hydra.
  31 ;;
  32 ;; Once you summon the Hydra (through the prefixed binding), all the
  33 ;; heads can be called in succession with only a short extension.
  34 ;; The Hydra is vanquished once Hercules, any binding that isn't the
  35 ;; Hydra's head, arrives.  Note that Hercules, besides vanquishing the
  36 ;; Hydra, will still serve his orignal purpose, calling his proper
  37 ;; command.  This makes the Hydra very seamless, it's like a minor
  38 ;; mode that disables itself automagically.
  39 ;;
  40 ;; Here's an example Hydra, bound in the global map (you can use any
  41 ;; keymap in place of `global-map'):
  42 ;;
  43 ;;     (defhydra hydra-zoom (global-map "<f2>")
  44 ;;       "zoom"
  45 ;;       ("g" text-scale-increase "in")
  46 ;;       ("l" text-scale-decrease "out"))
  47 ;;
  48 ;; It allows to start a command chain either like this:
  49 ;; "<f2> gg4ll5g", or "<f2> lgllg".
  50 ;;
  51 ;; Here's another approach, when you just want a "callable keymap":
  52 ;;
  53 ;;     (defhydra hydra-toggle (:color blue)
  54 ;;       "toggle"
  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"))
  61 ;;
  62 ;; This binds nothing so far, but if you follow up with:
  63 ;;
  64 ;;     (global-set-key (kbd "C-c C-v") 'hydra-toggle/body)
  65 ;;
  66 ;; you will have bound "C-c C-v a", "C-c C-v d" etc.
  67 ;;
  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.
  71 ;;
  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.
  76
  77 ;;; Code:
  78 ;;* Requires
  79 (require 'cl-lib)
  80 (require 'lv)
  81
  82 (defvar hydra-curr-map nil
  83   "The keymap of the current Hydra called.")
  84
  85 (defvar hydra-curr-on-exit nil
  86   "The on-exit predicate for the current Hydra.")
  87
  88 (defvar hydra-curr-foreign-keys nil
  89   "The current :foreign-keys behavior.")
  90
  91 (defvar hydra-deactivate nil
  92   "If a Hydra head sets this to t, exit the Hydra even if the
  93   head wasn't designated for exiting.")
  94
  95 (defun hydra-set-transient-map (keymap on-exit &optional foreign-keys)
  96   "Set KEYMAP to the highest priority.
  97
  98 Call ON-EXIT when the KEYMAP is deactivated.
  99
 100 FOREIGN-KEYS determines the deactivation behavior, when a command
 101 that isn't in KEYMAP is called:
 102
 103 nil: deactivate KEYMAP and run the command.
 104 run: keep KEYMAP and run the command.
 105 warn: keep KEYMAP and issue a warning instead of running the command."
 106   (if hydra-deactivate
 107       (hydra-keyboard-quit)
 108     (setq hydra-curr-map keymap)
 109     (setq hydra-curr-on-exit on-exit)
 110     (setq hydra-curr-foreign-keys foreign-keys)
 111     (add-hook 'pre-command-hook 'hydra--clearfun)
 112     (internal-push-keymap keymap 'overriding-terminal-local-map)))
 113
 114 (defun hydra--clearfun ()
 115   "Disable the current Hydra unless `this-command' is a head."
 116   (when (or
 117          (memq this-command '(handle-switch-frame keyboard-quit))
 118          (null overriding-terminal-local-map)
 119          (not (or (eq this-command
 120                       (lookup-key hydra-curr-map (this-single-command-keys)))
 121                   (cl-case hydra-curr-foreign-keys
 122                     (warn
 123                      (setq this-command 'hydra-amaranth-warn))
 124                     (run
 125                      t)
 126                     (t nil)))))
 127     (hydra-disable)))
 128
 129 (defvar hydra--ignore nil
 130   "When non-nil, don't call `hydra-curr-on-exit'")
 131
 132 (defvar hydra--input-method-function nil
 133   "Store overridden `input-method-function' here.")
 134
 135 (defun hydra-disable ()
 136   "Disable the current Hydra."
 137   (setq hydra-deactivate nil)
 138   (remove-hook 'pre-command-hook 'hydra--clearfun)
 139   (dolist (frame (frame-list))
 140     (with-selected-frame frame
 141       (when overriding-terminal-local-map
 142         (internal-pop-keymap hydra-curr-map 'overriding-terminal-local-map)
 143         (unless hydra--ignore
 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           (when hydra-curr-on-exit
 150             (let ((on-exit hydra-curr-on-exit))
 151               (setq hydra-curr-on-exit nil)
 152               (funcall on-exit))))))))
 153
 154 (unless (fboundp 'internal-push-keymap)
 155   (defun internal-push-keymap (keymap symbol)
 156     (let ((map (symbol-value symbol)))
 157       (unless (memq keymap map)
 158         (unless (memq 'add-keymap-witness (symbol-value symbol))
 159           (setq map (make-composed-keymap nil (symbol-value symbol)))
 160           (push 'add-keymap-witness (cdr map))
 161           (set symbol map))
 162         (push keymap (cdr map))))))
 163
 164 (unless (fboundp 'internal-pop-keymap)
 165   (defun internal-pop-keymap (keymap symbol)
 166     (let ((map (symbol-value symbol)))
 167       (when (memq keymap map)
 168         (setf (cdr map) (delq keymap (cdr map))))
 169       (let ((tail (cddr map)))
 170         (and (or (null tail) (keymapp tail))
 171              (eq 'add-keymap-witness (nth 1 map))
 172              (set symbol tail))))))
 173
 174 (defun hydra-amaranth-warn ()
 175   (interactive)
 176   (message "An amaranth Hydra can only exit through a blue head"))
 177
 178 ;;* Customize
 179 (defgroup hydra nil
 180   "Make bindings that stick around."
 181   :group 'bindings
 182   :prefix "hydra-")
 183
 184 (defcustom hydra-is-helpful t
 185   "When t, display a hint with possible bindings in the echo area."
 186   :type 'boolean
 187   :group 'hydra)
 188
 189 (defcustom hydra-lv t
 190   "When non-nil, `lv-message' (not `message') will be used to display hints."
 191   :type 'boolean)
 192
 193 (defcustom hydra-verbose nil
 194   "When non-nil, hydra will issue some non essential style warnings."
 195   :type 'boolean)
 196
 197 (defcustom hydra-key-format-spec "%s"
 198   "Default `format'-style specifier for _a_  syntax in docstrings.
 199 When nil, you can specify your own at each location like this: _ 5a_.")
 200
 201 (make-obsolete-variable
 202  'hydra-key-format-spec
 203  "Since the docstrings are aligned by hand anyway, this isn't very useful."
 204  "0.13.1")
 205
 206 (defface hydra-face-red
 207     '((t (:foreground "#FF0000" :bold t)))
 208   "Red Hydra heads don't exit the Hydra.
 209 Every other command exits the Hydra."
 210   :group 'hydra)
 211
 212 (defface hydra-face-blue
 213     '((t (:foreground "#0000FF" :bold t)))
 214   "Blue Hydra heads exit the Hydra.
 215 Every other command exits as well.")
 216
 217 (defface hydra-face-amaranth
 218     '((t (:foreground "#E52B50" :bold t)))
 219   "Amaranth body has red heads and warns on intercepting non-heads.
 220 Exitable only through a blue head.")
 221
 222 (defface hydra-face-pink
 223     '((t (:foreground "#FF6EB4" :bold t)))
 224   "Pink body has red heads and runs intercepted non-heads.
 225 Exitable only through a blue head.")
 226
 227 (defface hydra-face-teal
 228     '((t (:foreground "#367588" :bold t)))
 229   "Teal body has blue heads and warns on intercepting non-heads.
 230 Exitable only through a blue head.")
 231
 232 ;;* Fontification
 233 (defun hydra-add-font-lock ()
 234   "Fontify `defhydra' statements."
 235   (font-lock-add-keywords
 236    'emacs-lisp-mode
 237    '(("(\\(defhydra\\)\\_> +\\(.*?\\)\\_>"
 238       (1 font-lock-keyword-face)
 239       (2 font-lock-type-face))
 240      ("(\\(defhydradio\\)\\_> +\\(.*?\\)\\_>"
 241       (1 font-lock-keyword-face)
 242       (2 font-lock-type-face)))))
 243
 244 ;;* Universal Argument
 245 (defvar hydra-base-map
 246   (let ((map (make-sparse-keymap)))
 247     (define-key map [?\C-u] 'hydra--universal-argument)
 248     (define-key map [?-] 'hydra--negative-argument)
 249     (define-key map [?0] 'hydra--digit-argument)
 250     (define-key map [?1] 'hydra--digit-argument)
 251     (define-key map [?2] 'hydra--digit-argument)
 252     (define-key map [?3] 'hydra--digit-argument)
 253     (define-key map [?4] 'hydra--digit-argument)
 254     (define-key map [?5] 'hydra--digit-argument)
 255     (define-key map [?6] 'hydra--digit-argument)
 256     (define-key map [?7] 'hydra--digit-argument)
 257     (define-key map [?8] 'hydra--digit-argument)
 258     (define-key map [?9] 'hydra--digit-argument)
 259     (define-key map [kp-0] 'hydra--digit-argument)
 260     (define-key map [kp-1] 'hydra--digit-argument)
 261     (define-key map [kp-2] 'hydra--digit-argument)
 262     (define-key map [kp-3] 'hydra--digit-argument)
 263     (define-key map [kp-4] 'hydra--digit-argument)
 264     (define-key map [kp-5] 'hydra--digit-argument)
 265     (define-key map [kp-6] 'hydra--digit-argument)
 266     (define-key map [kp-7] 'hydra--digit-argument)
 267     (define-key map [kp-8] 'hydra--digit-argument)
 268     (define-key map [kp-9] 'hydra--digit-argument)
 269     (define-key map [kp-subtract] 'hydra--negative-argument)
 270     map)
 271   "Keymap that all Hydras inherit.  See `universal-argument-map'.")
 272
 273 (defun hydra--universal-argument (arg)
 274   "Forward to (`universal-argument' ARG)."
 275   (interactive "P")
 276   (setq prefix-arg (if (consp arg)
 277                        (list (* 4 (car arg)))
 278                      (if (eq arg '-)
 279                          (list -4)
 280                        '(4)))))
 281
 282 (defun hydra--digit-argument (arg)
 283   "Forward to (`digit-argument' ARG)."
 284   (interactive "P")
 285   (let* ((char (if (integerp last-command-event)
 286                    last-command-event
 287                  (get last-command-event 'ascii-character)))
 288          (digit (- (logand char ?\177) ?0)))
 289     (setq prefix-arg (cond ((integerp arg)
 290                             (+ (* arg 10)
 291                                (if (< arg 0)
 292                                    (- digit)
 293                                  digit)))
 294                            ((eq arg '-)
 295                             (if (zerop digit)
 296                                 '-
 297                               (- digit)))
 298                            (t
 299                             digit)))))
 300
 301 (defun hydra--negative-argument (arg)
 302   "Forward to (`negative-argument' ARG)."
 303   (interactive "P")
 304   (setq prefix-arg (cond ((integerp arg) (- arg))
 305                          ((eq arg '-) nil)
 306                          (t '-))))
 307
 308 ;;* Repeat
 309 (defvar hydra-repeat--prefix-arg nil
 310   "Prefix arg to use with `hydra-repeat'.")
 311
 312 (defvar hydra-repeat--command nil
 313   "Command to use with `hydra-repeat'.")
 314
 315 (defun hydra-repeat (&optional arg)
 316   "Repeat last command with last prefix arg.
 317 When ARG is non-nil, use that instead."
 318   (interactive "p")
 319   (if (eq arg 1)
 320       (unless (string-match "hydra-repeat$" (symbol-name last-command))
 321         (setq hydra-repeat--command last-command)
 322         (setq hydra-repeat--prefix-arg last-prefix-arg))
 323     (setq hydra-repeat--prefix-arg arg))
 324   (setq current-prefix-arg hydra-repeat--prefix-arg)
 325   (funcall hydra-repeat--command))
 326
 327 ;;* Misc internals
 328 (defun hydra--callablep (x)
 329   "Test if X is callable."
 330   (or (functionp x)
 331       (and (consp x)
 332            (memq (car x) '(function quote)))))
 333
 334 (defun hydra--make-callable (x)
 335   "Generate a callable symbol from X.
 336 If X is a function symbol or a lambda, return it.  Otherwise, it
 337 should be a single statement.  Wrap it in an interactive lambda."
 338   (if (or (symbolp x) (functionp x))
 339       x
 340     `(lambda ()
 341        (interactive)
 342        ,x)))
 343
 344 (defun hydra-plist-get-default (plist prop default)
 345   "Extract a value from a property list.
 346 PLIST is a property list, which is a list of the form
 347 \(PROP1 VALUE1 PROP2 VALUE2...).
 348
 349 Return the value corresponding to PROP, or DEFAULT if PROP is not
 350 one of the properties on the list."
 351   (if (memq prop plist)
 352       (plist-get plist prop)
 353     default))
 354
 355 (defun hydra--head-property (h prop &optional default)
 356   "Return for Hydra head H the value of property PROP.
 357 Return DEFAULT if PROP is not in H."
 358   (hydra-plist-get-default (cl-cdddr h) prop default))
 359
 360 (defun hydra--body-foreign-keys (body)
 361   "Return what BODY does with a non-head binding."
 362   (or
 363    (plist-get (cddr body) :foreign-keys)
 364    (let ((color (plist-get (cddr body) :color)))
 365      (cl-case color
 366        ((amaranth teal) 'warn)
 367        (pink 'run)))))
 368
 369 (defun hydra--body-exit (body)
 370   "Return the exit behavior of BODY."
 371   (or
 372    (plist-get (cddr body) :exit)
 373    (let ((color (plist-get (cddr body) :color)))
 374      (cl-case color
 375        ((blue teal) t)
 376        (t nil)))))
 377
 378 (defalias 'hydra--imf #'list)
 379
 380 (defun hydra-default-pre ()
 381   "Default setup that happens in each head before :pre."
 382   (when (eq input-method-function 'key-chord-input-method)
 383     (if (fboundp 'add-function)
 384         (add-function :override input-method-function #'hydra--imf)
 385       (unless hydra--input-method-function
 386         (setq hydra--input-method-function input-method-function)
 387         (setq input-method-function nil)))))
 388
 389 (defvar hydra-timeout-timer (timer-create)
 390   "Timer for `hydra-timeout'.")
 391
 392 (defvar hydra-message-timer (timer-create)
 393   "Timer for the hint.")
 394
 395 (defvar hydra--work-around-dedicated t
 396   "When non-nil, assume there's no bug in `pop-to-buffer'
 397   selecting a dedicated window.")
 398
 399 (defun hydra-keyboard-quit ()
 400   "Quitting function similar to `keyboard-quit'."
 401   (interactive)
 402   (hydra-disable)
 403   (cancel-timer hydra-timeout-timer)
 404   (cancel-timer hydra-message-timer)
 405   (unless (and hydra--ignore
 406                (null hydra--work-around-dedicated))
 407    (if hydra-lv
 408        (lv-delete-window)
 409      (message "")))
 410   nil)
 411
 412 (defun hydra--hint (body heads)
 413   "Generate a hint for the echo area.
 414 BODY, and HEADS are parameters to `defhydra'."
 415   (let (alist)
 416     (dolist (h heads)
 417       (let ((val (assoc (cadr h) alist))
 418             (pstr (hydra-fontify-head h body)))
 419         (unless (null (cl-caddr h))
 420           (if val
 421               (setf (cadr val)
 422                     (concat (cadr val) " " pstr))
 423             (push
 424              (cons (cadr h)
 425                    (cons pstr (cl-caddr h)))
 426              alist)))))
 427     (mapconcat
 428      (lambda (x)
 429        (format
 430         (if (> (length (cdr x)) 0)
 431             (concat "[%s]: " (cdr x))
 432           "%s")
 433         (car x)))
 434      (nreverse (mapcar #'cdr alist))
 435      ", ")))
 436
 437 (defvar hydra-fontify-head-function nil
 438   "Possible replacement for `hydra-fontify-head-default'.")
 439
 440 (defun hydra-fontify-head-default (head body)
 441   "Produce a pretty string from HEAD and BODY.
 442 HEAD's binding is returned as a string with a colored face."
 443   (let* ((foreign-keys (hydra--body-foreign-keys body))
 444          (head-exit (hydra--head-property head :exit))
 445          (head-color
 446           (if head-exit
 447               (if (eq foreign-keys 'warn)
 448                   'teal
 449                 'blue)
 450             (cl-case foreign-keys
 451               (warn 'amaranth)
 452               (run 'pink)
 453               (t 'red)))))
 454     (when (and (null (cadr head))
 455                (not head-exit))
 456       (hydra--complain "nil cmd can only be blue"))
 457     (propertize (car head) 'face
 458                 (cl-case head-color
 459                   (blue 'hydra-face-blue)
 460                   (red 'hydra-face-red)
 461                   (amaranth 'hydra-face-amaranth)
 462                   (pink 'hydra-face-pink)
 463                   (teal 'hydra-face-teal)
 464                   (t (error "Unknown color for %S" head))))))
 465
 466 (defun hydra-fontify-head-greyscale (head _body)
 467   "Produce a pretty string from HEAD and BODY.
 468 HEAD's binding is returned as a string wrapped with [] or {}."
 469   (format
 470    (if (hydra--head-property head :exit)
 471        "[%s]"
 472      "{%s}") (car head)))
 473
 474 (defun hydra-fontify-head (head body)
 475   "Produce a pretty string from HEAD and BODY."
 476   (funcall (or hydra-fontify-head-function 'hydra-fontify-head-default)
 477            head body))
 478
 479 (defun hydra--format (_name body docstring heads)
 480   "Generate a `format' statement from STR.
 481 \"%`...\" expressions are extracted into \"%S\".
 482 _NAME, BODY, DOCSTRING and HEADS are parameters of `defhydra'.
 483 The expressions can be auto-expanded according to NAME."
 484   (setq docstring (replace-regexp-in-string "\\^" "" docstring))
 485   (let ((rest (hydra--hint body heads))
 486         (start 0)
 487         varlist
 488         offset)
 489     (while (setq start
 490                  (string-match
 491                   "\\(?:%\\( ?-?[0-9]*s?\\)\\(`[a-z-A-Z/0-9]+\\|(\\)\\)\\|\\(?:_\\( ?-?[0-9]*?\\)\\([-[:alnum:] ~.,;:/|?<>={}*+#]+?\\)_\\)"
 492                   docstring start))
 493       (cond ((eq ?_ (aref (match-string 0 docstring) 0))
 494              (let* ((key (match-string 4 docstring))
 495                     (head (assoc key heads)))
 496                (if head
 497                    (progn
 498                      (push (hydra-fontify-head head body) varlist)
 499                      (setq docstring
 500                            (replace-match
 501                             (or
 502                              hydra-key-format-spec
 503                              (concat "%" (match-string 3 docstring) "s"))
 504                             t nil docstring)))
 505                  (error "Unrecognized key: _%s_" key))))
 506
 507             (t
 508              (let* ((varp (if (eq ?` (aref (match-string 2 docstring) 0)) 1 0))
 509                     (spec (match-string 1 docstring))
 510                     (lspec (length spec)))
 511                (setq offset
 512                      (with-temp-buffer
 513                        (insert (substring docstring (+ 1 start varp
 514                                                        (length spec))))
 515                        (goto-char (point-min))
 516                        (push (read (current-buffer)) varlist)
 517                        (- (point) (point-min))))
 518                (when (or (zerop lspec)
 519                          (/= (aref spec (1- (length spec))) ?s))
 520                  (setq spec (concat spec "S")))
 521                (setq docstring
 522                      (concat
 523                       (substring docstring 0 start)
 524                       "%" spec
 525                       (substring docstring (+ start offset 1 lspec varp))))))))
 526     (if (eq ?\n (aref docstring 0))
 527         `(concat (format ,(substring docstring 1) ,@(nreverse varlist))
 528                  ,rest)
 529       `(format ,(concat docstring ": " rest ".")))))
 530
 531 (defun hydra--complain (format-string &rest args)
 532   "Forward to (`message' FORMAT-STRING ARGS) unless `hydra-verbose' is nil."
 533   (if hydra-verbose
 534       (apply #'error format-string args)
 535     (apply #'message format-string args)))
 536
 537 (defun hydra--doc (body-key body-name heads)
 538   "Generate a part of Hydra docstring.
 539 BODY-KEY is the body key binding.
 540 BODY-NAME is the symbol that identifies the Hydra.
 541 HEADS is a list of heads."
 542   (format
 543    "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
 544    (if body-key
 545        (format "a \"%s\"" body-key)
 546      "no")
 547    (mapconcat
 548     (lambda (x)
 549       (format "\"%s\":    `%S'" (car x) (cadr x)))
 550     heads ",\n")
 551    (format "The body can be accessed via `%S'." body-name)))
 552
 553 (defun hydra--call-interactively (cmd name)
 554   "Generate a `call-interactively' statement for CMD.
 555 Set `this-command' to NAME."
 556   (if (and (symbolp name)
 557            (not (memq name '(nil body))))
 558       `(progn
 559          (setq this-command ',name)
 560          (call-interactively #',cmd))
 561     `(call-interactively #',cmd)))
 562
 563 (defun hydra--make-defun (name body doc head
 564                           keymap body-pre body-before-exit
 565                           &optional body-after-exit)
 566   "Make a defun wrapper, using NAME, BODY, DOC, HEAD, and KEYMAP.
 567 NAME and BODY are the arguments to `defhydra'.
 568 DOC was generated with `hydra--doc'.
 569 HEAD is one of the HEADS passed to `defhydra'.
 570 BODY-PRE is added to the start of the wrapper.
 571 BODY-BEFORE-EXIT will be called before the hydra quits.
 572 BODY-AFTER-EXIT is added to the end of the wrapper."
 573   (let ((name (hydra--head-name head name))
 574         (cmd (when (car head)
 575                (hydra--make-callable
 576                 (cadr head))))
 577         (doc (if (car head)
 578                  (format "%s\n\nCall the head: `%S'." doc (cadr head))
 579                doc))
 580         (hint (intern (format "%S/hint" name)))
 581         (body-foreign-keys (hydra--body-foreign-keys body))
 582         (body-timeout (plist-get body :timeout))
 583         (body-idle (plist-get body :idle)))
 584     `(defun ,name ()
 585        ,doc
 586        (interactive)
 587        (hydra-default-pre)
 588        ,@(when body-pre (list body-pre))
 589        ,@(if (hydra--head-property head :exit)
 590              `((hydra-keyboard-quit)
 591                ,@(if body-after-exit
 592                      `((unwind-protect
 593                             ,(when cmd
 594                                    (hydra--call-interactively cmd (cadr head)))
 595                          ,body-after-exit))
 596                      (when cmd
 597                        `(,(hydra--call-interactively cmd (cadr head))))))
 598              (delq
 599               nil
 600               `((let ((hydra--ignore ,(not (eq (cadr head) 'body))))
 601                   (hydra-keyboard-quit))
 602                 ,(when cmd
 603                        `(condition-case err
 604                             ,(hydra--call-interactively cmd (cadr head))
 605                           ((quit error)
 606                            (message "%S" err)
 607                            (unless hydra-lv
 608                              (sit-for 0.8)))))
 609                 ,(if (and body-idle (eq (cadr head) 'body))
 610                      `(hydra-idle-message ,body-idle ,hint)
 611                      `(when hydra-is-helpful
 612                         (if hydra-lv
 613                             (lv-message (eval ,hint))
 614                           (message (eval ,hint)))))
 615                 (hydra-set-transient-map
 616                  ,keymap
 617                  (lambda () (hydra-keyboard-quit) ,body-before-exit)
 618                  ,(when body-foreign-keys
 619                         (list 'quote body-foreign-keys)))
 620                 ,body-after-exit
 621                 ,(when body-timeout
 622                        `(hydra-timeout ,body-timeout))))))))
 623
 624 (defmacro hydra--make-funcall (sym)
 625   "Transform SYM into a `funcall' to call it."
 626   `(when (and ,sym (symbolp ,sym))
 627      (setq ,sym `(funcall #',,sym))))
 628
 629 (defun hydra--head-name (h name)
 630   "Return the symbol for head H of hydra with NAME."
 631   (let ((str (format "%S/%s" name
 632                      (if (symbolp (cadr h))
 633                          (cadr h)
 634                        (concat "lambda-" (car h))))))
 635     (when (and (hydra--head-property h :exit)
 636                (not (memq (cadr h) '(body nil))))
 637       (setq str (concat str "-and-exit")))
 638     (intern str)))
 639
 640 (defun hydra--delete-duplicates (heads)
 641   "Return HEADS without entries that have the same CMD part.
 642 In duplicate HEADS, :cmd-name is modified to whatever they duplicate."
 643   (let ((ali '(((hydra-repeat . nil) . hydra-repeat)))
 644         res entry)
 645     (dolist (h heads)
 646       (if (setq entry (assoc (cons (cadr h)
 647                                    (hydra--head-property h :exit))
 648                              ali))
 649           (setf (cl-cdddr h) (plist-put (cl-cdddr h) :cmd-name (cdr entry)))
 650         (push (cons (cons (cadr h)
 651                           (hydra--head-property h :exit))
 652                     (plist-get (cl-cdddr h) :cmd-name))
 653               ali)
 654         (push h res)))
 655     (nreverse res)))
 656
 657 (defun hydra--pad (lst n)
 658   "Pad LST with nil until length N."
 659   (let ((len (length lst)))
 660     (if (= len n)
 661         lst
 662       (append lst (make-list (- n len) nil)))))
 663
 664 (defmacro hydra-multipop (lst n)
 665   "Return LST's first N elements while removing them."
 666   `(if (<= (length ,lst) ,n)
 667        (prog1 ,lst
 668          (setq ,lst nil))
 669      (prog1 ,lst
 670        (setcdr
 671         (nthcdr (1- ,n) (prog1 ,lst (setq ,lst (nthcdr ,n ,lst))))
 672         nil))))
 673
 674 (defun hydra--matrix (lst rows cols)
 675   "Create a matrix from elements of LST.
 676 The matrix size is ROWS times COLS."
 677   (let ((ls (copy-sequence lst))
 678         res)
 679     (dotimes (_c cols)
 680       (push (hydra--pad (hydra-multipop ls rows) rows) res))
 681     (nreverse res)))
 682
 683 (defun hydra--cell (fstr names)
 684   "Format a rectangular cell based on FSTR and NAMES.
 685 FSTR is a format-style string with two string inputs: one for the
 686 doc and one for the symbol name.
 687 NAMES is a list of variables."
 688   (let ((len (cl-reduce
 689               (lambda (acc it) (max (length (symbol-name it)) acc))
 690               names
 691               :initial-value 0)))
 692     (mapconcat
 693      (lambda (sym)
 694        (if sym
 695            (format fstr
 696                    (documentation-property sym 'variable-documentation)
 697                    (let ((name (symbol-name sym)))
 698                      (concat name (make-string (- len (length name)) ?^)))
 699                    sym)
 700          ""))
 701      names
 702      "\n")))
 703
 704 (defun hydra--vconcat (strs &optional joiner)
 705   "Glue STRS vertically.  They must be the same height.
 706 JOINER is a function similar to `concat'."
 707   (setq joiner (or joiner #'concat))
 708   (mapconcat
 709    (lambda (s)
 710      (if (string-match " +$" s)
 711          (replace-match "" nil nil s)
 712        s))
 713    (apply #'cl-mapcar joiner
 714           (mapcar
 715            (lambda (s) (split-string s "\n"))
 716            strs))
 717    "\n"))
 718
 719 (defvar hydra-cell-format "% -20s %% -8`%s"
 720   "The default format for docstring cells.")
 721
 722 (defun hydra--table (names rows cols &optional cell-formats)
 723   "Format a `format'-style table from variables in NAMES.
 724 The size of the table is ROWS times COLS.
 725 CELL-FORMATS are `format' strings for each column.
 726 If CELL-FORMATS is a string, it's used for all columns.
 727 If CELL-FORMATS is nil, `hydra-cell-format' is used for all columns."
 728   (setq cell-formats
 729         (cond ((null cell-formats)
 730                (make-list cols hydra-cell-format))
 731               ((stringp cell-formats)
 732                (make-list cols cell-formats))
 733               (t
 734                cell-formats)))
 735   (hydra--vconcat
 736    (cl-mapcar
 737     #'hydra--cell
 738     cell-formats
 739     (hydra--matrix names rows cols))
 740    (lambda (&rest x)
 741      (mapconcat #'identity x "    "))))
 742
 743 (defun hydra-reset-radios (names)
 744   "Set varibles NAMES to their defaults.
 745 NAMES should be defined by `defhydradio' or similar."
 746   (dolist (n names)
 747     (set n (aref (get n 'range) 0))))
 748
 749 (defun hydra-idle-message (secs hint)
 750   "In SECS seconds display HINT."
 751   (cancel-timer hydra-message-timer)
 752   (setq hydra-message-timer (timer-create))
 753   (timer-set-time hydra-message-timer
 754                   (timer-relative-time (current-time) secs))
 755   (timer-set-function
 756    hydra-message-timer
 757    (lambda ()
 758      (when hydra-is-helpful
 759        (if hydra-lv
 760            (lv-message (eval hint))
 761          (message (eval hint))))
 762      (cancel-timer hydra-message-timer)))
 763   (timer-activate hydra-message-timer))
 764
 765 (defun hydra-timeout (secs &optional function)
 766   "In SECS seconds call FUNCTION, then function `hydra-keyboard-quit'.
 767 Cancel the previous `hydra-timeout'."
 768   (cancel-timer hydra-timeout-timer)
 769   (setq hydra-timeout-timer (timer-create))
 770   (timer-set-time hydra-timeout-timer
 771                   (timer-relative-time (current-time) secs))
 772   (timer-set-function
 773    hydra-timeout-timer
 774    `(lambda ()
 775       ,(when function
 776              `(funcall ,function))
 777       (hydra-keyboard-quit)))
 778   (timer-activate hydra-timeout-timer))
 779
 780 ;;* Macros
 781 ;;;###autoload
 782 (defmacro defhydra (name body &optional docstring &rest heads)
 783   "Create a Hydra - a family of functions with prefix NAME.
 784
 785 NAME should be a symbol, it will be the prefix of all functions
 786 defined here.
 787
 788 BODY has the format:
 789
 790     (BODY-MAP BODY-KEY &rest BODY-PLIST)
 791
 792 DOCSTRING will be displayed in the echo area to identify the
 793 Hydra.  When DOCSTRING starts with a newline, special Ruby-style
 794 substitution will be performed by `hydra--format'.
 795
 796 Functions are created on basis of HEADS, each of which has the
 797 format:
 798
 799     (KEY CMD &optional HINT &rest PLIST)
 800
 801 BODY-MAP is a keymap; `global-map' is used quite often.  Each
 802 function generated from HEADS will be bound in BODY-MAP to
 803 BODY-KEY + KEY (both are strings passed to `kbd'), and will set
 804 the transient map so that all following heads can be called
 805 though KEY only.  BODY-KEY can be an empty string.
 806
 807 CMD is a callable expression: either an interactive function
 808 name, or an interactive lambda, or a single sexp (it will be
 809 wrapped in an interactive lambda).
 810
 811 HINT is a short string that identifies its head.  It will be
 812 printed beside KEY in the echo erea if `hydra-is-helpful' is not
 813 nil.  If you don't even want the KEY to be printed, set HINT
 814 explicitly to nil.
 815
 816 The heads inherit their PLIST from BODY-PLIST and are allowed to
 817 override some keys.  The keys recognized are :exit and :bind.
 818 :exit can be:
 819
 820 - nil (default): this head will continue the Hydra state.
 821 - t: this head will stop the Hydra state.
 822
 823 :bind can be:
 824 - nil: this head will not be bound in BODY-MAP.
 825 - a lambda taking KEY and CMD used to bind a head.
 826
 827 It is possible to omit both BODY-MAP and BODY-KEY if you don't
 828 want to bind anything.  In that case, typically you will bind the
 829 generated NAME/body command.  This command is also the return
 830 result of `defhydra'."
 831   (declare (indent defun))
 832   (cond ((stringp docstring))
 833         ((and (consp docstring)
 834               (memq (car docstring) '(hydra--table concat format)))
 835          (setq docstring (concat "\n" (eval docstring))))
 836         (t
 837          (setq heads (cons docstring heads))
 838          (setq docstring "hydra")))
 839   (when (keywordp (car body))
 840     (setq body (cons nil (cons nil body))))
 841   (condition-case-unless-debug err
 842       (let* ((keymap (copy-keymap hydra-base-map))
 843              (keymap-name (intern (format "%S/keymap" name)))
 844              (body-name (intern (format "%S/body" name)))
 845              (body-key (cadr body))
 846              (body-plist (cddr body))
 847              (body-map (or (car body)
 848                            (plist-get body-plist :bind)))
 849              (body-pre (plist-get body-plist :pre))
 850              (body-body-pre (plist-get body-plist :body-pre))
 851              (body-before-exit (or (plist-get body-plist :post)
 852                                    (plist-get body-plist :before-exit)))
 853              (body-after-exit (plist-get body-plist :after-exit))
 854              (body-inherit (plist-get body-plist :inherit))
 855              (body-foreign-keys (hydra--body-foreign-keys body))
 856              (body-exit (hydra--body-exit body)))
 857         (dolist (base body-inherit)
 858           (setq heads (append heads (copy-sequence (eval base)))))
 859         (dolist (h heads)
 860           (let ((len (length h)))
 861             (cond ((< len 2)
 862                    (error "Each head should have at least two items: %S" h))
 863                   ((= len 2)
 864                    (setcdr (cdr h)
 865                            (list
 866                             (hydra-plist-get-default body-plist :hint "")))
 867                    (setcdr (nthcdr 2 h) (list :exit body-exit)))
 868                   (t
 869                    (let ((hint (cl-caddr h)))
 870                      (unless (or (null hint)
 871                                  (stringp hint))
 872                        (setcdr (cdr h) (cons
 873                                         (hydra-plist-get-default body-plist :hint "")
 874                                         (cddr h)))))
 875                    (let ((hint-and-plist (cddr h)))
 876                      (if (null (cdr hint-and-plist))
 877                          (setcdr hint-and-plist (list :exit body-exit))
 878                        (let* ((plist (cl-cdddr h))
 879                               (h-color (plist-get plist :color)))
 880                          (if h-color
 881                              (progn
 882                                (plist-put plist :exit
 883                                           (cl-case h-color
 884                                             ((blue teal) t)
 885                                             (t nil)))
 886                                (cl-remf (cl-cdddr h) :color))
 887                            (let ((h-exit (hydra-plist-get-default plist :exit 'default)))
 888                              (plist-put plist :exit
 889                                         (if (eq h-exit 'default)
 890                                             body-exit
 891                                           h-exit))))))))))
 892           (plist-put (cl-cdddr h) :cmd-name (hydra--head-name h name))
 893           (when (null (cadr h)) (plist-put (cl-cdddr h) :exit t)))
 894         (let ((doc (hydra--doc body-key body-name heads))
 895               (heads-nodup (hydra--delete-duplicates heads)))
 896           (mapc
 897            (lambda (x)
 898              (define-key keymap (kbd (car x))
 899                (plist-get (cl-cdddr x) :cmd-name)))
 900            heads)
 901           (hydra--make-funcall body-pre)
 902           (hydra--make-funcall body-body-pre)
 903           (hydra--make-funcall body-before-exit)
 904           (hydra--make-funcall body-after-exit)
 905           (when (memq body-foreign-keys '(run warn))
 906             (unless (cl-some
 907                      (lambda (h)
 908                        (hydra--head-property h :exit))
 909                      heads)
 910               (error
 911                "An %S Hydra must have at least one blue head in order to exit"
 912                body-foreign-keys)))
 913           `(progn
 914              ;; create keymap
 915              (set (defvar ,keymap-name
 916                     nil
 917                     ,(format "Keymap for %S." name))
 918                   ',keymap)
 919              ;; declare heads
 920              (set (defvar ,(intern (format "%S/heads" name))
 921                     nil
 922                     ,(format "Heads for %S." name))
 923                   ',(mapcar (lambda (h)
 924                               (let ((j (copy-sequence h)))
 925                                 (cl-remf (cl-cdddr j) :cmd-name)
 926                                 j))
 927                             heads))
 928              (set
 929               (defvar ,(intern (format "%S/hint" name)) nil
 930                 ,(format "Dynamic hint for %S." name))
 931               ',(hydra--format name body docstring heads))
 932              ;; create defuns
 933              ,@(mapcar
 934                 (lambda (head)
 935                   (hydra--make-defun name body doc head keymap-name
 936                                      body-pre
 937                                      body-before-exit
 938                                      body-after-exit))
 939                 heads-nodup)
 940              ;; free up keymap prefix
 941              ,@(unless (or (null body-key)
 942                            (null body-map)
 943                            (hydra--callablep body-map))
 944                        `((unless (keymapp (lookup-key ,body-map (kbd ,body-key)))
 945                            (define-key ,body-map (kbd ,body-key) nil))))
 946              ;; bind keys
 947              ,@(delq nil
 948                      (mapcar
 949                       (lambda (head)
 950                         (let ((name (hydra--head-property head :cmd-name)))
 951                           (when (and (cadr head)
 952                                      (or body-key body-map))
 953                             (let ((bind (hydra--head-property head :bind body-map))
 954                                   (final-key
 955                                    (if body-key
 956                                        (vconcat (kbd body-key) (kbd (car head)))
 957                                      (kbd (car head)))))
 958                               (cond ((null bind) nil)
 959                                     ((hydra--callablep bind)
 960                                      `(funcall ,bind ,final-key (function ,name)))
 961                                     ((and (symbolp bind)
 962                                           (if (boundp bind)
 963                                               (keymapp (symbol-value bind))
 964                                             t))
 965                                      `(define-key ,bind ,final-key (function ,name)))
 966                                     (t
 967                                      (error "Invalid :bind property `%S' for head %S" bind head)))))))
 968                       heads))
 969              ,(hydra--make-defun
 970                name body doc '(nil body)
 971                keymap-name
 972                (or body-body-pre body-pre) body-before-exit
 973                '(setq prefix-arg current-prefix-arg)))))
 974     (error
 975      (hydra--complain "Error in defhydra %S: %s" name (cdr err))
 976      nil)))
 977
 978 (defmacro defhydradio (name _body &rest heads)
 979   "Create radios with prefix NAME.
 980 _BODY specifies the options; there are none currently.
 981 HEADS have the format:
 982
 983     (TOGGLE-NAME &optional VALUE DOC)
 984
 985 TOGGLE-NAME will be used along with NAME to generate a variable
 986 name and a function that cycles it with the same name.  VALUE
 987 should be an array.  The first element of VALUE will be used to
 988 inialize the variable.
 989 VALUE defaults to [nil t].
 990 DOC defaults to TOGGLE-NAME split and capitalized."
 991   (declare (indent defun))
 992   `(progn
 993      ,@(apply #'append
 994               (mapcar (lambda (h)
 995                         (hydra--radio name h))
 996                       heads))
 997      (defvar ,(intern (format "%S/names" name))
 998        ',(mapcar (lambda (h) (intern (format "%S/%S" name (car h))))
 999                  heads))))
1000
1001 (defun hydra--radio (parent head)
1002   "Generate a hydradio with PARENT from HEAD."
1003   (let* ((name (car head))
1004          (full-name (intern (format "%S/%S" parent name)))
1005          (doc (cadr head))
1006          (val (or (cl-caddr head) [nil t])))
1007     `((defvar ,full-name ,(hydra--quote-maybe (aref val 0)) ,doc)
1008       (put ',full-name 'range ,val)
1009       (defun ,full-name ()
1010         (hydra--cycle-radio ',full-name)))))
1011
1012 (defun hydra--quote-maybe (x)
1013   "Quote X if it's a symbol."
1014   (cond ((null x)
1015          nil)
1016         ((symbolp x)
1017          (list 'quote x))
1018         (t
1019          x)))
1020
1021 (defun hydra--cycle-radio (sym)
1022   "Set SYM to the next value in its range."
1023   (let* ((val (symbol-value sym))
1024          (range (get sym 'range))
1025          (i 0)
1026          (l (length range)))
1027     (setq i (catch 'done
1028               (while (< i l)
1029                 (if (equal (aref range i) val)
1030                     (throw 'done (1+ i))
1031                   (cl-incf i)))
1032               (error "Val not in range for %S" sym)))
1033     (set sym
1034          (aref range
1035                (if (>= i l)
1036                    0
1037                  i)))))
1038
1039 ;; Local Variables:
1040 ;; outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|###autoload\\)\\|("
1041 ;; indent-tabs-mode: nil
1042 ;; End:
1043
1044 (provide 'hydra)
1045
1046 ;;; hydra.el ends here