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