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.5.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 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 (require 'cl-lib)
  65
  66 (defgroup hydra nil
  67   "Make bindings that stick around."
  68   :group 'bindings
  69   :prefix "hydra-")
  70
  71 (defcustom hydra-is-helpful t
  72   "When t, display a hint with possible bindings in the echo area."
  73   :type 'boolean
  74   :group 'hydra)
  75
  76 (defface hydra-face-red
  77     '((t (:foreground "#7F0055" :bold t)))
  78   "Red Hydra heads will persist indefinitely."
  79   :group 'hydra)
  80
  81 (defface hydra-face-blue
  82     '((t (:foreground "#758BC6" :bold t)))
  83   "Blue Hydra heads will vanquish the Hydra.")
  84
  85 (defalias 'hydra-set-transient-map
  86   (if (fboundp 'set-transient-map)
  87       'set-transient-map
  88     'set-temporary-overlay-map))
  89
  90 (defvar hydra-last nil
  91   "The result of the last `hydra-set-transient-map' call.")
  92
  93 ;;;###autoload
  94 (defmacro hydra-create (body heads &optional method)
  95   "Create a hydra with a BODY prefix and HEADS with METHOD.
  96 This will result in `global-set-key' statements with the keys
  97 being the concatenation of BODY and each head in HEADS.  HEADS is
  98 an list of (KEY FUNCTION &optional HINT).
  99
 100 After one of the HEADS is called via BODY+KEY, it and the other
 101 HEADS can be called with only KEY (no need for BODY).  This state
 102 is broken once any key binding that is not in HEADS is called.
 103
 104 METHOD is a lambda takes two arguments: a KEY and a COMMAND.
 105 It defaults to `global-set-key'.
 106 When `(keymapp METHOD)`, it becomes:
 107
 108     (lambda (key command) (define-key METHOD key command))"
 109   (declare (indent 1))
 110   `(defhydra ,(intern
 111                (concat
 112                 "hydra-" (replace-regexp-in-string " " "_" body)))
 113        ,(cond ((hydra--callablep method)
 114               method)
 115              ((null method)
 116               `(global-map ,body))
 117              (t
 118               (list method body)))
 119      "hydra"
 120      ,@(eval heads)))
 121
 122 (defun hydra--callablep (x)
 123   "Test if X is callable."
 124   (or (functionp x)
 125       (and (consp x)
 126            (memq (car x) '(function quote)))))
 127
 128 (defun hydra--color (h body-color)
 129   "Return the color of a Hydra head H with BODY-COLOR."
 130   (if (null (cadr h))
 131       'blue
 132     (let ((plist (if (stringp (cl-caddr h))
 133                      (cl-cdddr h)
 134                    (cddr h))))
 135       (or (plist-get plist :color) body-color))))
 136
 137 (defun hydra--face (h body-color)
 138   "Return the face for a Hydra head H with BODY-COLOR."
 139   (cl-case (hydra--color h body-color)
 140     (blue 'hydra-face-blue)
 141     (red 'hydra-face-red)
 142     (t (error "Unknown color for %S" h))))
 143
 144 (defun hydra--hint (docstring heads)
 145   "Generate a hint from DOCSTRING and HEADS.
 146 It's intended for the echo area, when a Hydra is active."
 147   (format "%s: %s."
 148           docstring
 149           (mapconcat
 150            (lambda (h)
 151              (format
 152               (if (stringp (cl-caddr h))
 153                   (concat "[%s]: " (cl-caddr h))
 154                 "%s")
 155               (propertize
 156                (car h) 'face
 157                (hydra--face h body-color))))
 158            heads ", ")))
 159
 160 (defun hydra-disable ()
 161   "Disable the current Hydra."
 162   (if (functionp hydra-last)
 163       (funcall hydra-last)
 164     (while (and (consp (car emulation-mode-map-alists))
 165                 (consp (caar emulation-mode-map-alists))
 166                 (equal (cl-cdaar emulation-mode-map-alists) ',keymap))
 167       (setq emulation-mode-map-alists
 168             (cdr emulation-mode-map-alists)))))
 169
 170 (defun hydra--doc (body-key body-name heads)
 171   "Generate a part of Hydra docstring.
 172 BODY-KEY is the body key binding.
 173 BODY-NAME is the symbol that identifies the Hydra.
 174 HEADS is a list of heads."
 175   (format
 176    "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
 177    (if body-key
 178        (format "a \"%s\"" body-key)
 179      "no")
 180    (mapconcat
 181     (lambda (x)
 182       (format "\"%s\":    `%S'" (car x) (cadr x)))
 183     heads ",\n")
 184    (format "The body can be accessed via `%S'." body-name)))
 185
 186 ;;;###autoload
 187 (defmacro defhydra (name body &optional docstring &rest heads)
 188   "Create a hydra named NAME with a prefix BODY.
 189
 190 NAME should be a symbol, it will be the prefix of all functions
 191 defined here.
 192
 193 BODY should be either:
 194
 195     (BODY-MAP &optional BODY-KEY &rest PLIST)
 196 or:
 197
 198     (lambda (KEY CMD) ...)
 199
 200 BODY-MAP should be a keymap; `global-map' is acceptable here.
 201 BODY-KEY should be a string processable by `kbd'.
 202
 203 DOCSTRING will be displayed in the echo area to identify the
 204 hydra.
 205
 206 HEADS is a list of (KEY CMD &optional HINT &rest PLIST).
 207
 208 PLIST in both cases recognizes only the :color key so far, which
 209 in turn can be either red or blue."
 210   (unless (stringp docstring)
 211     (setq heads (cons docstring heads))
 212     (setq docstring "hydra"))
 213   (when (keywordp (car body))
 214     (setq body (cons nil (cons nil body))))
 215   (let* ((keymap (make-sparse-keymap))
 216          (names (mapcar
 217                  (lambda (x)
 218                    (define-key keymap (kbd (car x))
 219                      (intern (format "%S/%s" name (cadr x)))))
 220                  heads))
 221          (body-name (intern (format "%S/body" name)))
 222          (body-key (unless (hydra--callablep body)
 223                      (cadr body)))
 224          (body-color (if (hydra--callablep body)
 225                          'red
 226                        (or (plist-get (cddr body) :color)
 227                            'red)))
 228          (method (if (hydra--callablep body)
 229                      body
 230                    (car body)))
 231          (hint (hydra--hint docstring heads))
 232          (doc (hydra--doc body-key body-name heads)))
 233     `(progn
 234        ,@(cl-mapcar
 235           (lambda (head name)
 236             `(defun ,name ()
 237                ,(format "%s\n\nCall the head: `%S'." doc (cadr head))
 238                (interactive)
 239                ,@(if (eq (hydra--color head body-color) 'blue)
 240                      `((hydra-disable)
 241                        ,@(unless (null (cadr head))
 242                                  `((call-interactively #',(cadr head)))))
 243                      `((call-interactively #',(cadr head))
 244                        (when hydra-is-helpful
 245                          (message ,hint))
 246                        (setq hydra-last
 247                              (hydra-set-transient-map ',keymap t))))))
 248           heads names)
 249        ,@(unless (or (null body-key)
 250                      (null method)
 251                      (hydra--callablep method))
 252                  `((unless (keymapp (lookup-key ,method (kbd ,body-key)))
 253                      (define-key ,method (kbd ,body-key) nil))))
 254        ,@(delq nil
 255                (cl-mapcar
 256                 (lambda (head name)
 257                   (unless (or (null body-key) (null method))
 258                     (list
 259                      (if (hydra--callablep method)
 260                          'funcall
 261                        'define-key)
 262                      method
 263                      (vconcat (kbd body-key) (kbd (car head)))
 264                      (list 'function name))))
 265                 heads names))
 266        (defun ,body-name ()
 267          ,doc
 268          (interactive)
 269          (when hydra-is-helpful
 270            (message ,hint))
 271          (setq hydra-last
 272                (hydra-set-transient-map ',keymap t))))))
 273
 274 (provide 'hydra)
 275 ;;; hydra.el ends here