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

   1 ;;; hydra.el --- Make bindings that stick around
   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.10.0
   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 (defalias 'hydra-set-transient-map
  83     (if (fboundp 'set-transient-map)
  84         'set-transient-map
  85       (lambda (map keep-pred &optional on-exit)
  86         (set-temporary-overlay-map map (hydra--pred on-exit)))))
  87
  88 (defun hydra--pred (on-exit)
  89   "Generate a predicate on whether to continue the Hydra state.
  90 Call ON-EXIT for clean-up.
  91 This is a compatibility code for Emacs older than 24.4."
  92   `(lambda ()
  93      (if (lookup-key hydra-curr-map (this-command-keys-vector))
  94          t
  95        (hydra-cleanup)
  96        ,(when on-exit
  97               `(funcall ,(hydra--make-callable on-exit)))
  98        nil)))
  99
 100 ;;* Customize
 101 (defgroup hydra nil
 102   "Make bindings that stick around."
 103   :group 'bindings
 104   :prefix "hydra-")
 105
 106 (defcustom hydra-is-helpful t
 107   "When t, display a hint with possible bindings in the echo area."
 108   :type 'boolean
 109   :group 'hydra)
 110
 111 (defcustom hydra-keyboard-quit "\a"
 112   "This binding will quit an amaranth Hydra.
 113 It's the only other way to quit it besides though a blue head.
 114 It's possible to set this to nil.")
 115
 116 (defcustom hydra-lv t
 117   "When non-nil, `lv-message' (not `message') will be used to display hints."
 118   :type 'boolean)
 119
 120 (defface hydra-face-red
 121     '((t (:foreground "#FF0000" :bold t)))
 122   "Red Hydra heads will persist indefinitely."
 123   :group 'hydra)
 124
 125 (defface hydra-face-blue
 126     '((t (:foreground "#0000FF" :bold t)))
 127   "Blue Hydra heads will vanquish the Hydra.")
 128
 129 (defface hydra-face-amaranth
 130     '((t (:foreground "#E52B50" :bold t)))
 131   "Amaranth body has red heads and warns on intercepting non-heads.
 132 Vanquishable only through a blue head.")
 133
 134 (defface hydra-face-pink
 135     '((t (:foreground "#FF6EB4" :bold t)))
 136   "Pink body has red heads and on intercepting non-heads calls them without quitting.
 137 Vanquishable only through a blue head.")
 138
 139 (defface hydra-face-teal
 140     '((t (:foreground "#367588" :bold t)))
 141   "Teal body has blue heads an warns on intercepting non-heads.
 142 Vanquishable only through a blue head.")
 143
 144 ;;* Fontification
 145 (defun hydra-add-font-lock ()
 146   "Fontify `defhydra' statements."
 147   (font-lock-add-keywords
 148    'emacs-lisp-mode
 149    '(("(\\(defhydra\\)\\_> +\\(.*?\\)\\_>"
 150       (1 font-lock-keyword-face)
 151       (2 font-lock-type-face))
 152      ("(\\(defhydradio\\)\\_> +\\(.*?\\)\\_>"
 153       (1 font-lock-keyword-face)
 154       (2 font-lock-type-face)))))
 155
 156 ;;* Universal Argument
 157 (defvar hydra-base-map
 158   (let ((map (make-sparse-keymap)))
 159     (define-key map [?\C-u] 'hydra--universal-argument)
 160     (define-key map [?-] 'hydra--negative-argument)
 161     (define-key map [?0] 'hydra--digit-argument)
 162     (define-key map [?1] 'hydra--digit-argument)
 163     (define-key map [?2] 'hydra--digit-argument)
 164     (define-key map [?3] 'hydra--digit-argument)
 165     (define-key map [?4] 'hydra--digit-argument)
 166     (define-key map [?5] 'hydra--digit-argument)
 167     (define-key map [?6] 'hydra--digit-argument)
 168     (define-key map [?7] 'hydra--digit-argument)
 169     (define-key map [?8] 'hydra--digit-argument)
 170     (define-key map [?9] 'hydra--digit-argument)
 171     (define-key map [kp-0] 'hydra--digit-argument)
 172     (define-key map [kp-1] 'hydra--digit-argument)
 173     (define-key map [kp-2] 'hydra--digit-argument)
 174     (define-key map [kp-3] 'hydra--digit-argument)
 175     (define-key map [kp-4] 'hydra--digit-argument)
 176     (define-key map [kp-5] 'hydra--digit-argument)
 177     (define-key map [kp-6] 'hydra--digit-argument)
 178     (define-key map [kp-7] 'hydra--digit-argument)
 179     (define-key map [kp-8] 'hydra--digit-argument)
 180     (define-key map [kp-9] 'hydra--digit-argument)
 181     (define-key map [kp-subtract] 'hydra--negative-argument)
 182     map)
 183   "Keymap that all Hydras inherit.  See `universal-argument-map'.")
 184
 185 (defvar hydra-curr-map
 186   (make-sparse-keymap)
 187   "Keymap of the current Hydra called.")
 188
 189 (defun hydra--universal-argument (arg)
 190   "Forward to (`universal-argument' ARG)."
 191   (interactive "P")
 192   (setq prefix-arg (if (consp arg)
 193                        (list (* 4 (car arg)))
 194                      (if (eq arg '-)
 195                          (list -4)
 196                        '(4))))
 197   (hydra-set-transient-map hydra-curr-map t))
 198
 199 (defun hydra--digit-argument (arg)
 200   "Forward to (`digit-argument' ARG)."
 201   (interactive "P")
 202   (let ((universal-argument-map hydra-curr-map))
 203     (digit-argument arg)))
 204
 205 (defun hydra--negative-argument (arg)
 206   "Forward to (`negative-argument' ARG)."
 207   (interactive "P")
 208   (let ((universal-argument-map hydra-curr-map))
 209     (negative-argument arg)))
 210
 211 ;;* Misc internals
 212 (defvar hydra-last nil
 213   "The result of the last `hydra-set-transient-map' call.")
 214
 215 (defun hydra--callablep (x)
 216   "Test if X is callable."
 217   (or (functionp x)
 218       (and (consp x)
 219            (memq (car x) '(function quote)))))
 220
 221 (defun hydra--make-callable (x)
 222   "Generate a callable symbol from X.
 223 If X is a function symbol or a lambda, return it.  Otherwise, it
 224 should be a single statement.  Wrap it in an interactive lambda."
 225   (if (or (symbolp x) (functionp x))
 226       x
 227     `(lambda ()
 228        (interactive)
 229        ,x)))
 230
 231 (defun hydra--head-property (h prop &optional default)
 232   "Return for Hydra head H the value of property PROP.
 233 Return DEFAULT if PROP is not in H."
 234   (let ((plist (if (or (stringp (cl-caddr h))
 235                        (null (cl-caddr h)))
 236                    (cl-cdddr h)
 237                  (cddr h))))
 238     (if (memq prop h)
 239         (plist-get plist prop)
 240       default)))
 241
 242 (defun hydra--head-color (h body)
 243   "Return the color of a Hydra head H with BODY."
 244   (let ((color (hydra--head-property h :color))
 245         (exit (or (plist-get (cddr body) :exit)
 246                   (hydra--head-property h :exit 'default)))
 247         (nonheads (plist-get (cddr body) :nonheads)))
 248     (cond ((null (cadr h))
 249            'blue)
 250           ((eq exit t)
 251            'blue)
 252           ((eq nonheads 'run)
 253            'pink)
 254           ((eq nonheads 'warn)
 255            (if (eq exit t)
 256                'teal
 257              'amaranth))
 258           ((null color)
 259            (hydra--body-color body))
 260           (t
 261            color))))
 262
 263 (defun hydra--body-color (body)
 264   "Return the color of BODY.
 265 BODY is the second argument to `defhydra'"
 266   (let ((color (plist-get (cddr body) :color))
 267         (exit (plist-get (cddr body) :exit))
 268         (nonheads (plist-get (cddr body) :nonheads)))
 269     (cond ((eq nonheads 'warn)
 270            (if exit 'teal 'amaranth))
 271           ((eq nonheads 'run) 'pink)
 272           (exit 'blue)
 273           (color color)
 274           (t 'red))))
 275
 276 (defun hydra--face (h body)
 277   "Return the face for a Hydra head H with BODY."
 278   (cl-case (hydra--head-color h body)
 279     (blue 'hydra-face-blue)
 280     (red 'hydra-face-red)
 281     (amaranth 'hydra-face-amaranth)
 282     (pink 'hydra-face-pink)
 283     (teal 'hydra-face-teal)
 284     (t (error "Unknown color for %S" h))))
 285
 286 (defun hydra-cleanup ()
 287   "Clean up after a Hydra."
 288   (when (window-live-p lv-wnd)
 289     (let ((buf (window-buffer lv-wnd)))
 290       (delete-window lv-wnd)
 291       (kill-buffer buf))))
 292
 293 (defun hydra-disable ()
 294   "Disable the current Hydra."
 295   (cond
 296     ;; Emacs 25
 297     ((functionp hydra-last)
 298      (funcall hydra-last))
 299
 300     ;; Emacs 24.3 or older
 301     ((< emacs-minor-version 4)
 302      (setq emulation-mode-map-alists
 303            (cl-remove-if
 304             (lambda (x)
 305               (and (consp x)
 306                    (consp (car x))
 307                    (equal (cdar x) hydra-curr-map)))
 308             emulation-mode-map-alists)))
 309
 310     ;; Emacs 24.4.1
 311     (t
 312      (setq overriding-terminal-local-map nil))))
 313
 314 (defun hydra--unalias-var (str prefix)
 315   "Return the symbol named STR if it's bound as a variable.
 316 Otherwise, add PREFIX to the symbol name."
 317   (let ((sym (intern-soft str)))
 318     (if (boundp sym)
 319         sym
 320       (intern (concat prefix "/" str)))))
 321
 322 (defun hydra--hint (name body docstring heads)
 323   "Generate a hint for the echo area.
 324 NAME, BODY, DOCSTRING and HEADS are parameters to `defhydra'."
 325   (let (alist)
 326     (dolist (h heads)
 327       (let ((val (assoc (cadr h) alist))
 328             (pstr (hydra-fontify-head h body)))
 329         (unless (and (> (length h) 2)
 330                      (null (cl-caddr h)))
 331           (if val
 332               (setf (cadr val)
 333                     (concat (cadr val) " " pstr))
 334             (push
 335              (cons (cadr h)
 336                    (cons pstr
 337                          (and (stringp (cl-caddr h)) (cl-caddr h))))
 338              alist)))))
 339     (mapconcat
 340      (lambda (x)
 341        (format
 342         (if (cdr x)
 343             (concat "[%s]: " (cdr x))
 344           "%s")
 345         (car x)))
 346      (nreverse (mapcar #'cdr alist))
 347      ", ")))
 348
 349 (defvar hydra-fontify-head-function nil
 350   "Possible replacement for `hydra-fontify-head-default'.")
 351
 352 (defun hydra-fontify-head-default (head body)
 353   "Produce a pretty string from HEAD and BODY.
 354 HEAD's binding is returned as a string with a colored face."
 355   (propertize (car head) 'face (hydra--face head body)))
 356
 357 (defun hydra-fontify-head-greyscale (head body)
 358   "Produce a pretty string from HEAD and BODY.
 359 HEAD's binding is returned as a string wrapped with [] or {}."
 360   (let ((color (hydra--head-color head body)))
 361     (format
 362      (if (eq color 'blue)
 363          "[%s]"
 364        "{%s}") (car head))))
 365
 366 (defun hydra-fontify-head (head body)
 367   "Produce a pretty string from HEAD and BODY."
 368   (funcall (or hydra-fontify-head-function 'hydra-fontify-head-default)
 369            head body))
 370
 371 (defun hydra--format (name body docstring heads)
 372   "Generate a `format' statement from STR.
 373 \"%`...\" expressions are extracted into \"%S\".
 374 NAME, BODY, DOCSTRING and HEADS are parameters of `defhydra'.
 375 The expressions can be auto-expanded according to NAME."
 376   (setq docstring (replace-regexp-in-string "\\^" "" docstring))
 377   (let ((rest (hydra--hint name body docstring heads))
 378         (body-color (hydra--body-color body))
 379         (prefix (symbol-name name))
 380         (start 0)
 381         varlist)
 382     (while (setq start
 383                  (string-match
 384                   "\\(?:%\\( ?-?[0-9]*\\)`\\([a-z-A-Z/0-9]+\\)\\)\\|\\(?:_\\([a-z-~A-Z]+\\)_\\)"
 385                   docstring start))
 386       (if (eq ?_ (aref (match-string 0 docstring) 0))
 387           (let* ((key (match-string 3 docstring))
 388                  (head (assoc key heads)))
 389             (if head
 390                 (progn
 391                   (push (hydra-fontify-head head body) varlist)
 392                   (setq docstring (replace-match "% 3s" nil nil docstring)))
 393               (error "Unrecognized key: _%s_" key)))
 394         (push (hydra--unalias-var (match-string 2 docstring) prefix) varlist)
 395         (setq docstring (replace-match (concat "%" (match-string 1 docstring) "S") nil nil docstring 0))))
 396     (if (eq ?\n (aref docstring 0))
 397         `(concat (format ,docstring ,@(nreverse varlist))
 398                  ,rest)
 399       `(format ,(concat docstring ": " rest ".")))))
 400
 401 (defun hydra--message (name body docstring heads)
 402   "Generate code to display the hint in the preferred echo area.
 403 Set `hydra-lv' to choose the echo area.
 404 NAME, BODY, DOCSTRING, and HEADS are parameters of `defhydra'."
 405   (let ((format-expr (hydra--format name body docstring heads)))
 406     `(if hydra-lv
 407          (lv-message ,format-expr)
 408        (message ,format-expr))))
 409
 410 (defun hydra--doc (body-key body-name heads)
 411   "Generate a part of Hydra docstring.
 412 BODY-KEY is the body key binding.
 413 BODY-NAME is the symbol that identifies the Hydra.
 414 HEADS is a list of heads."
 415   (format
 416    "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
 417    (if body-key
 418        (format "a \"%s\"" body-key)
 419      "no")
 420    (mapconcat
 421     (lambda (x)
 422       (format "\"%s\":    `%S'" (car x) (cadr x)))
 423     heads ",\n")
 424    (format "The body can be accessed via `%S'." body-name)))
 425
 426 (defun hydra--make-defun (name cmd color
 427                           doc hint keymap
 428                           body-color body-pre body-post &optional other-post)
 429   "Make a defun wrapper, using NAME, CMD, COLOR, DOC, HINT, and KEYMAP.
 430 BODY-COLOR, BODY-PRE, BODY-POST, and OTHER-POST are used as well."
 431   `(defun ,name ()
 432      ,doc
 433      (interactive)
 434      ,@(when body-pre (list body-pre))
 435      (hydra-disable)
 436      ,@(when (memq color '(blue teal)) '((hydra-cleanup)))
 437      (catch 'hydra-disable
 438        ,@(delq nil
 439                (if (memq color '(blue teal))
 440                    `(,(when cmd `(call-interactively #',cmd))
 441                       ,body-post)
 442                  `(,(when cmd
 443                           `(condition-case err
 444                                (prog1 t
 445                                  (call-interactively #',cmd))
 446                              ((quit error)
 447                               (message "%S" err)
 448                               (unless hydra-lv
 449                                 (sit-for 0.8))
 450                               nil)))
 451                     (when hydra-is-helpful
 452                       (,hint))
 453                     (setq hydra-last
 454                           (hydra-set-transient-map
 455                            (setq hydra-curr-map ',keymap)
 456                            t
 457                            ,(if (and (not (memq body-color '(amaranth pink teal))) body-post)
 458                                 `(lambda () (hydra-cleanup) ,body-post)
 459                                 `(lambda () (hydra-cleanup)))))
 460                     ,other-post))))))
 461
 462 (defun hydra-pink-fallback ()
 463   "On intercepting a non-head, try to run it."
 464   (let ((keys (this-command-keys))
 465         kb)
 466     (when (equal keys [backspace])
 467       (setq keys "\7f"))
 468     (setq kb (key-binding keys))
 469     (if kb
 470         (if (commandp kb)
 471             (condition-case err
 472                 (call-interactively kb)
 473               ((quit error)
 474                (message "%S" err)
 475                (unless hydra-lv
 476                  (sit-for 0.8))))
 477           (message "Pink Hydra can't currently handle prefixes, continuing"))
 478       (message "Pink Hydra could not resolve: %S" keys))))
 479
 480 (defun hydra--handle-nonhead (keymap name body heads)
 481   "Setup KEYMAP for intercepting non-head bindings.
 482 NAME, BODY and HEADS are parameters to `defhydra'."
 483   (let ((body-color (hydra--body-color body))
 484         (body-post (plist-get (cddr body) :post)))
 485     (when (and body-post (symbolp body-post))
 486       (setq body-post `(funcall #',body-post)))
 487     (when (memq body-color '(amaranth pink teal))
 488       (if (cl-some `(lambda (h)
 489                       (eq (hydra--head-color h body) 'blue))
 490                    heads)
 491           (progn
 492             (define-key keymap [t]
 493               `(lambda ()
 494                  (interactive)
 495                  ,(cond
 496                    ((eq body-color 'amaranth)
 497                     '(message "An amaranth Hydra can only exit through a blue head"))
 498                    ((eq body-color 'teal)
 499                     '(message "A teal Hydra can only exit through a blue head"))
 500                    (t
 501                     '(hydra-pink-fallback)))
 502                  (hydra-set-transient-map hydra-curr-map t)
 503                  (when hydra-is-helpful
 504                    (unless hydra-lv
 505                      (sit-for 0.8))
 506                    (,(intern (format "%S/hint" name)))))))
 507         (error
 508          "An %S Hydra must have at least one blue head in order to exit"
 509          body-color))
 510       (when hydra-keyboard-quit
 511         (define-key keymap hydra-keyboard-quit
 512           `(lambda ()
 513              (interactive)
 514              (hydra-disable)
 515              (hydra-cleanup)
 516              ,body-post))))))
 517
 518 ;;* Macros
 519 ;;** defhydra
 520 ;;;###autoload
 521 (defmacro defhydra (name body &optional docstring &rest heads)
 522   "Create a Hydra - a family of functions with prefix NAME.
 523
 524 NAME should be a symbol, it will be the prefix of all functions
 525 defined here.
 526
 527 BODY has the format:
 528
 529     (BODY-MAP BODY-KEY &rest PLIST)
 530
 531 DOCSTRING will be displayed in the echo area to identify the
 532 Hydra.
 533
 534 Functions are created on basis of HEADS, each of which has the
 535 format:
 536
 537     (KEY CMD &optional HINT &rest PLIST)
 538
 539 BODY-MAP is a keymap; `global-map' is used quite often.  Each
 540 function generated from HEADS will be bound in BODY-MAP to
 541 BODY-KEY + KEY (both are strings passed to `kbd'), and will set
 542 the transient map so that all following heads can be called
 543 though KEY only.
 544
 545 CMD is a callable expression: either an interactive function
 546 name, or an interactive lambda, or a single sexp (it will be
 547 wrapped in an interactive lambda).
 548
 549 HINT is a short string that identifies its head.  It will be
 550 printed beside KEY in the echo erea if `hydra-is-helpful' is not
 551 nil.  If you don't even want the KEY to be printed, set HINT
 552 explicitly to nil.
 553
 554 The heads inherit their PLIST from the body and are allowed to
 555 override each key.  The keys recognized are :color and :bind.
 556 :color can be:
 557
 558 - red (default): this head will continue the Hydra state.
 559 - blue: this head will stop the Hydra state.
 560 - amaranth (applies to body only): similar to red, but no binding
 561 except a blue head can stop the Hydra state.
 562
 563 :bind can be:
 564 - nil: this head will not be bound in BODY-MAP.
 565 - a lambda taking KEY and CMD used to bind a head
 566
 567 It is possible to omit both BODY-MAP and BODY-KEY if you don't
 568 want to bind anything.  In that case, typically you will bind the
 569 generated NAME/body command.  This command is also the return
 570 result of `defhydra'."
 571   (declare (indent defun))
 572   (unless (stringp docstring)
 573     (setq heads (cons docstring heads))
 574     (setq docstring "hydra"))
 575   (when (keywordp (car body))
 576     (setq body (cons nil (cons nil body))))
 577   (let* ((keymap (copy-keymap hydra-base-map))
 578          (names (mapcar
 579                  (lambda (x)
 580                    (define-key keymap (kbd (car x))
 581                      (intern (format "%S/%s" name
 582                                      (if (symbolp (cadr x))
 583                                          (cadr x)
 584                                        (concat "lambda-" (car x)))))))
 585                  heads))
 586          (body-name (intern (format "%S/body" name)))
 587          (hint-name (intern (format "%S/hint" name)))
 588          (body-key (unless (hydra--callablep body)
 589                      (cadr body)))
 590          (body-color (hydra--body-color body))
 591          (body-pre (plist-get (cddr body) :pre))
 592          (body-post (plist-get (cddr body) :post))
 593          (method (or (plist-get body :bind)
 594                      (car body)))
 595          (doc (hydra--doc body-key body-name heads)))
 596     (when (and body-pre (symbolp body-pre))
 597       (setq body-pre `(funcall #',body-pre)))
 598     (when (and body-post (symbolp body-post))
 599       (setq body-post `(funcall #',body-post)))
 600     (hydra--handle-nonhead keymap name body heads)
 601     `(progn
 602        ,@(cl-mapcar
 603           (lambda (head name)
 604             (hydra--make-defun
 605              name (hydra--make-callable
 606                    (cadr head)) (hydra--head-color head body)
 607              (format "%s\n\nCall the head: `%S'." doc (cadr head))
 608              hint-name keymap
 609              body-color body-pre body-post))
 610           heads names)
 611        ,@(unless (or (null body-key)
 612                      (null method)
 613                      (hydra--callablep method))
 614                  `((unless (keymapp (lookup-key ,method (kbd ,body-key)))
 615                      (define-key ,method (kbd ,body-key) nil))))
 616        ,@(delq nil
 617                (cl-mapcar
 618                 (lambda (head name)
 619                   (when (or body-key method)
 620                     (let ((bind (hydra--head-property head :bind 'default))
 621                           (final-key
 622                            (if body-key
 623                                (vconcat (kbd body-key) (kbd (car head)))
 624                              (kbd (car head)))))
 625                       (cond ((null bind) nil)
 626
 627                             ((eq bind 'default)
 628                              (list
 629                               (if (hydra--callablep method)
 630                                   'funcall
 631                                 'define-key)
 632                               method
 633                               final-key
 634                               (list 'function name)))
 635
 636                             ((hydra--callablep bind)
 637                              `(funcall (function ,bind)
 638                                        ,final-key
 639                                        (function ,name)))
 640
 641                             (t
 642                              (error "Invalid :bind property %S" head))))))
 643                 heads names))
 644        (defun ,hint-name ()
 645          ,(hydra--message name body docstring heads))
 646        ,(hydra--make-defun body-name nil nil doc hint-name keymap
 647                            body-color body-pre body-post
 648                            '(setq prefix-arg current-prefix-arg)))))
 649
 650 (defmacro defhydradio (name body &rest heads)
 651   "Create radios with prefix NAME.
 652 BODY specifies the options; there are none currently.
 653 HEADS have the format:
 654
 655     (TOGGLE-NAME &optional VALUE DOC)
 656
 657 TOGGLE-NAME will be used along with NAME to generate a variable
 658 name and a function that cycles it with the same name.  VALUE
 659 should be an array.  The first element of VALUE will be used to
 660 inialize the variable.
 661 VALUE defaults to [nil t].
 662 DOC defaults to TOGGLE-NAME split and capitalized."
 663   (declare (indent defun))
 664   `(progn
 665      ,@(apply #'append
 666               (mapcar (lambda (h)
 667                         (hydra--radio name h))
 668                       heads))
 669      (defun ,(intern (format "%S/reset-radios" name)) ()
 670        ,@(mapcar
 671           (lambda (h)
 672             (let ((full-name (intern (format "%S/%S" name (car h))))
 673                   )
 674               `(setq ,full-name ,(hydra--quote-maybe
 675                                   (and (cadr h) (aref (cadr h) 0))))))
 676           heads))))
 677
 678 (defun hydra--radio (parent head)
 679   "Generate a hydradio with PARENT from HEAD."
 680   (let* ((name (car head))
 681          (full-name (intern (format "%S/%S" parent name)))
 682          (val (or (cadr head) [nil t]))
 683          (doc (or (cl-caddr head)
 684                   (mapconcat #'capitalize
 685                              (split-string (symbol-name name) "-")
 686                              " "))))
 687     `((defvar ,full-name ,(hydra--quote-maybe (aref val 0)) ,doc)
 688       (put ',full-name 'range ,val)
 689       (defun ,full-name ()
 690         (hydra--cycle-radio ',full-name)))))
 691
 692 (defun hydra--quote-maybe (x)
 693   "Quote X if it's a symbol."
 694   (cond ((null x)
 695          nil)
 696         ((symbolp x)
 697          (list 'quote x))
 698         (t
 699          x)))
 700
 701 (defun hydra--cycle-radio (sym)
 702   "Set SYM to the next value in its range."
 703   (let* ((val (symbol-value sym))
 704          (range (get sym 'range))
 705          (i 0)
 706          (l (length range)))
 707     (setq i (catch 'done
 708               (while (< i l)
 709                 (if (equal (aref range i) val)
 710                     (throw 'done (1+ i))
 711                   (incf i)))
 712               (error "Val not in range for %S" sym)))
 713     (set sym
 714          (aref range
 715                (if (>= i l)
 716                    0
 717                  i)))))
 718
 719 (provide 'hydra)
 720
 721 ;;; Local Variables:
 722 ;;; outline-regexp: ";;\\*+"
 723 ;;; End:
 724
 725 ;;; hydra.el ends here