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