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

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