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

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