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