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