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