;; Author: Oleh Krehel <ohwoeowho@gmail.com>
;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
;; URL: https://github.com/abo-abo/hydra
-;; Version: 0.10.0
+;; Version: 0.11.0
;; Keywords: bindings
;; Package-Requires: ((cl-lib "0.5"))
(require 'lv)
(defalias 'hydra-set-transient-map
- (if (fboundp 'set-transient-map)
- 'set-transient-map
- 'set-temporary-overlay-map))
+ (if (fboundp 'set-transient-map)
+ 'set-transient-map
+ (lambda (map keep-pred &optional on-exit)
+ (set-temporary-overlay-map map (hydra--pred on-exit)))))
+
+(defun hydra--pred (on-exit)
+ "Generate a predicate on whether to continue the Hydra state.
+Call ON-EXIT for clean-up.
+This is a compatibility code for Emacs older than 24.4."
+ `(lambda ()
+ (if (lookup-key hydra-curr-map (this-command-keys-vector))
+ t
+ (hydra-cleanup)
+ ,(when on-exit
+ `(funcall ,(hydra--make-callable on-exit)))
+ nil)))
;;* Customize
(defgroup hydra nil
"When non-nil, `lv-message' (not `message') will be used to display hints."
:type 'boolean)
+(defcustom hydra-verbose nil
+ "When non-nil, hydra will issue some non essential style warnings."
+ :type 'boolean)
+
+(defcustom hydra-key-format-spec "%s"
+ "Default `format'-style specifier for _a_ syntax in docstrings.
+When nil, you can specify your own at each location like this: _ 5a_.")
+
(defface hydra-face-red
'((t (:foreground "#FF0000" :bold t)))
"Red Hydra heads will persist indefinitely."
(font-lock-add-keywords
'emacs-lisp-mode
'(("(\\(defhydra\\)\\_> +\\(.*?\\)\\_>"
+ (1 font-lock-keyword-face)
+ (2 font-lock-type-face))
+ ("(\\(defhydradio\\)\\_> +\\(.*?\\)\\_>"
(1 font-lock-keyword-face)
(2 font-lock-type-face)))))
(interactive "P")
(let ((universal-argument-map hydra-curr-map))
(negative-argument arg)))
+;;* Repeat
+(defvar hydra-repeat--prefix-arg nil
+ "Prefix arg to use with `hydra-repeat'.")
+
+(defvar hydra-repeat--command nil
+ "Command to use with `hydra-repeat'.")
+
+(defun hydra-repeat ()
+ "Repeat last command with last prefix arg."
+ (interactive)
+ (unless (string-match "hydra-repeat$" (symbol-name last-command))
+ (setq hydra-repeat--command last-command)
+ (setq hydra-repeat--prefix-arg (or last-prefix-arg 1)))
+ (setq current-prefix-arg hydra-repeat--prefix-arg)
+ (funcall hydra-repeat--command))
;;* Misc internals
(defvar hydra-last nil
(defun hydra--head-property (h prop &optional default)
"Return for Hydra head H the value of property PROP.
Return DEFAULT if PROP is not in H."
- (let ((plist (if (or (stringp (cl-caddr h))
- (null (cl-caddr h)))
- (cl-cdddr h)
- (cddr h))))
+ (let ((plist (cl-cdddr h)))
(if (memq prop h)
(plist-get plist prop)
default)))
-(defun hydra--head-color (h body-color)
- "Return the color of a Hydra head H with BODY-COLOR."
- (let ((col (hydra--head-property h :color)))
- (cond ((null (cadr h))
- 'blue)
- ((null col)
- body-color)
- (t
- col))))
+(defun hydra--aggregate-color (head-color body-color)
+ "Return the resulting head color for HEAD-COLOR and BODY-COLOR."
+ (cond ((eq head-color 'red)
+ (cl-case body-color
+ (red 'red)
+ (blue 'red)
+ (amaranth 'amaranth)
+ (pink 'pink)
+ (cyan 'amaranth)))
+ ((eq head-color 'blue)
+ (cl-case body-color
+ (red 'blue)
+ (blue 'blue)
+ (amaranth 'teal)
+ (pink 'blue)
+ (cyan 'teal)))
+ (t
+ (error "Can't aggregate head %S to body %S"
+ head-color body-color))))
+
+(defun hydra--head-color (h body)
+ "Return the color of a Hydra head H with BODY."
+ (let* ((exit (hydra--head-property h :exit 'default))
+ (color (hydra--head-property h :color))
+ (foreign-keys (hydra--body-foreign-keys body))
+ (head-color
+ (cond ((eq exit 'default)
+ (cl-case color
+ (blue 'blue)
+ (red 'red)
+ (t
+ (unless (null color)
+ (error "Use only :blue or :red for heads: %S" h)))))
+ ((null exit)
+ (if color
+ (error "Don't mix :color and :exit - they are aliases: %S" h)
+ (cl-case foreign-keys
+ (run 'pink)
+ (warn 'amaranth)
+ (t 'red))))
+ ((eq exit t)
+ (if color
+ (error "Don't mix :color and :exit - they are aliases: %S" h)
+ 'blue))
+ (t
+ (error "Unknown :exit %S" exit)))))
+ (let ((body-exit (plist-get (cddr body) :exit)))
+ (cond ((null (cadr h))
+ (when head-color
+ (hydra--complain
+ "Doubly specified blue head - nil cmd is already blue: %S" h))
+ 'blue)
+ ((null head-color)
+ (hydra--body-color body))
+ ((null foreign-keys)
+ head-color)
+ ((eq foreign-keys 'run)
+ (if (eq head-color 'red)
+ 'pink
+ 'blue))
+ ((eq foreign-keys 'warn)
+ (if (memq head-color '(red amaranth))
+ 'amaranth
+ 'teal))
+ (t
+ (error "Unexpected %S %S" h body))))))
+
+(defun hydra--body-foreign-keys (body)
+ "Return what BODY does with a non-head binding."
+ (or
+ (plist-get (cddr body) :foreign-keys)
+ (let ((color (plist-get (cddr body) :color)))
+ (cl-case color
+ ((amaranth teal) 'warn)
+ (pink 'run)))))
(defun hydra--body-color (body)
"Return the color of BODY.
BODY is the second argument to `defhydra'"
- (or (plist-get (cddr body) :color) 'red))
-
-(defun hydra--face (h body-color)
- "Return the face for a Hydra head H with BODY-COLOR."
- (cl-case (hydra--head-color h body-color)
+ (let ((color (plist-get (cddr body) :color))
+ (exit (plist-get (cddr body) :exit))
+ (foreign-keys (plist-get (cddr body) :foreign-keys)))
+ (cond ((eq foreign-keys 'warn)
+ (if exit 'teal 'amaranth))
+ ((eq foreign-keys 'run) 'pink)
+ (exit 'blue)
+ (color color)
+ (t 'red))))
+
+(defun hydra--face (h body)
+ "Return the face for a Hydra head H with BODY."
+ (cl-case (hydra--head-color h body)
(blue 'hydra-face-blue)
(red 'hydra-face-red)
(amaranth 'hydra-face-amaranth)
(delete-window lv-wnd)
(kill-buffer buf))))
+(defun hydra-keyboard-quit ()
+ "Quitting function similar to `keyboard-quit'."
+ (interactive)
+ (hydra-disable)
+ (hydra-cleanup)
+ nil)
+
(defun hydra-disable ()
"Disable the current Hydra."
(cond
((functionp hydra-last)
(funcall hydra-last))
- ;; Emacs 24.4.1
- ((boundp 'overriding-terminal-local-map)
- (setq overriding-terminal-local-map nil))
+ ;; Emacs 24.3 or older
+ ((< emacs-minor-version 4)
+ (setq emulation-mode-map-alists
+ (cl-remove-if
+ (lambda (x)
+ (and (consp x)
+ (consp (car x))
+ (equal (cdar x) hydra-curr-map)))
+ emulation-mode-map-alists)))
- ;; older
+ ;; Emacs 24.4.1
(t
- (while (and (consp (car emulation-mode-map-alists))
- (consp (caar emulation-mode-map-alists))
- (equal (cl-cdaar emulation-mode-map-alists) ',keymap))
- (setq emulation-mode-map-alists
- (cdr emulation-mode-map-alists))))))
+ (setq overriding-terminal-local-map nil))))
(defun hydra--unalias-var (str prefix)
"Return the symbol named STR if it's bound as a variable.
(defun hydra--hint (name body docstring heads)
"Generate a hint for the echo area.
NAME, BODY, DOCSTRING and HEADS are parameters to `defhydra'."
- (let ((body-color (hydra--body-color body))
- alist)
+ (let (alist)
(dolist (h heads)
(let ((val (assoc (cadr h) alist))
- (pstr (propertize (car h) 'face
- (hydra--face h body-color))))
- (unless (and (> (length h) 2)
- (null (cl-caddr h)))
+ (pstr (hydra-fontify-head h body)))
+ (unless (null (cl-caddr h))
(if val
(setf (cadr val)
(concat (cadr val) " " pstr))
(push
(cons (cadr h)
- (cons pstr
- (and (stringp (cl-caddr h)) (cl-caddr h))))
+ (cons pstr (cl-caddr h)))
alist)))))
-
- (format (if (eq ?\n (aref docstring 0))
- "%s%s"
- "%s: %s.")
- docstring
- (mapconcat
- (lambda (x)
- (format
- (if (cdr x)
- (concat "[%s]: " (cdr x))
- "%s")
- (car x)))
- (nreverse (mapcar #'cdr alist))
- ", "))))
+ (mapconcat
+ (lambda (x)
+ (format
+ (if (> (length (cdr x)) 0)
+ (concat "[%s]: " (cdr x))
+ "%s")
+ (car x)))
+ (nreverse (mapcar #'cdr alist))
+ ", ")))
+
+(defvar hydra-fontify-head-function nil
+ "Possible replacement for `hydra-fontify-head-default'.")
+
+(defun hydra-fontify-head-default (head body)
+ "Produce a pretty string from HEAD and BODY.
+HEAD's binding is returned as a string with a colored face."
+ (propertize (car head) 'face (hydra--face head body)))
+
+(defun hydra-fontify-head-greyscale (head body)
+ "Produce a pretty string from HEAD and BODY.
+HEAD's binding is returned as a string wrapped with [] or {}."
+ (let ((color (hydra--head-color head body)))
+ (format
+ (if (eq color 'blue)
+ "[%s]"
+ "{%s}") (car head))))
+
+(defun hydra-fontify-head (head body)
+ "Produce a pretty string from HEAD and BODY."
+ (funcall (or hydra-fontify-head-function 'hydra-fontify-head-default)
+ head body))
(defun hydra--format (name body docstring heads)
"Generate a `format' statement from STR.
\"%`...\" expressions are extracted into \"%S\".
-NAME, HEADS and BODY-COLOR are parameters of `defhydra'.
+NAME, BODY, DOCSTRING and HEADS are parameters of `defhydra'.
The expressions can be auto-expanded according to NAME."
- (let ((str (hydra--hint name body docstring heads))
+ (setq docstring (replace-regexp-in-string "\\^" "" docstring))
+ (let ((rest (hydra--hint name body docstring heads))
(body-color (hydra--body-color body))
(prefix (symbol-name name))
(start 0)
- varlist)
- (while (setq start (string-match "%`\\([a-z-A-Z/0-9]+\\)" str start))
- (push (hydra--unalias-var (match-string 1 str) prefix) varlist)
- (setq str (replace-match "%S" nil nil str 0)))
- (setq start 0)
- (while (setq start (string-match "_\\([a-z-A-Z]+\\)_" str start))
- (let* ((key (match-string 1 str))
- (head (assoc key heads)))
- (if head
- (setq str (replace-match
- (propertize key 'face (hydra--face head body-color))
- nil nil str))
- (error "Unrecognized key: _%s_" key))))
- `(format ,str ,@(nreverse varlist))))
+ varlist
+ offset)
+ (while (setq start
+ (string-match
+ "\\(?:%\\( ?-?[0-9]*\\)\\(`[a-z-A-Z/0-9]+\\|(\\)\\)\\|\\(?:_\\( ?-?[0-9]*\\)\\([a-z-~A-Z0-9/|?<>={}]+\\)_\\)"
+ docstring start))
+ (cond ((eq ?_ (aref (match-string 0 docstring) 0))
+ (let* ((key (match-string 4 docstring))
+ (head (assoc key heads)))
+ (if head
+ (progn
+ (push (hydra-fontify-head head body) varlist)
+ (setq docstring
+ (replace-match
+ (or
+ hydra-key-format-spec
+ (concat "%" (match-string 3 docstring) "s"))
+ nil nil docstring)))
+ (error "Unrecognized key: _%s_" key))))
+
+ ((eq ?` (aref (match-string 2 docstring) 0))
+ (push (hydra--unalias-var
+ (substring (match-string 2 docstring) 1) prefix) varlist)
+ (setq docstring
+ (replace-match
+ (concat "%" (match-string 1 docstring) "S")
+ nil nil docstring 0)))
+
+ (t
+ (setq offset
+ (with-temp-buffer
+ (insert (substring docstring (1+ start)))
+ (goto-char (point-min))
+ (push (read (current-buffer)) varlist)
+ (point)))
+ (setq docstring
+ (concat
+ (substring docstring 0 start)
+ "%" (match-string 1 docstring) "S"
+ (substring docstring
+ (+ (match-end 2) offset -2)))))))
+ (if (eq ?\n (aref docstring 0))
+ `(concat (format ,(substring docstring 1) ,@(nreverse varlist))
+ ,rest)
+ `(format ,(concat docstring ": " rest ".")))))
(defun hydra--message (name body docstring heads)
"Generate code to display the hint in the preferred echo area.
(lv-message ,format-expr)
(message ,format-expr))))
+(defun hydra--complain (format-string &rest args)
+ "Forward to (`message' FORMAT-STRING ARGS) unless `hydra-verbose' is nil."
+ (when hydra-verbose
+ (apply #'warn format-string args)))
+
(defun hydra--doc (body-key body-name heads)
"Generate a part of Hydra docstring.
BODY-KEY is the body key binding.
heads ",\n")
(format "The body can be accessed via `%S'." body-name)))
-(defun hydra--make-defun (name cmd color
- doc hint keymap
- body-color body-pre body-post &optional other-post)
- "Make a defun wrapper, using NAME, CMD, COLOR, DOC, HINT, and KEYMAP.
-BODY-COLOR, BODY-PRE, BODY-POST, and OTHER-POST are used as well."
- `(defun ,name ()
- ,doc
- (interactive)
- ,@(when body-pre (list body-pre))
- (hydra-disable)
- ,@(when (memq color '(blue teal)) '((hydra-cleanup)))
- (catch 'hydra-disable
- ,@(delq nil
- (if (memq color '(blue teal))
- `(,(when cmd `(call-interactively #',cmd))
- ,body-post)
- `(,(when cmd
- `(condition-case err
- (prog1 t
- (call-interactively #',cmd))
- (error
- (message "%S" err)
- (unless hydra-lv
- (sit-for 0.8))
- nil)))
- (when hydra-is-helpful
- (,hint))
- (setq hydra-last
- (hydra-set-transient-map
- (setq hydra-curr-map ',keymap)
- t
- ,(if (and (not (eq body-color 'amaranth)) body-post)
- `(lambda () (hydra-cleanup) ,body-post)
- `(lambda () (hydra-cleanup)))))
- ,other-post))))))
+(defun hydra--make-defun (name body doc head
+ keymap body-pre body-post &optional other-post)
+ "Make a defun wrapper, using NAME, BODY, DOC, HEAD, and KEYMAP.
+NAME and BODY are the arguments to `defhydra'.
+DOC was generated with `hydra--doc'.
+HEAD is one of the HEADS passed to `defhydra'.
+BODY-PRE and BODY-POST are pre-processed in `defhydra'.
+OTHER-POST is an optional extension to the :post key of BODY."
+ (let ((name (hydra--head-name head name))
+ (cmd (when (car head)
+ (hydra--make-callable
+ (cadr head))))
+ (color (when (car head)
+ (hydra--head-color head body)))
+ (doc (if (car head)
+ (format "%s\n\nCall the head: `%S'." doc (cadr head))
+ doc))
+ (hint (intern (format "%S/hint" name)))
+ (body-color (hydra--body-color body)))
+ `(defun ,name ()
+ ,doc
+ (interactive)
+ ,@(when body-pre (list body-pre))
+ (hydra-disable)
+ ,@(when (memq color '(blue teal)) '((hydra-cleanup)))
+ (catch 'hydra-disable
+ ,@(delq nil
+ (if (memq color '(blue teal))
+ `(,(when cmd `(call-interactively #',cmd))
+ ,body-post)
+ `(,(when cmd
+ `(condition-case err
+ (prog1 t
+ (call-interactively #',cmd))
+ ((quit error)
+ (message "%S" err)
+ (unless hydra-lv
+ (sit-for 0.8))
+ nil)))
+ (when hydra-is-helpful
+ (,hint))
+ (setq hydra-last
+ (hydra-set-transient-map
+ (setq hydra-curr-map ',keymap)
+ t
+ ,(if (and
+ (not (memq body-color
+ '(amaranth pink teal)))
+ body-post)
+ `(lambda () (hydra-cleanup) ,body-post)
+ `(lambda () (hydra-cleanup)))))
+ ,other-post)))))))
(defun hydra-pink-fallback ()
+ "On intercepting a non-head, try to run it."
(let ((keys (this-command-keys))
kb)
(when (equal keys [backspace])
(if (commandp kb)
(condition-case err
(call-interactively kb)
- (error
+ ((quit error)
(message "%S" err)
(unless hydra-lv
(sit-for 0.8))))
(message "Pink Hydra can't currently handle prefixes, continuing"))
(message "Pink Hydra could not resolve: %S" keys))))
+(defun hydra--handle-nonhead (keymap name body heads)
+ "Setup KEYMAP for intercepting non-head bindings.
+NAME, BODY and HEADS are parameters to `defhydra'."
+ (let ((body-color (hydra--body-color body))
+ (body-post (plist-get (cddr body) :post)))
+ (when (and body-post (symbolp body-post))
+ (setq body-post `(funcall #',body-post)))
+ (when hydra-keyboard-quit
+ (define-key keymap hydra-keyboard-quit #'hydra-keyboard-quit))
+ (when (memq body-color '(amaranth pink teal))
+ (if (cl-some `(lambda (h)
+ (memq (hydra--head-color h body) '(blue teal)))
+ heads)
+ (progn
+ (define-key keymap [t]
+ `(lambda ()
+ (interactive)
+ ,(cond
+ ((memq body-color '(amaranth teal))
+ '(message "An amaranth Hydra can only exit through a blue head"))
+ (t
+ '(hydra-pink-fallback)))
+ (hydra-set-transient-map hydra-curr-map t)
+ (when hydra-is-helpful
+ (unless hydra-lv
+ (sit-for 0.8))
+ (,(intern (format "%S/hint" name)))))))
+ (unless (eq body-color 'teal)
+ (error
+ "An %S Hydra must have at least one blue head in order to exit"
+ body-color))))))
+
+(defun hydra--head-name (h body-name)
+ "Return the symbol for head H of body BODY-NAME."
+ (intern (format "%S/%s" body-name
+ (if (symbolp (cadr h))
+ (cadr h)
+ (concat "lambda-" (car h))))))
+
+(defun hydra--delete-duplicates (heads)
+ "Return HEADS without entries that have the same CMD part.
+In duplicate HEADS, :cmd-name is modified to whatever they duplicate."
+ (let ((ali '(((hydra-repeat . red) . hydra-repeat)))
+ res entry)
+ (dolist (h heads)
+ (if (setq entry (assoc (cons (cadr h)
+ (hydra--head-color h '(nil nil)))
+ ali))
+ (setf (cl-cdddr h) (plist-put (cl-cdddr h) :cmd-name (cdr entry)))
+ (push (cons (cons (cadr h)
+ (hydra--head-color h '(nil nil)))
+ (plist-get (cl-cdddr h) :cmd-name))
+ ali)
+ (push h res)))
+ (nreverse res)))
+
+(defun hydra--pad (lst n)
+ "Pad LST with nil until length N."
+ (let ((len (length lst)))
+ (if (= len n)
+ lst
+ (append lst (make-list (- n len) nil)))))
+
+(defun hydra--matrix (lst rows cols)
+ "Create a matrix from elements of LST.
+The matrix size is ROWS times COLS."
+ (let ((ls (copy-sequence lst))
+ res)
+ (dotimes (c cols)
+ (push (hydra--pad (hydra-multipop ls rows) rows) res))
+ (nreverse res)))
+
+(defun hydra--cell (fstr names)
+ "Format a rectangular cell based on FSTR and NAMES.
+FSTR is a format-style string with two string inputs: one for the
+doc and one for the symbol name.
+NAMES is a list of variables."
+ (let ((len (cl-reduce
+ (lambda (acc it) (max (length (symbol-name it)) acc))
+ names
+ :initial-value 0)))
+ (mapconcat
+ (lambda (sym)
+ (if sym
+ (format fstr
+ (documentation-property sym 'variable-documentation)
+ (let ((name (symbol-name sym)))
+ (concat name (make-string (- len (length name)) ?^)))
+ sym)
+ ""))
+ names
+ "\n")))
+
+(defun hydra--vconcat (strs &optional joiner)
+ "Glue STRS vertically. They must be the same height.
+JOINER is a function similar to `concat'."
+ (setq joiner (or joiner #'concat))
+ (mapconcat
+ (lambda (s)
+ (if (string-match " +$" s)
+ (replace-match "" nil nil s)
+ s))
+ (apply #'cl-mapcar joiner
+ (mapcar
+ (lambda (s) (split-string s "\n"))
+ strs))
+ "\n"))
+
+(defcustom hydra-cell-format "% -20s %% -8`%s"
+ "The default format for docstring cells."
+ :type 'string)
+
+(defun hydra--table (names rows cols &optional cell-formats)
+ "Format a `format'-style table from variables in NAMES.
+The size of the table is ROWS times COLS.
+CELL-FORMATS are `format' strings for each column.
+If CELL-FORMATS is a string, it's used for all columns.
+If CELL-FORMATS is nil, `hydra-cell-format' is used for all columns."
+ (setq cell-formats
+ (cond ((null cell-formats)
+ (make-list cols hydra-cell-format))
+ ((stringp cell-formats)
+ (make-list cols cell-formats))
+ (t
+ cell-formats)))
+ (hydra--vconcat
+ (cl-mapcar
+ #'hydra--cell
+ cell-formats
+ (hydra--matrix names rows cols))
+ (lambda (&rest x)
+ (mapconcat #'identity x " "))))
+
+(defun hydra-reset-radios (names)
+ "Set varibles NAMES to their defaults.
+NAMES should be defined by `defhydradio' or similar."
+ (dolist (n names)
+ (set n (aref (get n 'range) 0))))
+
;;* Macros
;;** defhydra
;;;###autoload
generated NAME/body command. This command is also the return
result of `defhydra'."
(declare (indent defun))
- (unless (stringp docstring)
- (setq heads (cons docstring heads))
- (setq docstring "hydra"))
+ (cond ((stringp docstring))
+ ((and (consp docstring)
+ (memq (car docstring) '(hydra--table concat format)))
+ (setq docstring (concat "\n" (eval docstring))))
+ (t
+ (setq heads (cons docstring heads))
+ (setq docstring "hydra")))
(when (keywordp (car body))
(setq body (cons nil (cons nil body))))
+ (dolist (h heads)
+ (let ((len (length h))
+ (cmd-name (hydra--head-name h name)))
+ (cond ((< len 2)
+ (error "Each head should have at least two items: %S" h))
+ ((= len 2)
+ (setcdr (cdr h) `("" :cmd-name ,cmd-name)))
+ (t
+ (let ((hint (cl-caddr h)))
+ (unless (or (null hint)
+ (stringp hint))
+ (setcdr (cdr h) (cons "" (cddr h))))
+ (setcdr (cddr h) `(:cmd-name ,cmd-name ,@(cl-cdddr h))))))))
(let* ((keymap (copy-keymap hydra-base-map))
- (names (mapcar
- (lambda (x)
- (define-key keymap (kbd (car x))
- (intern (format "%S/%s" name
- (if (symbolp (cadr x))
- (cadr x)
- (concat "lambda-" (car x)))))))
- heads))
(body-name (intern (format "%S/body" name)))
- (hint-name (intern (format "%S/hint" name)))
(body-key (unless (hydra--callablep body)
(cadr body)))
(body-color (hydra--body-color body))
(body-pre (plist-get (cddr body) :pre))
+ (body-body-pre (plist-get (cddr body) :body-pre))
(body-post (plist-get (cddr body) :post))
(method (or (plist-get body :bind)
(car body)))
- (doc (hydra--doc body-key body-name heads)))
- (when (and (or body-pre body-post)
- (version< emacs-version "24.4"))
- (error "At least Emacs 24.4 is needed for :pre and :post"))
+ (doc (hydra--doc body-key body-name heads))
+ (heads-nodup (hydra--delete-duplicates heads)))
+ (mapc
+ (lambda (x)
+ (define-key keymap (kbd (car x))
+ (plist-get (cl-cdddr x) :cmd-name)))
+ heads)
(when (and body-pre (symbolp body-pre))
(setq body-pre `(funcall #',body-pre)))
+ (when (and body-body-pre (symbolp body-body-pre))
+ (setq body-body-pre `(funcall #',body-body-pre)))
(when (and body-post (symbolp body-post))
(setq body-post `(funcall #',body-post)))
- (when (memq body-color '(amaranth pink teal))
- (if (cl-some `(lambda (h)
- (eq (hydra--head-color h ',body-color) 'blue))
- heads)
- (progn
- (when (cl-some `(lambda (h)
- (eq (hydra--head-color h ',body-color) 'red))
- heads)
- (warn
- "%S body color: upgrading all red heads to %S"
- body-color body-color))
- (define-key keymap [t]
- `(lambda ()
- (interactive)
- ,@(cond
- ((eq body-color 'amaranth)
- '((message "An amaranth Hydra can only exit through a blue head")))
- ((eq body-color 'teal)
- '((message "A teal Hydra can only exit through a blue head")))
- (t
- '((hydra-pink-fallback))))
- (hydra-set-transient-map hydra-curr-map t)
- (when hydra-is-helpful
- (unless hydra-lv
- (sit-for 0.8))
- (,hint-name)))))
- (error
- "An %S Hydra must have at least one blue head in order to exit"
- body-color))
- (when hydra-keyboard-quit
- (define-key keymap hydra-keyboard-quit
- `(lambda ()
- (interactive)
- (hydra-disable)
- (hydra-cleanup)
- ,body-post))))
+ (hydra--handle-nonhead keymap name body heads)
`(progn
- ,@(cl-mapcar
- (lambda (head name)
- (hydra--make-defun
- name (hydra--make-callable
- (cadr head)) (hydra--head-color head body-color)
- (format "%s\n\nCall the head: `%S'." doc (cadr head))
- hint-name keymap
- body-color body-pre body-post))
- heads names)
+ ,@(mapcar
+ (lambda (head)
+ (hydra--make-defun name body doc head keymap
+ body-pre body-post))
+ heads-nodup)
,@(unless (or (null body-key)
(null method)
(hydra--callablep method))
(define-key ,method (kbd ,body-key) nil))))
,@(delq nil
(cl-mapcar
- (lambda (head name)
- (when (or body-key method)
- (let ((bind (hydra--head-property head :bind 'default))
- (final-key
- (if body-key
- (vconcat (kbd body-key) (kbd (car head)))
- (kbd (car head)))))
- (cond ((null bind) nil)
-
- ((eq bind 'default)
- (list
- (if (hydra--callablep method)
- 'funcall
- 'define-key)
- method
- final-key
- (list 'function name)))
-
- ((hydra--callablep bind)
- `(funcall (function ,bind)
- ,final-key
- (function ,name)))
-
- (t
- (error "Invalid :bind property %S" head))))))
- heads names))
- (defun ,hint-name ()
+ (lambda (head)
+ (let ((name (hydra--head-property head :cmd-name)))
+ (when (cadr head)
+ (when (or body-key method)
+ (let ((bind (hydra--head-property head :bind 'default))
+ (final-key
+ (if body-key
+ (vconcat (kbd body-key) (kbd (car head)))
+ (kbd (car head)))))
+ (cond ((null bind) nil)
+
+ ((eq bind 'default)
+ (list
+ (if (hydra--callablep method)
+ 'funcall
+ 'define-key)
+ method
+ final-key
+ (list 'function name)))
+
+ ((hydra--callablep bind)
+ `(funcall (function ,bind)
+ ,final-key
+ (function ,name)))
+
+ (t
+ (error "Invalid :bind property %S" head))))))))
+ heads))
+ (defun ,(intern (format "%S/hint" name)) ()
,(hydra--message name body docstring heads))
- ,(hydra--make-defun body-name nil nil doc hint-name keymap
- body-color body-pre body-post
- '(setq prefix-arg current-prefix-arg)))))
+ ,(hydra--make-defun
+ name body doc '(nil body)
+ keymap
+ (or body-body-pre body-pre) body-post
+ '(setq prefix-arg current-prefix-arg)))))
(defmacro defhydradio (name body &rest heads)
"Create radios with prefix NAME.
VALUE defaults to [nil t].
DOC defaults to TOGGLE-NAME split and capitalized."
(declare (indent defun))
- (cons 'progn
- (apply #'append
- (mapcar (lambda (h)
- (hydra--radio name h))
- heads))))
+ `(progn
+ ,@(apply #'append
+ (mapcar (lambda (h)
+ (hydra--radio name h))
+ heads))
+ (defvar ,(intern (format "%S/names" name))
+ ',(mapcar (lambda (h) (intern (format "%S/%S" name (car h))))
+ heads))))
+
+(defmacro hydra-multipop (lst n)
+ "Return LST's first N elements while removing them."
+ `(if (<= (length ,lst) ,n)
+ (prog1 ,lst
+ (setq ,lst nil))
+ (prog1 ,lst
+ (setcdr
+ (nthcdr (1- ,n) (prog1 ,lst (setq ,lst (nthcdr ,n ,lst))))
+ nil))))
(defun hydra--radio (parent head)
"Generate a hydradio with PARENT from HEAD."
(let* ((name (car head))
(full-name (intern (format "%S/%S" parent name)))
- (val (or (cadr head) [nil t]))
- (doc (or (cl-caddr head)
- (mapconcat #'capitalize
- (split-string (symbol-name name) "-")
- " "))))
+ (doc (cadr head))
+ (val (or (cl-caddr head) [nil t])))
`((defvar ,full-name ,(hydra--quote-maybe (aref val 0)) ,doc)
(put ',full-name 'range ,val)
(defun ,full-name ()
(defun hydra--quote-maybe (x)
"Quote X if it's a symbol."
- (if (symbolp x)
- (list 'quote x)
- x))
+ (cond ((null x)
+ nil)
+ ((symbolp x)
+ (list 'quote x))
+ (t
+ x)))
(defun hydra--cycle-radio (sym)
"Set SYM to the next value in its range."