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.3.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 ;;; Code:
  56 (require 'cl-lib)
  57
  58 (defgroup hydra nil
  59   "Make bindings that stick around."
  60   :group 'bindings
  61   :prefix "hydra-")
  62
  63 (defcustom hydra-is-helpful t
  64   "When t, display a hint with possible bindings in the echo area."
  65   :type 'boolean
  66   :group 'hydra)
  67
  68 (defalias 'hydra-set-transient-map
  69   (if (fboundp 'set-transient-map)
  70       'set-transient-map
  71     'set-temporary-overlay-map))
  72
  73 (defvar hydra-last nil
  74   "The result of the last `hydra-set-transient-map' call.")
  75
  76 ;;;###autoload
  77 (defmacro hydra-create (body heads &optional method)
  78   "Create a hydra with a BODY prefix and HEADS with METHOD.
  79 This will result in `global-set-key' statements with the keys
  80 being the concatenation of BODY and each head in HEADS.  HEADS is
  81 an list of (KEY FUNCTION &optional HINT).
  82
  83 After one of the HEADS is called via BODY+KEY, it and the other
  84 HEADS can be called with only KEY (no need for BODY).  This state
  85 is broken once any key binding that is not in HEADS is called.
  86
  87 METHOD is a lambda takes two arguments: a KEY and a COMMAND.
  88 It defaults to `global-set-key'.
  89 When `(keymapp METHOD)`, it becomes:
  90
  91     (lambda (key command) (define-key METHOD key command))"
  92   (declare (indent 1))
  93   (let* ((keymap (make-sparse-keymap))
  94          (heads (eval heads))
  95          (names (mapcar
  96                  (lambda (x)
  97                    (define-key keymap (kbd (car x))
  98                      (intern (format "hydra-%s-%S" body (cadr x)))))
  99                  heads))
 100          (hint (format "hydra: %s."
 101                        (mapconcat
 102                         (lambda (h)
 103                           (format
 104                            (if (cl-caddr h)
 105                                (concat "[%s]: " (cl-caddr h))
 106                              "%s")
 107                            (propertize (car h) 'face 'font-lock-keyword-face)))
 108                         heads ", ")))
 109          (doc (format
 110                "Create a hydra with a \"%s\" body and the heads:\n\n%s."
 111                body
 112                (mapconcat
 113                 (lambda (x)
 114                   (format "\"%s\":    `%S'" (car x) (cadr x)))
 115                 heads ",\n"))))
 116     `(progn
 117        ,@(cl-mapcar
 118           (lambda (head name)
 119             `(defun ,name ()
 120                ,(format "%s\n\nCall the head: `%S'." doc (cadr head))
 121                (interactive)
 122                ,@(if (null (cadr head))
 123                      '((funcall hydra-last))
 124                      `((call-interactively #',(cadr head))
 125                        (when hydra-is-helpful
 126                          (message ,hint))
 127                        (setq hydra-last
 128                              (hydra-set-transient-map ',keymap t))))))
 129           heads names)
 130        (defun ,(intern (format "hydra-%s-body" body)) ()
 131          ,doc
 132          (interactive)
 133          (when hydra-is-helpful
 134            (message ,hint))
 135          (setq hydra-last (hydra-set-transient-map ',keymap t)))
 136        ,@(cond ((null method)
 137                 `((unless (keymapp (global-key-binding (kbd ,body)))
 138                     (global-set-key (kbd ,body) nil))))
 139                ((or (functionp method)
 140                     (and (consp method)
 141                          (memq (car method) '(function quote))))
 142                 nil)
 143                (t
 144                 `((unless (keymapp (lookup-key ,method (kbd ,body)))
 145                     (define-key ,method (kbd ,body) nil)))))
 146        ,@(cl-mapcar
 147           (lambda (head name)
 148             `(,@(cond ((null method)
 149                       (list 'global-set-key))
 150                       ((or (functionp method)
 151                            (and (consp method)
 152                                 (memq (car method) '(function quote))))
 153                       (list 'funcall method))
 154                      (t
 155                       (list 'define-key method)))
 156                 ,(vconcat (kbd body) (kbd (car head))) #',name))
 157           heads names))))
 158
 159 (provide 'hydra)
 160 ;;; hydra.el ends here