branch: master
commit c049a33c2c3b7ed949880943175d7e23d278bead
Author: Oleh Krehel <ohwoeo...@gmail.com>
Commit: Oleh Krehel <ohwoeo...@gmail.com>
Allow for Ruby-style Hydra docstrings
* hydra.el (hydra--unalias-var): New defun.
(hydra--format): New defun.
(hydra--message): Use `hydra-format' instead of a static string.
Update signature.
(defhydra): Add a warning the pink Hydras can't yet handle unbound
prefix, e.g. "C-x". Update arguments given to `hydra--message'.
* hydra-test.el: Update tests, only hint functions were slightly
affected.
Example of using the newfound functionality:
(defhydra hydra-toggle (:color pink)
"
_a_ abbrev-mode: %`abbrev-mode
_d_ debug-on-error: %`debug-on-error
_f_ auto-fill-mode: %`auto-fill-function
_g_ golden-ratio-mode: %`golden-ratio-mode
_t_ truncate-lines: %`truncate-lines
_w_ whitespace-mode: %`whitespace-mode
"
("a" abbrev-mode nil)
("d" toggle-debug-on-error nil)
("f" auto-fill-mode nil)
("g" golden-ratio-mode nil)
("t" toggle-truncate-lines nil)
("w" whitespace-mode nil)
("q" nil "cancel"))
(global-set-key (kbd "C-c C-v") 'hydra-toggle/body)
Here, "Foo %`abbrev-mode" becomes equivelent to:
(format "Foo %S" abbrev-mode).
And "_a_" becomes equivalent to:
(propertize "a" 'face 'hydra-face-pink).
The hints for all heads except "q" have been set to nil, since their
equivalent is already displayed in the docstring.
---
hydra-test.el | 30 ++++++++++++------
hydra.el | 96 +++++++++++++++++++++++++++++++++++++++++----------------
2 files changed, 89 insertions(+), 37 deletions(-)
diff --git a/hydra-test.el b/hydra-test.el
index 09eb6d0..429cf14 100644
--- a/hydra-test.el
+++ b/hydra-test.el
@@ -187,9 +187,12 @@ Call the head: `previous-error'."
(define-key global-map [134217831 107]
(function hydra-error/previous-error))
(defun hydra-error/hint nil
- (hydra--message #("error: [h]: first, [j]: next, [k]: prev." 8 9 (face
hydra-face-red)
- 20 21 (face hydra-face-red)
- 31 32 (face hydra-face-red))))
+ (if hydra-lv (lv-message (format #("error: [h]: first, [j]: next, [k]:
prev." 8 9 (face hydra-face-red)
+ 20 21 (face hydra-face-red)
+ 31 32 (face hydra-face-red))))
+ (message (format #("error: [h]: first, [j]: next, [k]: prev." 8 9
(face hydra-face-red)
+ 20 21 (face hydra-face-red)
+ 31 32 (face hydra-face-red))))))
(defun hydra-error/body nil "Create a hydra with a \"M-g\" body and the
heads:
\"h\": `first-error',
@@ -305,10 +308,14 @@ Call the head: `nil'."
(hydra-cleanup)
(catch (quote hydra-disable)))
(defun hydra-toggle/hint nil
- (hydra--message #("toggle: [t]: truncate, [f]: fill, [a]: abbrev, [q]:
cancel." 9 10 (face hydra-face-blue)
- 24 25 (face hydra-face-blue)
- 35 36 (face hydra-face-blue)
- 48 49 (face hydra-face-blue))))
+ (if hydra-lv (lv-message (format #("toggle: [t]: truncate, [f]: fill,
[a]: abbrev, [q]: cancel." 9 10 (face hydra-face-blue)
+ 24 25 (face hydra-face-blue)
+ 35 36 (face hydra-face-blue)
+ 48 49 (face hydra-face-blue))))
+ (message (format #("toggle: [t]: truncate, [f]: fill, [a]: abbrev,
[q]: cancel." 9 10 (face hydra-face-blue)
+ 24 25 (face hydra-face-blue)
+ 35 36 (face hydra-face-blue)
+ 48 49 (face hydra-face-blue))))))
(defun hydra-toggle/body nil "Create a hydra with no body and the heads:
\"t\": `toggle-truncate-lines',
@@ -503,9 +510,12 @@ Call the head: `nil'."
(catch (quote hydra-disable)
(set-cursor-color "#ffffff")))
(defun hydra-vi/hint nil
- (hydra--message #("vi: j, k, [q]: quit." 4 5 (face
hydra-face-amaranth)
- 7 8 (face hydra-face-amaranth)
- 11 12 (face hydra-face-blue))))
+ (if hydra-lv (lv-message (format #("vi: j, k, [q]: quit." 4 5 (face
hydra-face-amaranth)
+ 7 8 (face hydra-face-amaranth)
+ 11 12 (face hydra-face-blue))))
+ (message (format #("vi: j, k, [q]: quit." 4 5 (face
hydra-face-amaranth)
+ 7 8 (face hydra-face-amaranth)
+ 11 12 (face hydra-face-blue))))))
(defun hydra-vi/body nil "Create a hydra with no body and the heads:
\"j\": `next-line',
diff --git a/hydra.el b/hydra.el
index ff03722..bdd2570 100644
--- a/hydra.el
+++ b/hydra.el
@@ -101,7 +101,8 @@ It's the only other way to quit it besides though a blue
head.
It's possible to set this to nil.")
(defcustom hydra-lv t
- "When non-nil, `lv-message' will be used to display hints instead of
`message'."
+ "When non-nil, `lv-message' will be used to display hints
+instead of `message'."
:type 'boolean)
(defface hydra-face-red
@@ -287,12 +288,44 @@ It's intended for the echo area, when a Hydra is active."
(setq emulation-mode-map-alists
(cdr emulation-mode-map-alists))))))
-(defun hydra--message (format-str &rest args)
- "Forward to (`message' FORMAT-STR ARGS).
-Or to `lv-message' if `hydra-lv' is non-nil."
- (if hydra-lv
- (apply #'lv-message format-str args)
- (apply #'message format-str args)))
+(defun hydra--unalias-var (str prefix)
+ "Return the symbol named STR if it's bound as a variable.
+Otherwise, add PREFIX to the symbol name."
+ (let ((sym (intern-soft str)))
+ (if (boundp sym)
+ sym
+ (intern (concat prefix "/" str)))))
+
+(defun hydra--format (str name heads body-color)
+ "Generate a `format' statement from STR.
+\"%`...\" expressions are extracted into \"%S\".
+NAME, HEADS and BODY-COLOR are parameters of `defhydra'.
+The expressions can be auto-expanded according to NAME."
+ (let ((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))))
+
+(defun hydra--message (str name heads body-color)
+ "Generate code to display STR in the preferred echo area.
+Set `hydra-lv' to choose the echo area.
+NAME, HEADS and BODY-COLOR are parameters of `defhydra'."
+ (let ((format-expr (hydra--format str name heads body-color)))
+ `(if hydra-lv
+ (lv-message ,format-expr)
+ (message ,format-expr))))
(defun hydra--doc (body-key body-name heads)
"Generate a part of Hydra docstring.
@@ -377,9 +410,9 @@ CMD is a callable expression: either an interactive function
name, or an interactive lambda, or a single sexp (it will be
wrapped in an interactive lambda).
-HINT is a short string that identifies its head. It will be
+HINT is a short string that identifies its head. It will be
printed beside KEY in the echo erea if `hydra-is-helpful' is not
-nil. If you don't even want the KEY to be printed, set HINT
+nil. If you don't even want the KEY to be printed, set HINT
explicitly to nil.
The heads inherit their PLIST from the body and are allowed to
@@ -396,8 +429,8 @@ except a blue head can stop the Hydra state.
- a lambda taking KEY and CMD used to bind a head
It is possible to omit both BODY-MAP and BODY-KEY if you don't
-want to bind anything. In that case, typically you will bind the
-generated NAME/body command. This command is also the return
+want to bind anything. In that case, typically you will bind the
+generated NAME/body command. This command is also the return
result of `defhydra'."
(declare (indent defun))
(unless (stringp docstring)
@@ -443,22 +476,29 @@ result of `defhydra'."
(when (cl-some `(lambda (h)
(eq (hydra--color h ',body-color) 'red))
heads)
- (warn "%S body color: upgrading all red heads to %S" body-color
body-color))
+ (warn
+ "%S body color: upgrading all red heads to %S"
+ body-color body-color))
(define-key keymap [t]
`(lambda ()
(interactive)
- ,@(if (eq body-color 'amaranth)
- '((message "An amaranth Hydra can only exit through a
blue head"))
- '((let ((kb (key-binding (this-command-keys))))
- (if kb
- (call-interactively kb)
- (message "A pink Hydra can only exit through a
blue head")))))
+ ,@(if
+ (eq body-color 'amaranth)
+ '((message "An amaranth Hydra can only exit through a blue
head"))
+ '((let ((kb (key-binding (this-command-keys))))
+ (if kb
+ (if (commandp kb)
+ (call-interactively kb)
+ (error "Pink Hydra can't currently handle
prefixes, aboring"))
+ (message "A pink Hydra can only exit through a blue
head")))))
(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))
+ (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 ()
@@ -470,7 +510,8 @@ result of `defhydra'."
,@(cl-mapcar
(lambda (head name)
(hydra--make-defun
- name (hydra--make-callable (cadr head)) (hydra--color head
body-color)
+ name (hydra--make-callable
+ (cadr head)) (hydra--color head body-color)
(format "%s\n\nCall the head: `%S'." doc (cadr head))
hint-name keymap
body-color body-pre body-post))
@@ -485,9 +526,10 @@ result of `defhydra'."
(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)))))
+ (final-key
+ (if body-key
+ (vconcat (kbd body-key) (kbd (car head)))
+ (kbd (car head)))))
(cond ((null bind) nil)
((eq bind 'default)
@@ -508,13 +550,13 @@ result of `defhydra'."
(error "Invalid :bind property %S" head))))))
heads names))
(defun ,hint-name ()
- (hydra--message ,hint))
+ ,(hydra--message hint name heads body-color))
,(hydra--make-defun body-name nil nil doc hint-name keymap
body-color body-pre body-post
'(setq prefix-arg current-prefix-arg)))))
(defmacro defhydradio (name body &rest heads)
- "Create toggles with prefix NAME.
+ "Create radios with prefix NAME.
BODY specifies the options; there are none currently.
HEADS have the format:
@@ -522,7 +564,7 @@ HEADS have the format:
TOGGLE-NAME will be used along with NAME to generate a variable
name and a function that cycles it with the same name. VALUE
-should be an array. The first element of VALUE will be used to
+should be an array. The first element of VALUE will be used to
inialize the variable.
VALUE defaults to [nil t].
DOC defaults to TOGGLE-NAME split and capitalized."
@@ -534,7 +576,7 @@ DOC defaults to TOGGLE-NAME split and capitalized."
heads))))
(defun hydra--radio (parent head)
- "Generate a hydradio from 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]))
