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.4.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 (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 (defalias 'hydra-set-transient-map
  77   (if (fboundp 'set-transient-map)
  78       'set-transient-map
  79     'set-temporary-overlay-map))
  80
  81 (defvar hydra-last nil
  82   "The result of the last `hydra-set-transient-map' call.")
  83
  84 ;;;###autoload
  85 (defmacro hydra-create (body heads &optional method)
  86   "Create a hydra with a BODY prefix and HEADS with METHOD.
  87 This will result in `global-set-key' statements with the keys
  88 being the concatenation of BODY and each head in HEADS.  HEADS is
  89 an list of (KEY FUNCTION &optional HINT).
  90
  91 After one of the HEADS is called via BODY+KEY, it and the other
  92 HEADS can be called with only KEY (no need for BODY).  This state
  93 is broken once any key binding that is not in HEADS is called.
  94
  95 METHOD is a lambda takes two arguments: a KEY and a COMMAND.
  96 It defaults to `global-set-key'.
  97 When `(keymapp METHOD)`, it becomes:
  98
  99     (lambda (key command) (define-key METHOD key command))"
 100   (declare (indent 1))
 101   `(defhydra ,(intern
 102                (concat
 103                 "hydra-" (replace-regexp-in-string " " "_" body)))
 104        ,(cond ((hydra--callablep method)
 105               method)
 106              ((null method)
 107               `(global-map ,body))
 108              (t
 109               (list method body)))
 110      "hydra"
 111      ,@(eval heads)))
 112
 113 (defun hydra--callablep (x)
 114   "Test if X looks like it's callable."
 115   (or (functionp x)
 116       (and (consp x)
 117            (memq (car x) '(function quote)))))
 118
 119 (defmacro defhydra (name body &optional docstring &rest heads)
 120   "Create a hydra named NAME with a prefix BODY.
 121
 122 NAME should be a symbol, it will be the prefix of all functions
 123 defined here.
 124
 125 BODY should be either:
 126
 127     (BODY-MAP &optional BODY-KEY)
 128 or:
 129
 130     (lambda (KEY CMD) ...)
 131
 132 BODY-MAP should be a keymap; `global-map' is acceptable here.
 133 BODY-KEY should be a string processable by `kbd'.
 134
 135 DOCSTRING will be displayed in the echo area to identify the
 136 hydra.
 137
 138 HEADS is a list of (KEY CMD &optional HINT)."
 139   (unless (stringp docstring)
 140     (setq heads (cons docstring heads))
 141     (setq docstring "hydra"))
 142   (let* ((keymap (make-sparse-keymap))
 143          (names (mapcar
 144                  (lambda (x)
 145                    (define-key keymap (kbd (car x))
 146                      (intern (format "%S/%s" name (cadr x)))))
 147                  heads))
 148          (body-name (intern (format "%S/body" name)))
 149          (body-key (unless (hydra--callablep body)
 150                      (cadr body)))
 151          (method (if (hydra--callablep body)
 152                      body
 153                    (car body)))
 154          (hint (format "%s: %s."
 155                        docstring
 156                        (mapconcat
 157                         (lambda (h)
 158                           (format
 159                            (if (cl-caddr h)
 160                                (concat "[%s]: " (cl-caddr h))
 161                              "%s")
 162                            (propertize (car h) 'face 'font-lock-keyword-face)))
 163                         heads ", ")))
 164          (doc (format
 165                "Create a hydra with %s body and the heads:\n\n%s\n\n%s"
 166                (if body-key
 167                    (format "a \"%s\"" body-key)
 168                  "no")
 169                (mapconcat
 170                 (lambda (x)
 171                   (format "\"%s\":    `%S'" (car x) (cadr x)))
 172                 heads ",\n")
 173                (format "The body can be accessed via `%S'." body-name))))
 174     `(progn
 175        ,@(cl-mapcar
 176           (lambda (head name)
 177             `(defun ,name ()
 178                ,(format "%s\n\nCall the head: `%S'." doc (cadr head))
 179                (interactive)
 180                ,@(if (null (cadr head))
 181                      `((if (functionp hydra-last)
 182                            (funcall hydra-last)
 183                          (while (and (consp (car emulation-mode-map-alists))
 184                                      (consp (caar emulation-mode-map-alists))
 185                                      (equal (cl-cdaar emulation-mode-map-alists) ',keymap))
 186                            (setq emulation-mode-map-alists
 187                                  (cdr emulation-mode-map-alists)))))
 188                      `((call-interactively #',(cadr head))
 189                        (when hydra-is-helpful
 190                          (message ,hint))
 191                        (setq hydra-last
 192                              (hydra-set-transient-map ',keymap t))))))
 193           heads names)
 194        ,@(unless (or (null body-key)
 195                      (null method)
 196                      (hydra--callablep method))
 197                  `((unless (keymapp (lookup-key ,method (kbd ,body-key)))
 198                      (define-key ,method (kbd ,body-key) nil))))
 199        ,@(delq nil
 200                (cl-mapcar
 201                 (lambda (head name)
 202                   (unless (or (null body-key) (null method))
 203                     (list
 204                      (if (hydra--callablep method)
 205                          'funcall
 206                        'define-key)
 207                      method
 208                      (vconcat (kbd body-key) (kbd (car head)))
 209                      (list 'function name))))
 210                 heads names))
 211        (defun ,body-name ()
 212          ,doc
 213          (interactive)
 214          (when hydra-is-helpful
 215            (message ,hint))
 216          (setq hydra-last
 217                (hydra-set-transient-map ',keymap t))))))
 218
 219 (provide 'hydra)
 220 ;;; hydra.el ends here