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