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

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