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.6.1
   9 ;; Keywords: bindings
  10 ;; Package-Requires: ((cl-lib "0.5"))
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software: you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation, either version 3 of the License, or
  17 ;; (at your option) any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 ;;; Commentary:
  28 ;;
  29 ;; This package can be used to tie related commands into a family of
  30 ;; short bindings with a common prefix - a Hydra.
  31 ;;
  32 ;; Once you summon the Hydra (through the prefixed binding), all the
  33 ;; heads can be called in succession with only a short extension.
  34 ;; The Hydra is vanquished once Hercules, any binding that isn't the
  35 ;; Hydra's head, arrives.  Note that Hercules, besides vanquishing the
  36 ;; Hydra, will still serve his orignal purpose, calling his proper
  37 ;; command.  This makes the Hydra very seamless, it's like a minor
  38 ;; mode that disables itself automagically.
  39 ;;
  40 ;; Here's how to use the examples bundled with Hydra:
  41 ;;
  42 ;;    (require 'hydra-examples)
  43 ;;    (hydra-create "C-M-y" hydra-example-move-window-splitter)
  44 ;;    (hydra-create "M-g" hydra-example-goto-error)
  45 ;;
  46 ;; You can expand the examples in-place, it still looks elegant:
  47 ;;
  48 ;;     (hydra-create "<f2>"
  49 ;;       '(("g" text-scale-increase "zoom in")
  50 ;;         ("l" text-scale-decrease "zoom out")))
  51 ;;
  52 ;; The third element of each list is the optional doc string that will
  53 ;; be displayed in the echo area when `hydra-is-helpful' is t.
  54 ;;
  55 ;; It's better to take the examples simply as templates and use
  56 ;; `defhydra' instead of `hydra-create', since it's more flexible.
  57 ;;
  58 ;;     (defhydra hydra-zoom (global-map "<f2>")
  59 ;;       "zoom"
  60 ;;       ("g" text-scale-increase "in")
  61 ;;       ("l" text-scale-decrease "out"))
  62
  63 ;;; Code:
  64 ;;* Requires
  65 (require 'cl-lib)
  66
  67 (defalias 'hydra-set-transient-map
  68   (if (fboundp 'set-transient-map)
  69       'set-transient-map
  70     'set-temporary-overlay-map))
  71
  72 ;;* Customize
  73 (defgroup hydra nil
  74   "Make bindings that stick around."
  75   :group 'bindings
  76   :prefix "hydra-")
  77
  78 (defcustom hydra-is-helpful t
  79   "When t, display a hint with possible bindings in the echo area."
  80   :type 'boolean
  81   :group 'hydra)
  82
  83 (defface hydra-face-red
  84     '((t (:foreground "#7F0055" :bold t)))
  85   "Red Hydra heads will persist indefinitely."
  86   :group 'hydra)
  87
  88 (defface hydra-face-blue
  89     '((t (:foreground "#758BC6" :bold t)))
  90   "Blue Hydra heads will vanquish the Hydra.")
  91
  92 ;;* Universal Argument
  93 (defvar hydra-base-map
  94   (let ((map (make-sparse-keymap)))
  95     (define-key map [?\C-u] 'hydra--universal-argument)
  96     (define-key map [?-] 'hydra--negative-argument)
  97     (define-key map [?0] 'hydra--digit-argument)
  98     (define-key map [?1] 'hydra--digit-argument)
  99     (define-key map [?2] 'hydra--digit-argument)
 100     (define-key map [?3] 'hydra--digit-argument)
 101     (define-key map [?4] 'hydra--digit-argument)
 102     (define-key map [?5] 'hydra--digit-argument)
 103     (define-key map [?6] 'hydra--digit-argument)
 104     (define-key map [?7] 'hydra--digit-argument)
 105     (define-key map [?8] 'hydra--digit-argument)
 106     (define-key map [?9] 'hydra--digit-argument)
 107     (define-key map [kp-0] 'hydra--digit-argument)
 108     (define-key map [kp-1] 'hydra--digit-argument)
 109     (define-key map [kp-2] 'hydra--digit-argument)
 110     (define-key map [kp-3] 'hydra--digit-argument)
 111     (define-key map [kp-4] 'hydra--digit-argument)
 112     (define-key map [kp-5] 'hydra--digit-argument)
 113     (define-key map [kp-6] 'hydra--digit-argument)
 114     (define-key map [kp-7] 'hydra--digit-argument)
 115     (define-key map [kp-8] 'hydra--digit-argument)
 116     (define-key map [kp-9] 'hydra--digit-argument)
 117     (define-key map [kp-subtract] 'hydra--negative-argument)
 118     map)
 119   "Keymap that all Hydras inherit. See `universal-argument-map'.")
 120
 121 (defvar hydra-curr-map
 122   (make-sparse-keymap)
 123   "Keymap of the current Hydra called.")
 124
 125 (defun hydra--universal-argument (arg)
 126   "Forward to (`universal-argument' ARG)."
 127   (interactive "P")
 128   (setq prefix-arg (if (consp arg)
 129                        (list (* 4 (car arg)))
 130                      (if (eq arg '-)
 131                          (list -4)
 132                        '(4))))
 133   (hydra-set-transient-map hydra-curr-map))
 134
 135 (defun hydra--digit-argument (arg)
 136   "Forward to (`digit-argument' ARG)."
 137   (interactive "P")
 138   (let ((universal-argument-map hydra-curr-map))
 139     (digit-argument arg)))
 140
 141 (defun hydra--negative-argument (arg)
 142   "Forward to (`negative-argument' ARG)."
 143   (interactive "P")
 144   (let ((universal-argument-map hydra-curr-map))
 145     (negative-argument arg)))
 146
 147 ;;* Misc internals
 148 (defvar hydra-last nil
 149   "The result of the last `hydra-set-transient-map' call.")
 150
 151 (defun hydra--callablep (x)
 152   "Test if X is callable."
 153   (or (functionp x)
 154       (and (consp x)
 155            (memq (car x) '(function quote)))))
 156
 157 (defun hydra--color (h body-color)
 158   "Return the color of a Hydra head H with BODY-COLOR."
 159   (if (null (cadr h))
 160       'blue
 161     (let ((plist (if (stringp (cl-caddr h))
 162                      (cl-cdddr h)
 163                    (cddr h))))
 164       (or (plist-get plist :color) body-color))))
 165
 166 (defun hydra--face (h body-color)
 167   "Return the face for a Hydra head H with BODY-COLOR."
 168   (cl-case (hydra--color h body-color)
 169     (blue 'hydra-face-blue)
 170     (red 'hydra-face-red)
 171     (t (error "Unknown color for %S" h))))
 172
 173 (defun hydra--hint (docstring heads body-color)
 174   "Generate a hint from DOCSTRING and HEADS and BODY-COLOR.
 175 It's intended for the echo area, when a Hydra is active."
 176   (format "%s: %s."
 177           docstring
 178           (mapconcat
 179            (lambda (h)
 180              (format
 181               (if (stringp (cl-caddr h))
 182                   (concat "[%s]: " (cl-caddr h))
 183                 "%s")
 184               (propertize
 185                (car h) 'face
 186                (hydra--face h body-color))))
 187            heads ", ")))
 188
 189 (defun hydra-disable ()
 190   "Disable the current Hydra."
 191   (cond
 192     ;; Emacs 25
 193     ((functionp hydra-last)
 194      (funcall hydra-last))
 195
 196     ;; Emacs 24.4.1
 197     ((boundp 'overriding-terminal-local-map)
 198      (setq overriding-terminal-local-map nil))
 199
 200     ;; older
 201     (t
 202      (while (and (consp (car emulation-mode-map-alists))
 203                  (consp (caar emulation-mode-map-alists))
 204                  (equal (cl-cdaar emulation-mode-map-alists) ',keymap))
 205        (setq emulation-mode-map-alists
 206              (cdr emulation-mode-map-alists))))))
 207
 208 (defun hydra--doc (body-key body-name heads)
 209   "Generate a part of Hydra docstring.
 210 BODY-KEY is the body key binding.
 211 BODY-NAME is the symbol that identifies the Hydra.
 212 HEADS is a list of heads."
 213   (format
 214    "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
 215    (if body-key
 216        (format "a \"%s\"" body-key)
 217      "no")
 218    (mapconcat
 219     (lambda (x)
 220       (format "\"%s\":    `%S'" (car x) (cadr x)))
 221     heads ",\n")
 222    (format "The body can be accessed via `%S'." body-name)))
 223
 224 ;;* Macros
 225 ;;** hydra-create
 226 ;;;###autoload
 227 (defmacro hydra-create (body heads &optional method)
 228   "Create a hydra with a BODY prefix and HEADS with METHOD.
 229 This will result in `global-set-key' statements with the keys
 230 being the concatenation of BODY and each head in HEADS.  HEADS is
 231 an list of (KEY FUNCTION &optional HINT).
 232
 233 After one of the HEADS is called via BODY+KEY, it and the other
 234 HEADS can be called with only KEY (no need for BODY).  This state
 235 is broken once any key binding that is not in HEADS is called.
 236
 237 METHOD is a lambda takes two arguments: a KEY and a COMMAND.
 238 It defaults to `global-set-key'.
 239 When `(keymapp METHOD)`, it becomes:
 240
 241     (lambda (key command) (define-key METHOD key command))"
 242   (declare (indent 1))
 243   `(defhydra ,(intern
 244                (concat
 245                 "hydra-" (replace-regexp-in-string " " "_" body)))
 246        ,(cond ((hydra--callablep method)
 247               method)
 248              ((null method)
 249               `(global-map ,body))
 250              (t
 251               (list method body)))
 252      "hydra"
 253      ,@(eval heads)))
 254
 255 ;;** defhydra
 256 ;;;###autoload
 257 (defmacro defhydra (name body &optional docstring &rest heads)
 258   "Create a hydra named NAME with a prefix BODY.
 259
 260 NAME should be a symbol, it will be the prefix of all functions
 261 defined here.
 262
 263 BODY should be either:
 264
 265     (BODY-MAP &optional BODY-KEY &rest PLIST)
 266 or:
 267
 268     (lambda (KEY CMD) ...)
 269
 270 BODY-MAP should be a keymap; `global-map' is acceptable here.
 271 BODY-KEY should be a string processable by `kbd'.
 272
 273 DOCSTRING will be displayed in the echo area to identify the
 274 hydra.
 275
 276 HEADS is a list of (KEY CMD &optional HINT &rest PLIST).
 277
 278 PLIST in both cases recognizes only the :color key so far, which
 279 in turn can be either red or blue."
 280   (unless (stringp docstring)
 281     (setq heads (cons docstring heads))
 282     (setq docstring "hydra"))
 283   (when (keywordp (car body))
 284     (setq body (cons nil (cons nil body))))
 285   (let* ((keymap (copy-keymap hydra-base-map))
 286          (names (mapcar
 287                  (lambda (x)
 288                    (define-key keymap (kbd (car x))
 289                      (intern (format "%S/%s" name
 290                                      (if (symbolp (cadr x))
 291                                          (cadr x)
 292                                        (concat "lambda-" (car x)))))))
 293                  heads))
 294          (body-name (intern (format "%S/body" name)))
 295          (body-key (unless (hydra--callablep body)
 296                      (cadr body)))
 297          (body-color (if (hydra--callablep body)
 298                          'red
 299                        (or (plist-get (cddr body) :color)
 300                            'red)))
 301          (method (if (hydra--callablep body)
 302                      body
 303                    (car body)))
 304          (hint (hydra--hint docstring heads body-color))
 305          (doc (hydra--doc body-key body-name heads)))
 306     `(progn
 307        ,@(cl-mapcar
 308           (lambda (head name)
 309             `(defun ,name ()
 310                ,(format "%s\n\nCall the head: `%S'." doc (cadr head))
 311                (interactive)
 312                ,@(if (eq (hydra--color head body-color) 'blue)
 313                      `((hydra-disable)
 314                        ,@(unless (null (cadr head))
 315                                  `((call-interactively #',(cadr head)))))
 316                      `((when hydra-is-helpful
 317                          (message ,hint))
 318                        (setq hydra-last
 319                              (hydra-set-transient-map (setq hydra-curr-map ',keymap) t))
 320                        (call-interactively #',(cadr head))))))
 321           heads names)
 322        ,@(unless (or (null body-key)
 323                      (null method)
 324                      (hydra--callablep method))
 325                  `((unless (keymapp (lookup-key ,method (kbd ,body-key)))
 326                      (define-key ,method (kbd ,body-key) nil))))
 327        ,@(delq nil
 328                (cl-mapcar
 329                 (lambda (head name)
 330                   (unless (or (null body-key) (null method))
 331                     (list
 332                      (if (hydra--callablep method)
 333                          'funcall
 334                        'define-key)
 335                      method
 336                      (vconcat (kbd body-key) (kbd (car head)))
 337                      (list 'function name))))
 338                 heads names))
 339        (defun ,body-name ()
 340          ,doc
 341          (interactive)
 342          (when hydra-is-helpful
 343            (message ,hint))
 344          (setq hydra-last
 345                (hydra-set-transient-map ',keymap t))))))
 346
 347 (provide 'hydra)
 348
 349 ;;; Local Variables:
 350 ;;; outline-regexp: ";;\\*+"
 351 ;;; End:
 352
 353 ;;; hydra.el ends here