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