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