code.delx.au - gnu-emacs-elpa/blob - packages/hydra/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.9.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
  81 (defalias 'hydra-set-transient-map
  82   (if (fboundp 'set-transient-map)
  83       'set-transient-map
  84     'set-temporary-overlay-map))
  85
  86 ;;* Customize
  87 (defgroup hydra nil
  88   "Make bindings that stick around."
  89   :group 'bindings
  90   :prefix "hydra-")
  91
  92 (defcustom hydra-is-helpful t
  93   "When t, display a hint with possible bindings in the echo area."
  94   :type 'boolean
  95   :group 'hydra)
  96
  97 (defcustom hydra-keyboard-quit "\a"
  98   "This binding will quit an amaranth Hydra.
  99 It's the only other way to quit it besides though a blue head.
 100 It's possible to set this to nil.")
 101
 102 (defface hydra-face-red
 103     '((t (:foreground "#7F0055" :bold t)))
 104   "Red Hydra heads will persist indefinitely."
 105   :group 'hydra)
 106
 107 (defface hydra-face-blue
 108     '((t (:foreground "#758BC6" :bold t)))
 109   "Blue Hydra heads will vanquish the Hydra.")
 110
 111 (defface hydra-face-amaranth
 112     '((t (:foreground "#E52B50" :bold t)))
 113   "Amaranth Hydra can exit only through a blue head.")
 114
 115 ;;* Universal Argument
 116 (defvar hydra-base-map
 117   (let ((map (make-sparse-keymap)))
 118     (define-key map [?\C-u] 'hydra--universal-argument)
 119     (define-key map [?-] 'hydra--negative-argument)
 120     (define-key map [?0] 'hydra--digit-argument)
 121     (define-key map [?1] 'hydra--digit-argument)
 122     (define-key map [?2] 'hydra--digit-argument)
 123     (define-key map [?3] 'hydra--digit-argument)
 124     (define-key map [?4] 'hydra--digit-argument)
 125     (define-key map [?5] 'hydra--digit-argument)
 126     (define-key map [?6] 'hydra--digit-argument)
 127     (define-key map [?7] 'hydra--digit-argument)
 128     (define-key map [?8] 'hydra--digit-argument)
 129     (define-key map [?9] 'hydra--digit-argument)
 130     (define-key map [kp-0] 'hydra--digit-argument)
 131     (define-key map [kp-1] 'hydra--digit-argument)
 132     (define-key map [kp-2] 'hydra--digit-argument)
 133     (define-key map [kp-3] 'hydra--digit-argument)
 134     (define-key map [kp-4] 'hydra--digit-argument)
 135     (define-key map [kp-5] 'hydra--digit-argument)
 136     (define-key map [kp-6] 'hydra--digit-argument)
 137     (define-key map [kp-7] 'hydra--digit-argument)
 138     (define-key map [kp-8] 'hydra--digit-argument)
 139     (define-key map [kp-9] 'hydra--digit-argument)
 140     (define-key map [kp-subtract] 'hydra--negative-argument)
 141     map)
 142   "Keymap that all Hydras inherit.  See `universal-argument-map'.")
 143
 144 (defvar hydra-curr-map
 145   (make-sparse-keymap)
 146   "Keymap of the current Hydra called.")
 147
 148 (defun hydra--universal-argument (arg)
 149   "Forward to (`universal-argument' ARG)."
 150   (interactive "P")
 151   (setq prefix-arg (if (consp arg)
 152                        (list (* 4 (car arg)))
 153                      (if (eq arg '-)
 154                          (list -4)
 155                        '(4))))
 156   (hydra-set-transient-map hydra-curr-map t))
 157
 158 (defun hydra--digit-argument (arg)
 159   "Forward to (`digit-argument' ARG)."
 160   (interactive "P")
 161   (let ((universal-argument-map hydra-curr-map))
 162     (digit-argument arg)))
 163
 164 (defun hydra--negative-argument (arg)
 165   "Forward to (`negative-argument' ARG)."
 166   (interactive "P")
 167   (let ((universal-argument-map hydra-curr-map))
 168     (negative-argument arg)))
 169
 170 ;;* Misc internals
 171 (defvar hydra-last nil
 172   "The result of the last `hydra-set-transient-map' call.")
 173
 174 (defun hydra--callablep (x)
 175   "Test if X is callable."
 176   (or (functionp x)
 177       (and (consp x)
 178            (memq (car x) '(function quote)))))
 179
 180 (defun hydra--make-callable (x)
 181   "Generate a callable symbol from X.
 182 If X is a function symbol or a lambda, return it.  Otherwise, it
 183 should be a single statement. Wrap it in an interactive lambda."
 184   (if (or (symbolp x) (functionp x))
 185       x
 186     `(lambda ()
 187        (interactive)
 188        ,x)))
 189
 190 (defun hydra--head-property (h prop &optional default)
 191   "Return for Hydra head H the value of property PROP.
 192 Return DEFAULT if PROP is not in H."
 193   (let ((plist (if (stringp (cl-caddr h))
 194                    (cl-cdddr h)
 195                  (cddr h))))
 196     (if (memq prop h)
 197         (plist-get plist prop)
 198       default)))
 199
 200 (defun hydra--color (h body-color)
 201   "Return the color of a Hydra head H with BODY-COLOR."
 202   (if (null (cadr h))
 203       'blue
 204     (or (hydra--head-property h :color) body-color)))
 205
 206 (defun hydra--face (h body-color)
 207   "Return the face for a Hydra head H with BODY-COLOR."
 208   (cl-case (hydra--color h body-color)
 209     (blue 'hydra-face-blue)
 210     (red 'hydra-face-red)
 211     (amaranth 'hydra-face-amaranth)
 212     (t (error "Unknown color for %S" h))))
 213
 214 (defun hydra--hint (docstring heads body-color)
 215   "Generate a hint from DOCSTRING and HEADS and BODY-COLOR.
 216 It's intended for the echo area, when a Hydra is active."
 217   (format "%s: %s."
 218           docstring
 219           (mapconcat
 220            (lambda (h)
 221              (format
 222               (if (stringp (cl-caddr h))
 223                   (concat "[%s]: " (cl-caddr h))
 224                 "%s")
 225               (propertize
 226                (car h) 'face
 227                (hydra--face h body-color))))
 228            heads ", ")))
 229
 230 (defun hydra-disable ()
 231   "Disable the current Hydra."
 232   (cond
 233     ;; Emacs 25
 234     ((functionp hydra-last)
 235      (funcall hydra-last))
 236
 237     ;; Emacs 24.4.1
 238     ((boundp 'overriding-terminal-local-map)
 239      (setq overriding-terminal-local-map nil))
 240
 241     ;; older
 242     (t
 243      (while (and (consp (car emulation-mode-map-alists))
 244                  (consp (caar emulation-mode-map-alists))
 245                  (equal (cl-cdaar emulation-mode-map-alists) ',keymap))
 246        (setq emulation-mode-map-alists
 247              (cdr emulation-mode-map-alists))))))
 248
 249 (defun hydra--doc (body-key body-name heads)
 250   "Generate a part of Hydra docstring.
 251 BODY-KEY is the body key binding.
 252 BODY-NAME is the symbol that identifies the Hydra.
 253 HEADS is a list of heads."
 254   (format
 255    "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
 256    (if body-key
 257        (format "a \"%s\"" body-key)
 258      "no")
 259    (mapconcat
 260     (lambda (x)
 261       (format "\"%s\":    `%S'" (car x) (cadr x)))
 262     heads ",\n")
 263    (format "The body can be accessed via `%S'." body-name)))
 264
 265 (defun hydra--make-defun (name cmd color
 266                           doc hint keymap
 267                           body-color body-pre body-post &optional other-post)
 268   "Make a defun wrapper, using NAME, CMD, COLOR, DOC, HINT, and KEYMAP.
 269 BODY-COLOR, BODY-PRE, BODY-POST, and OTHER-POST are used as well."
 270   `(defun ,name ()
 271      ,doc
 272      (interactive)
 273      ,@(when body-pre (list body-pre))
 274      (hydra-disable)
 275      (catch 'hydra-disable
 276        ,@(delq nil
 277                (if (eq color 'blue)
 278                    `(,(when cmd `(call-interactively #',cmd))
 279                       ,body-post)
 280                  `(,(when cmd
 281                           `(condition-case err
 282                                (prog1 t
 283                                  (call-interactively #',cmd))
 284                              ((debug error)
 285                               (message "%S" err)
 286                               (sit-for 0.8)
 287                               nil)))
 288                     (when hydra-is-helpful
 289                       (message ,hint))
 290                     (setq hydra-last
 291                           (hydra-set-transient-map
 292                            (setq hydra-curr-map ',keymap)
 293                            t
 294                            ,@(if (and (not (eq body-color 'amaranth)) body-post)
 295                                  `((lambda () ,body-post)))))
 296                     ,other-post))))))
 297
 298 ;;* Macros
 299 ;;** hydra-create
 300 ;;;###autoload
 301 (defmacro hydra-create (body heads &optional method)
 302   "Create a hydra with a BODY prefix and HEADS with METHOD.
 303 This will result in `global-set-key' statements with the keys
 304 being the concatenation of BODY and each head in HEADS.  HEADS is
 305 an list of (KEY FUNCTION &optional HINT).
 306
 307 After one of the HEADS is called via BODY+KEY, it and the other
 308 HEADS can be called with only KEY (no need for BODY).  This state
 309 is broken once any key binding that is not in HEADS is called.
 310
 311 METHOD is a lambda takes two arguments: a KEY and a COMMAND.
 312 It defaults to `global-set-key'.
 313 When `(keymapp METHOD)`, it becomes:
 314
 315     (lambda (key command) (define-key METHOD key command))"
 316   (declare (indent 1)
 317            (obsolete defhydra "0.8.0"))
 318   `(defhydra ,(intern
 319                (concat
 320                 "hydra-" (replace-regexp-in-string " " "_" body)))
 321        ,(cond ((hydra--callablep method)
 322               method)
 323              ((null method)
 324               `(global-map ,body))
 325              (t
 326               (list method body)))
 327      "hydra"
 328      ,@(eval heads)))
 329
 330 ;;** defhydra
 331 ;;;###autoload
 332 (defmacro defhydra (name body &optional docstring &rest heads)
 333   "Create a Hydra - a family of functions with prefix NAME.
 334
 335 NAME should be a symbol, it will be the prefix of all functions
 336 defined here.
 337
 338 BODY has the format:
 339
 340     (BODY-MAP BODY-KEY &rest PLIST)
 341
 342 DOCSTRING will be displayed in the echo area to identify the
 343 Hydra.
 344
 345 Functions are created on basis of HEADS, each of which has the
 346 format:
 347
 348     (KEY CMD &optional HINT &rest PLIST)
 349
 350 BODY-MAP is a keymap; `global-map' is used quite often.  Each
 351 function generated from HEADS will be bound in BODY-MAP to
 352 BODY-KEY + KEY, and will set the transient map so that all
 353 following heads can be called though KEY only.
 354
 355 The heads inherit their PLIST from the body and are allowed to
 356 override each key.  The keys recognized are :color and :bind.
 357 :color can be:
 358
 359 - red (default): this head will continue the Hydra state.
 360 - blue: this head will stop the Hydra state.
 361 - amaranth (applies to body only): similar to red, but no binding
 362 except a blue head can stop the Hydra state.
 363
 364 :bind can be:
 365 - nil: this head will not be bound in BODY-MAP.
 366 - a lambda taking KEY and CMD used to bind a head"
 367   (declare (indent 2))
 368   (unless (stringp docstring)
 369     (setq heads (cons docstring heads))
 370     (setq docstring "hydra"))
 371   (when (keywordp (car body))
 372     (setq body (cons nil (cons nil body))))
 373   (let* ((keymap (copy-keymap hydra-base-map))
 374          (names (mapcar
 375                  (lambda (x)
 376                    (define-key keymap (kbd (car x))
 377                      (intern (format "%S/%s" name
 378                                      (if (symbolp (cadr x))
 379                                          (cadr x)
 380                                        (concat "lambda-" (car x)))))))
 381                  heads))
 382          (body-name (intern (format "%S/body" name)))
 383          (body-key (unless (hydra--callablep body)
 384                      (cadr body)))
 385          (body-color (if (hydra--callablep body)
 386                          'red
 387                        (or (plist-get (cddr body) :color)
 388                            'red)))
 389          (body-pre (plist-get (cddr body) :pre))
 390          (body-post (plist-get (cddr body) :post))
 391          (method (or (plist-get body :bind)
 392                      (car body)))
 393          (hint (hydra--hint docstring heads body-color))
 394          (doc (hydra--doc body-key body-name heads)))
 395     (when (and (or body-pre body-post)
 396                (version< emacs-version "24.4"))
 397       (error "At least Emacs 24.4 is needed for :pre and :post"))
 398     (when (and body-pre (symbolp body-pre))
 399       (setq body-pre `(funcall #',body-pre)))
 400     (when (and body-post (symbolp body-post))
 401       (setq body-post `(funcall #',body-post)))
 402     (when (eq body-color 'amaranth)
 403       (if (cl-some `(lambda (h)
 404                       (eq (hydra--color h ',body-color) 'blue))
 405                    heads)
 406           (define-key keymap [t]
 407             `(lambda ()
 408                (interactive)
 409                (message "An amaranth Hydra can only exit through a blue head")
 410                (hydra-set-transient-map hydra-curr-map t)
 411                (when hydra-is-helpful
 412                  (sit-for 0.8)
 413                  (message ,hint))))
 414         (error "An amaranth Hydra must have at least one blue head in order to exit"))
 415       (when hydra-keyboard-quit
 416         (define-key keymap hydra-keyboard-quit
 417           `(lambda ()
 418              (interactive)
 419              (hydra-disable)
 420              ,body-post))))
 421     `(progn
 422        ,@(cl-mapcar
 423           (lambda (head name)
 424             (hydra--make-defun
 425              name (hydra--make-callable (cadr head)) (hydra--color head body-color)
 426              (format "%s\n\nCall the head: `%S'." doc (cadr head))
 427              hint keymap
 428              body-color body-pre body-post))
 429           heads names)
 430        ,@(unless (or (null body-key)
 431                      (null method)
 432                      (hydra--callablep method))
 433                  `((unless (keymapp (lookup-key ,method (kbd ,body-key)))
 434                      (define-key ,method (kbd ,body-key) nil))))
 435        ,@(delq nil
 436                (cl-mapcar
 437                 (lambda (head name)
 438                   (when (or body-key method)
 439                     (let ((bind (hydra--head-property head :bind 'default))
 440                           (final-key (if body-key
 441                                          (vconcat (kbd body-key) (kbd (car head)))
 442                                        (kbd (car head)))))
 443                       (cond ((null bind) nil)
 444
 445                             ((eq bind 'default)
 446                              (list
 447                               (if (hydra--callablep method)
 448                                   'funcall
 449                                 'define-key)
 450                               method
 451                               final-key
 452                               (list 'function name)))
 453
 454                             ((hydra--callablep bind)
 455                              `(funcall (function ,bind)
 456                                        ,final-key
 457                                        (function ,name)))
 458
 459                             (t
 460                              (error "Invalid :bind property %S" head))))))
 461                 heads names))
 462        ,(hydra--make-defun body-name nil nil doc hint keymap
 463                            body-color body-pre body-post
 464                            '(setq prefix-arg current-prefix-arg)))))
 465
 466 (provide 'hydra)
 467
 468 ;;; Local Variables:
 469 ;;; outline-regexp: ";;\\*+"
 470 ;;; End:
 471
 472 ;;; hydra.el ends here