branch: master commit 3222b0c8df41ad1f04b041814c16b2906683c16a Merge: ffa5405 e342c33 Author: Oleh Krehel <ohwoeo...@gmail.com> Commit: Oleh Krehel <ohwoeo...@gmail.com>
Merge commit 'e342c330807fdd09adba974611122d1c95bdf07d' from hydra --- packages/hydra/Makefile | 2 +- packages/hydra/README.md | 41 ++ packages/hydra/hydra-examples.el | 122 +++-- packages/hydra/hydra-ox.el | 118 +++++ packages/hydra/hydra-test.el | 1082 ++++++++++++++++++++++++++++---------- packages/hydra/hydra.el | 899 +++++++++++++++++++++++++------- packages/hydra/lv.el | 75 +++ 7 files changed, 1827 insertions(+), 512 deletions(-) diff --git a/packages/hydra/Makefile b/packages/hydra/Makefile index b2d473d..4b6451f 100644 --- a/packages/hydra/Makefile +++ b/packages/hydra/Makefile @@ -1,7 +1,7 @@ EMACS = emacs # EMACS = emacs-24.3 -LOAD = -l hydra.el -l hydra-test.el +LOAD = -l lv.el -l hydra.el -l hydra-test.el .PHONY: all test clean diff --git a/packages/hydra/README.md b/packages/hydra/README.md index c7c1dff..70b31bf 100644 --- a/packages/hydra/README.md +++ b/packages/hydra/README.md @@ -50,6 +50,9 @@ that disables itself auto-magically. ("l" hydra-move-splitter-right)) ``` +### Community wiki +A few useful hydras are aggregated in projects [community wiki](https://github.com/abo-abo/hydra/wiki/Hydras%20by%20Topic). Feel free to add your own or edit existing ones. + ## Using the functions generated by `defhydra` With the example above, you can e.g.: @@ -266,3 +269,41 @@ to a head. This sexp will be wrapped in an interactive lambda. Here's an example ("q" nil "cancel")) (global-set-key (kbd "C-c r") 'hydra-launcher/body) ``` + +## Define Hydra heads that don't show up in the hint at all + +This can be done by setting the head's hint explicitly to `nil`, instead of the usual string. + +## Use a dedicated window for Hydra hints + +Since version `0.10.0`, setting `hydra-lv` to `t` (the default setting) will make it use a dedicated +window right above the Echo Area for hints. This has the advantage that you can immediately see +any `message` output from the functions that you call, since Hydra no longer uses `message` to display +the hint. You can still have the old behavior by setting `hydra-lv` to `nil`. + +## Color table + + + | Body Color | Head Inherited | Executing NON-HEADS | Executing HEADS | + |------------+----------------+-----------------------+-----------------| + | amaranth | red | Disallow and Continue | Continue | + | teal | blue | Disallow and Continue | Quit | + | pink | red | Allow and Continue | Continue | + | red | red | Allow and Quit | Continue | + | blue | blue | Allow and Quit | Quit | + +## Color to toggle correspondence + +By popular demand, an alternative syntax has been implemented that translates to colors without +using them in the syntax. `:exit` can be used both in body (heads will inherit) and in heads +(possible to override body). `:exit` is nil by default, corresponding to `red` head; you don't need +to set it explicitly to nil. `:foreign-keys` can be used only in body and can be either nil (default), +`warn` or `run`. + + | color | toggle | + |----------+----------------------------| + | red | | + | blue | :exit t | + | amaranth | :foreign-keys warn | + | teal | :foreign-keys warn :exit t | + | pink | :foreign-keys run | diff --git a/packages/hydra/hydra-examples.el b/packages/hydra/hydra-examples.el index 5167c50..50773b0 100644 --- a/packages/hydra/hydra-examples.el +++ b/packages/hydra/hydra-examples.el @@ -160,6 +160,80 @@ ;; This example will bind "C-x `" in `global-map', but it will not ;; bind "C-x j" and "C-x k". ;; You can still "C-x `jjk" though. +;;** Example 7: toggle with Ruby-style docstring +(when (bound-and-true-p hydra-examples-verbatim) + (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 "quit")) + (global-set-key (kbd "C-c C-v") 'hydra-toggle/body)) + +;; Here, using e.g. "_a_" translates to "a" with proper face. +;; More interestingly: +;; +;; "foobar %`abbrev-mode" means roughly (format "foobar %S" abbrev-mode) +;; +;; This means that you actually see the state of the mode that you're changing. +;;** Example 8: the whole menu for `Buffer-menu-mode' +(defhydra hydra-buffer-menu (:color pink) + " + Mark Unmark Actions Search +------------------------------------------------------------------------- (__) +_m_: mark _u_: unmark _x_: execute _R_: re-isearch (oo) +_s_: save _U_: unmark up _b_: bury _I_: isearch /------\\/ +_d_: delete _g_: refresh _O_: multi-occur / | || +_D_: delete up _T_: files only: % -28`Buffer-menu-files-only * /\\---/\\ +_~_: modified ~~ ~~ +" + ("m" Buffer-menu-mark nil) + ("u" Buffer-menu-unmark nil) + ("U" Buffer-menu-backup-unmark nil) + ("d" Buffer-menu-delete nil) + ("D" Buffer-menu-delete-backwards nil) + ("s" Buffer-menu-save nil) + ("~" Buffer-menu-not-modified nil) + ("x" Buffer-menu-execute nil) + ("b" Buffer-menu-bury nil) + ("g" revert-buffer nil) + ("T" Buffer-menu-toggle-files-only nil) + ("O" Buffer-menu-multi-occur nil :color blue) + ("I" Buffer-menu-isearch-buffers nil :color blue) + ("R" Buffer-menu-isearch-buffers-regexp nil :color blue) + ("c" nil "cancel") + ("v" Buffer-menu-select "select" :color blue) + ("o" Buffer-menu-other-window "other-window" :color blue) + ("q" quit-window "quit" :color blue)) +;; Recommended binding: +;; (define-key Buffer-menu-mode-map "." 'hydra-buffer-menu/body) +;;** Example 9: s-expressions in the docstring +;; You can inline s-expresssions into the docstring like this: +(when (bound-and-true-p hydra-examples-verbatim) + (eval-after-load 'dired + (defhydra hydra-marked-items (dired-mode-map "") + " +Number of marked items: %(length (dired-get-marked-files)) +" + ("m" dired-mark "mark")))) + +;; This results in the following dynamic docstring: +;; +;; (format "Number of marked items: %S\n" +;; (length (dired-get-marked-files))) +;; +;; You can use `format'-style width specs, e.g. % 10(length nil). ;;* Windmove helpers (require 'windmove) @@ -196,53 +270,5 @@ (shrink-window arg) (enlarge-window arg))) -;;* Obsoletes -(defvar hydra-example-text-scale - '(("g" text-scale-increase "zoom in") - ("l" text-scale-decrease "zoom out")) - "A two-headed hydra for text scale manipulation.") -(make-obsolete-variable - 'hydra-example-text-scale - "Don't use `hydra-example-text-scale', just write your own -`defhydra' using hydra-examples.el as a template" - "0.9.0") - -(defvar hydra-example-move-window-splitter - '(("h" hydra-move-splitter-left) - ("j" hydra-move-splitter-down) - ("k" hydra-move-splitter-up) - ("l" hydra-move-splitter-right)) - "A four-headed hydra for the window splitter manipulation. -Works best if you have not more than 4 windows.") -(make-obsolete-variable - 'hydra-example-move-window-splitter - "Don't use `hydra-example-move-window-splitter', just write your own -`defhydra' using hydra-examples.el as a template" - "0.9.0") - -(defvar hydra-example-goto-error - '(("h" first-error "first") - ("j" next-error "next") - ("k" previous-error "prev")) - "A three-headed hydra for jumping between \"errors\". -Useful for e.g. `occur', `rgrep' and the like.") -(make-obsolete-variable - 'hydra-example-goto-error - "Don't use `hydra-example-goto-error', just write your own -`defhydra' using hydra-examples.el as a template" - "0.9.0") - -(defvar hydra-example-windmove - '(("h" windmove-left) - ("j" windmove-down) - ("k" windmove-up) - ("l" windmove-right)) - "A four-headed hydra for `windmove'.") -(make-obsolete-variable - 'hydra-example-windmove - "Don't use `hydra-example-windmove', just write your own -`defhydra' using hydra-examples.el as a template" - "0.9.0") - (provide 'hydra-examples) ;;; hydra-examples.el ends here diff --git a/packages/hydra/hydra-ox.el b/packages/hydra/hydra-ox.el new file mode 100644 index 0000000..4053081 --- /dev/null +++ b/packages/hydra/hydra-ox.el @@ -0,0 +1,118 @@ +;;; hydra-ox.el --- Org mode export widget implemented in Hydra + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Oleh Krehel + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This shows how a complex dispatch menu can be built with Hydra. + +;;; Code: +(require 'org) + +(defhydradio hydra-ox () + (body-only) + (export-scope [buffer subtree]) + (async-export) + (visible-only) + (force-publishing)) + +(defhydra hydra-ox-html (:color blue) + "ox-html" + ("H" (org-html-export-as-html + hydra-ox/async-export + (eq hydra-ox/export-scope 'subtree) + hydra-ox/visible-only + hydra-ox/body-only) + "As HTML buffer") + ("h" (org-html-export-to-html + hydra-ox/async-export + (eq hydra-ox/export-scope 'subtree) + hydra-ox/visible-only + hydra-ox/body-only) "As HTML file") + ("o" (org-open-file + (org-html-export-to-html + hydra-ox/async-export + (eq hydra-ox/export-scope 'subtree) + hydra-ox/visible-only + hydra-ox/body-only)) "As HTML file and open") + ("b" hydra-ox/body "back") + ("q" nil "quit")) + +(defhydra hydra-ox-latex (:color blue) + "ox-latex" + ("L" org-latex-export-as-latex "As LaTeX buffer") + ("l" org-latex-export-to-latex "As LaTeX file") + ("p" org-latex-export-to-pdf "As PDF file") + ("o" (org-open-file (org-latex-export-to-pdf)) "As PDF file and open") + ("b" hydra-ox/body "back") + ("q" nil "quit")) + +(defhydra hydra-ox-text (:color blue) + "ox-text" + ("A" (org-ascii-export-as-ascii + nil nil nil nil + '(:ascii-charset ascii)) + "As ASCII buffer") + + ("a" (org-ascii-export-to-ascii + nil nil nil nil + '(:ascii-charset ascii)) + "As ASCII file") + ("L" (org-ascii-export-as-ascii + nil nil nil nil + '(:ascii-charset latin1)) + "As Latin1 buffer") + ("l" (org-ascii-export-to-ascii + nil nil nil nil + '(:ascii-charset latin1)) + "As Latin1 file") + ("U" (org-ascii-export-as-ascii + nil nil nil nil + '(:ascii-charset utf-8)) + "As UTF-8 buffer") + ("u" (org-ascii-export-to-ascii + nil nil nil nil + '(:ascii-charset utf-8)) + "As UTF-8 file") + ("b" hydra-ox/body "back") + ("q" nil "quit")) + +(defhydra hydra-ox () + " +_C-b_ Body only: % -15`hydra-ox/body-only^^^ _C-v_ Visible only: %`hydra-ox/visible-only +_C-s_ Export scope: % -15`hydra-ox/export-scope _C-f_ Force publishing: %`hydra-ox/force-publishing +_C-a_ Async export: %`hydra-ox/async-export + +" + ("C-b" (hydra-ox/body-only) nil) + ("C-v" (hydra-ox/visible-only) nil) + ("C-s" (hydra-ox/export-scope) nil) + ("C-f" (hydra-ox/force-publishing) nil) + ("C-a" (hydra-ox/async-export) nil) + ("h" hydra-ox-html/body "Export to HTML" :exit t) + ("l" hydra-ox-latex/body "Export to LaTeX" :exit t) + ("t" hydra-ox-text/body "Export to Plain Text" :exit t) + ("q" nil "quit")) + +(define-key org-mode-map (kbd "C-c C-,") 'hydra-ox/body) + +(provide 'hydra-ox) + +;;; hydra-ox.el ends here diff --git a/packages/hydra/hydra-test.el b/packages/hydra/hydra-test.el index f2311ab..754984d 100644 --- a/packages/hydra/hydra-test.el +++ b/packages/hydra/hydra-test.el @@ -34,13 +34,15 @@ "error" ("h" first-error "first") ("j" next-error "next") - ("k" previous-error "prev"))) + ("k" previous-error "prev") + ("SPC" hydra-repeat "rep" :bind nil))) '(progn (defun hydra-error/first-error nil "Create a hydra with a \"M-g\" body and the heads: \"h\": `first-error', \"j\": `next-error', -\"k\": `previous-error' +\"k\": `previous-error', +\"SPC\": `hydra-repeat' The body can be accessed via `hydra-error/body'. @@ -49,17 +51,17 @@ Call the head: `first-error'." (hydra-disable) (catch (quote hydra-disable) (condition-case err (prog1 t (call-interactively (function first-error))) - ((debug error) + ((quit error) (message "%S" err) - (sit-for 0.8) + (unless hydra-lv (sit-for 0.8)) nil)) - (when hydra-is-helpful (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)))) + (when hydra-is-helpful (hydra-error/hint)) (setq hydra-last (hydra-set-transient-map (setq hydra-curr-map - (quote (keymap (107 . hydra-error/previous-error) + (quote (keymap (7 . hydra-keyboard-quit) + (32 . hydra-repeat) + (107 . hydra-error/previous-error) (106 . hydra-error/next-error) (104 . hydra-error/first-error) (kp-subtract . hydra--negative-argument) @@ -85,12 +87,13 @@ Call the head: `first-error'." (48 . hydra--digit-argument) (45 . hydra--negative-argument) (21 . hydra--universal-argument)))) - t)))) + t (lambda nil (hydra-cleanup)))))) (defun hydra-error/next-error nil "Create a hydra with a \"M-g\" body and the heads: \"h\": `first-error', \"j\": `next-error', -\"k\": `previous-error' +\"k\": `previous-error', +\"SPC\": `hydra-repeat' The body can be accessed via `hydra-error/body'. @@ -99,17 +102,17 @@ Call the head: `next-error'." (hydra-disable) (catch (quote hydra-disable) (condition-case err (prog1 t (call-interactively (function next-error))) - ((debug error) + ((quit error) (message "%S" err) - (sit-for 0.8) + (unless hydra-lv (sit-for 0.8)) nil)) - (when hydra-is-helpful (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)))) + (when hydra-is-helpful (hydra-error/hint)) (setq hydra-last (hydra-set-transient-map (setq hydra-curr-map - (quote (keymap (107 . hydra-error/previous-error) + (quote (keymap (7 . hydra-keyboard-quit) + (32 . hydra-repeat) + (107 . hydra-error/previous-error) (106 . hydra-error/next-error) (104 . hydra-error/first-error) (kp-subtract . hydra--negative-argument) @@ -135,12 +138,13 @@ Call the head: `next-error'." (48 . hydra--digit-argument) (45 . hydra--negative-argument) (21 . hydra--universal-argument)))) - t)))) + t (lambda nil (hydra-cleanup)))))) (defun hydra-error/previous-error nil "Create a hydra with a \"M-g\" body and the heads: \"h\": `first-error', \"j\": `next-error', -\"k\": `previous-error' +\"k\": `previous-error', +\"SPC\": `hydra-repeat' The body can be accessed via `hydra-error/body'. @@ -149,17 +153,17 @@ Call the head: `previous-error'." (hydra-disable) (catch (quote hydra-disable) (condition-case err (prog1 t (call-interactively (function previous-error))) - ((debug error) + ((quit error) (message "%S" err) - (sit-for 0.8) + (unless hydra-lv (sit-for 0.8)) nil)) - (when hydra-is-helpful (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)))) + (when hydra-is-helpful (hydra-error/hint)) (setq hydra-last (hydra-set-transient-map (setq hydra-curr-map - (quote (keymap (107 . hydra-error/previous-error) + (quote (keymap (7 . hydra-keyboard-quit) + (32 . hydra-repeat) + (107 . hydra-error/previous-error) (106 . hydra-error/next-error) (104 . hydra-error/first-error) (kp-subtract . hydra--negative-argument) @@ -185,149 +189,654 @@ Call the head: `previous-error'." (48 . hydra--digit-argument) (45 . hydra--negative-argument) (21 . hydra--universal-argument)))) - t)))) + t (lambda nil (hydra-cleanup)))))) (unless (keymapp (lookup-key global-map (kbd "M-g"))) (define-key global-map (kbd "M-g") nil)) (define-key global-map [134217831 104] - (function hydra-error/first-error)) + (function hydra-error/first-error)) (define-key global-map [134217831 106] - (function hydra-error/next-error)) + (function hydra-error/next-error)) (define-key global-map [134217831 107] - (function hydra-error/previous-error)) + (function hydra-error/previous-error)) + (defun hydra-error/hint nil + (if hydra-lv (lv-message (format #("error: [h]: first, [j]: next, [k]: prev, [SPC]: rep." 8 9 (face hydra-face-red) + 20 21 (face hydra-face-red) + 31 32 (face hydra-face-red) + 42 45 (face hydra-face-red)))) + (message (format #("error: [h]: first, [j]: next, [k]: prev, [SPC]: rep." 8 9 (face hydra-face-red) + 20 21 (face hydra-face-red) + 31 32 (face hydra-face-red) + 42 45 (face hydra-face-red)))))) (defun hydra-error/body nil "Create a hydra with a \"M-g\" body and the heads: \"h\": `first-error', \"j\": `next-error', -\"k\": `previous-error' +\"k\": `previous-error', +\"SPC\": `hydra-repeat' The body can be accessed via `hydra-error/body'." (interactive) (hydra-disable) (catch (quote hydra-disable) - (when hydra-is-helpful (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)))) + (when hydra-is-helpful (hydra-error/hint)) (setq hydra-last (hydra-set-transient-map (setq hydra-curr-map - (quote (keymap (107 . hydra-error/previous-error) - (106 . hydra-error/next-error) - (104 . hydra-error/first-error) - (kp-subtract . hydra--negative-argument) - (kp-9 . hydra--digit-argument) - (kp-8 . hydra--digit-argument) - (kp-7 . hydra--digit-argument) - (kp-6 . hydra--digit-argument) - (kp-5 . hydra--digit-argument) - (kp-4 . hydra--digit-argument) - (kp-3 . hydra--digit-argument) - (kp-2 . hydra--digit-argument) - (kp-1 . hydra--digit-argument) - (kp-0 . hydra--digit-argument) - (57 . hydra--digit-argument) - (56 . hydra--digit-argument) - (55 . hydra--digit-argument) - (54 . hydra--digit-argument) - (53 . hydra--digit-argument) - (52 . hydra--digit-argument) - (51 . hydra--digit-argument) - (50 . hydra--digit-argument) - (49 . hydra--digit-argument) - (48 . hydra--digit-argument) - (45 . hydra--negative-argument) - (21 . hydra--universal-argument)))) - t)) + (quote + (keymap (7 . hydra-keyboard-quit) + (32 . hydra-repeat) + (107 . hydra-error/previous-error) + (106 . hydra-error/next-error) + (104 . hydra-error/first-error) + (kp-subtract . hydra--negative-argument) + (kp-9 . hydra--digit-argument) + (kp-8 . hydra--digit-argument) + (kp-7 . hydra--digit-argument) + (kp-6 . hydra--digit-argument) + (kp-5 . hydra--digit-argument) + (kp-4 . hydra--digit-argument) + (kp-3 . hydra--digit-argument) + (kp-2 . hydra--digit-argument) + (kp-1 . hydra--digit-argument) + (kp-0 . hydra--digit-argument) + (57 . hydra--digit-argument) + (56 . hydra--digit-argument) + (55 . hydra--digit-argument) + (54 . hydra--digit-argument) + (53 . hydra--digit-argument) + (52 . hydra--digit-argument) + (51 . hydra--digit-argument) + (50 . hydra--digit-argument) + (49 . hydra--digit-argument) + (48 . hydra--digit-argument) + (45 . hydra--negative-argument) + (21 . hydra--universal-argument)))) + t (lambda nil (hydra-cleanup)))) (setq prefix-arg current-prefix-arg))))))) (ert-deftest hydra-blue-toggle () (should (equal (macroexpand - '(defhydra toggle (:color blue) + '(defhydra hydra-toggle (:color blue) "toggle" ("t" toggle-truncate-lines "truncate") ("f" auto-fill-mode "fill") ("a" abbrev-mode "abbrev") ("q" nil "cancel"))) '(progn - (defun toggle/toggle-truncate-lines nil "Create a hydra with no body and the heads: + (defun hydra-toggle/toggle-truncate-lines nil "Create a hydra with no body and the heads: \"t\": `toggle-truncate-lines', \"f\": `auto-fill-mode', \"a\": `abbrev-mode', \"q\": `nil' -The body can be accessed via `toggle/body'. +The body can be accessed via `hydra-toggle/body'. Call the head: `toggle-truncate-lines'." (interactive) (hydra-disable) + (hydra-cleanup) (catch (quote hydra-disable) (call-interactively (function toggle-truncate-lines)))) - (defun toggle/auto-fill-mode nil "Create a hydra with no body and the heads: + (defun hydra-toggle/auto-fill-mode nil "Create a hydra with no body and the heads: \"t\": `toggle-truncate-lines', \"f\": `auto-fill-mode', \"a\": `abbrev-mode', \"q\": `nil' -The body can be accessed via `toggle/body'. +The body can be accessed via `hydra-toggle/body'. Call the head: `auto-fill-mode'." (interactive) (hydra-disable) + (hydra-cleanup) (catch (quote hydra-disable) (call-interactively (function auto-fill-mode)))) - (defun toggle/abbrev-mode nil "Create a hydra with no body and the heads: + (defun hydra-toggle/abbrev-mode nil "Create a hydra with no body and the heads: \"t\": `toggle-truncate-lines', \"f\": `auto-fill-mode', \"a\": `abbrev-mode', \"q\": `nil' -The body can be accessed via `toggle/body'. +The body can be accessed via `hydra-toggle/body'. Call the head: `abbrev-mode'." (interactive) (hydra-disable) + (hydra-cleanup) (catch (quote hydra-disable) (call-interactively (function abbrev-mode)))) - (defun toggle/nil nil "Create a hydra with no body and the heads: + (defun hydra-toggle/nil nil "Create a hydra with no body and the heads: \"t\": `toggle-truncate-lines', \"f\": `auto-fill-mode', \"a\": `abbrev-mode', \"q\": `nil' -The body can be accessed via `toggle/body'. +The body can be accessed via `hydra-toggle/body'. Call the head: `nil'." (interactive) (hydra-disable) + (hydra-cleanup) (catch (quote hydra-disable))) - (defun toggle/body nil "Create a hydra with no body and the heads: + (defun hydra-toggle/hint nil + (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', \"f\": `auto-fill-mode', \"a\": `abbrev-mode', \"q\": `nil' -The body can be accessed via `toggle/body'." +The body can be accessed via `hydra-toggle/body'." + (interactive) + (hydra-disable) + (catch (quote hydra-disable) + (when hydra-is-helpful (hydra-toggle/hint)) + (setq hydra-last + (hydra-set-transient-map + (setq hydra-curr-map + (quote + (keymap (7 . hydra-keyboard-quit) + (113 . hydra-toggle/nil) + (97 . hydra-toggle/abbrev-mode) + (102 . hydra-toggle/auto-fill-mode) + (116 . hydra-toggle/toggle-truncate-lines) + (kp-subtract . hydra--negative-argument) + (kp-9 . hydra--digit-argument) + (kp-8 . hydra--digit-argument) + (kp-7 . hydra--digit-argument) + (kp-6 . hydra--digit-argument) + (kp-5 . hydra--digit-argument) + (kp-4 . hydra--digit-argument) + (kp-3 . hydra--digit-argument) + (kp-2 . hydra--digit-argument) + (kp-1 . hydra--digit-argument) + (kp-0 . hydra--digit-argument) + (57 . hydra--digit-argument) + (56 . hydra--digit-argument) + (55 . hydra--digit-argument) + (54 . hydra--digit-argument) + (53 . hydra--digit-argument) + (52 . hydra--digit-argument) + (51 . hydra--digit-argument) + (50 . hydra--digit-argument) + (49 . hydra--digit-argument) + (48 . hydra--digit-argument) + (45 . hydra--negative-argument) + (21 . hydra--universal-argument)))) + t (lambda nil (hydra-cleanup)))) + (setq prefix-arg current-prefix-arg))))))) + +(ert-deftest hydra-amaranth-vi () + (should + (equal + (macroexpand + '(defhydra hydra-vi + (:pre + (set-cursor-color "#e52b50") + :post + (set-cursor-color "#ffffff") + :color amaranth) + "vi" + ("j" next-line) + ("k" previous-line) + ("q" nil "quit"))) + '(progn + (defun hydra-vi/next-line nil "Create a hydra with no body and the heads: + +\"j\": `next-line', +\"k\": `previous-line', +\"q\": `nil' + +The body can be accessed via `hydra-vi/body'. + +Call the head: `next-line'." + (interactive) + (set-cursor-color "#e52b50") + (hydra-disable) + (catch (quote hydra-disable) + (condition-case err (prog1 t (call-interactively (function next-line))) + ((quit error) (message "%S" err) + (unless hydra-lv (sit-for 0.8)) + nil)) + (when hydra-is-helpful (hydra-vi/hint)) + (setq hydra-last + (hydra-set-transient-map + (setq hydra-curr-map + (quote + (keymap (t lambda nil (interactive) + (message "An amaranth 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)) + (hydra-vi/hint))) + (7 . hydra-keyboard-quit) + (113 . hydra-vi/nil) + (107 . hydra-vi/previous-line) + (106 . hydra-vi/next-line) + (kp-subtract . hydra--negative-argument) + (kp-9 . hydra--digit-argument) + (kp-8 . hydra--digit-argument) + (kp-7 . hydra--digit-argument) + (kp-6 . hydra--digit-argument) + (kp-5 . hydra--digit-argument) + (kp-4 . hydra--digit-argument) + (kp-3 . hydra--digit-argument) + (kp-2 . hydra--digit-argument) + (kp-1 . hydra--digit-argument) + (kp-0 . hydra--digit-argument) + (57 . hydra--digit-argument) + (56 . hydra--digit-argument) + (55 . hydra--digit-argument) + (54 . hydra--digit-argument) + (53 . hydra--digit-argument) + (52 . hydra--digit-argument) + (51 . hydra--digit-argument) + (50 . hydra--digit-argument) + (49 . hydra--digit-argument) + (48 . hydra--digit-argument) + (45 . hydra--negative-argument) + (21 . hydra--universal-argument)))) + t (lambda nil (hydra-cleanup)))))) + (defun hydra-vi/previous-line nil "Create a hydra with no body and the heads: + +\"j\": `next-line', +\"k\": `previous-line', +\"q\": `nil' + +The body can be accessed via `hydra-vi/body'. + +Call the head: `previous-line'." + (interactive) + (set-cursor-color "#e52b50") + (hydra-disable) + (catch (quote hydra-disable) + (condition-case err (prog1 t (call-interactively (function previous-line))) + ((quit error) (message "%S" err) + (unless hydra-lv (sit-for 0.8)) + nil)) + (when hydra-is-helpful (hydra-vi/hint)) + (setq hydra-last + (hydra-set-transient-map + (setq hydra-curr-map + (quote + (keymap (t lambda nil (interactive) + (message "An amaranth 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)) + (hydra-vi/hint))) + (7 . hydra-keyboard-quit) + (113 . hydra-vi/nil) + (107 . hydra-vi/previous-line) + (106 . hydra-vi/next-line) + (kp-subtract . hydra--negative-argument) + (kp-9 . hydra--digit-argument) + (kp-8 . hydra--digit-argument) + (kp-7 . hydra--digit-argument) + (kp-6 . hydra--digit-argument) + (kp-5 . hydra--digit-argument) + (kp-4 . hydra--digit-argument) + (kp-3 . hydra--digit-argument) + (kp-2 . hydra--digit-argument) + (kp-1 . hydra--digit-argument) + (kp-0 . hydra--digit-argument) + (57 . hydra--digit-argument) + (56 . hydra--digit-argument) + (55 . hydra--digit-argument) + (54 . hydra--digit-argument) + (53 . hydra--digit-argument) + (52 . hydra--digit-argument) + (51 . hydra--digit-argument) + (50 . hydra--digit-argument) + (49 . hydra--digit-argument) + (48 . hydra--digit-argument) + (45 . hydra--negative-argument) + (21 . hydra--universal-argument)))) + t (lambda nil (hydra-cleanup)))))) + (defun hydra-vi/nil nil "Create a hydra with no body and the heads: + +\"j\": `next-line', +\"k\": `previous-line', +\"q\": `nil' + +The body can be accessed via `hydra-vi/body'. + +Call the head: `nil'." + (interactive) + (set-cursor-color "#e52b50") + (hydra-disable) + (hydra-cleanup) + (catch (quote hydra-disable) + (set-cursor-color "#ffffff"))) + (defun hydra-vi/hint nil + (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', +\"k\": `previous-line', +\"q\": `nil' + +The body can be accessed via `hydra-vi/body'." + (interactive) + (set-cursor-color "#e52b50") + (hydra-disable) + (catch (quote hydra-disable) + (when hydra-is-helpful (hydra-vi/hint)) + (setq hydra-last + (hydra-set-transient-map + (setq hydra-curr-map + (quote + (keymap (t lambda nil (interactive) + (message "An amaranth 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)) + (hydra-vi/hint))) + (7 . hydra-keyboard-quit) + (113 . hydra-vi/nil) + (107 . hydra-vi/previous-line) + (106 . hydra-vi/next-line) + (kp-subtract . hydra--negative-argument) + (kp-9 . hydra--digit-argument) + (kp-8 . hydra--digit-argument) + (kp-7 . hydra--digit-argument) + (kp-6 . hydra--digit-argument) + (kp-5 . hydra--digit-argument) + (kp-4 . hydra--digit-argument) + (kp-3 . hydra--digit-argument) + (kp-2 . hydra--digit-argument) + (kp-1 . hydra--digit-argument) + (kp-0 . hydra--digit-argument) + (57 . hydra--digit-argument) + (56 . hydra--digit-argument) + (55 . hydra--digit-argument) + (54 . hydra--digit-argument) + (53 . hydra--digit-argument) + (52 . hydra--digit-argument) + (51 . hydra--digit-argument) + (50 . hydra--digit-argument) + (49 . hydra--digit-argument) + (48 . hydra--digit-argument) + (45 . hydra--negative-argument) + (21 . hydra--universal-argument)))) + t (lambda nil (hydra-cleanup)))) + (setq prefix-arg current-prefix-arg))))))) + +(ert-deftest defhydradio () + (should (equal + (macroexpand + '(defhydradio hydra-test () + (num "Num" [0 1 2 3 4 5 6 7 8 9 10]) + (str "Str" ["foo" "bar" "baz"]))) + '(progn + (defvar hydra-test/num 0 + "Num") + (put 'hydra-test/num 'range [0 1 2 3 4 5 6 7 8 9 10]) + (defun hydra-test/num () + (hydra--cycle-radio 'hydra-test/num)) + (defvar hydra-test/str "foo" + "Str") + (put 'hydra-test/str 'range ["foo" "bar" "baz"]) + (defun hydra-test/str () + (hydra--cycle-radio 'hydra-test/str)) + (defvar hydra-test/names '(hydra-test/num hydra-test/str)))))) + +(ert-deftest hydra-blue-compat () + (should + (equal + (macroexpand + '(defhydra hydra-toggle (:color blue) + "toggle" + ("t" toggle-truncate-lines "truncate") + ("f" auto-fill-mode "fill") + ("a" abbrev-mode "abbrev") + ("q" nil "cancel"))) + (macroexpand + '(defhydra hydra-toggle (:exit t) + "toggle" + ("t" toggle-truncate-lines "truncate") + ("f" auto-fill-mode "fill") + ("a" abbrev-mode "abbrev") + ("q" nil "cancel")))))) + +(ert-deftest hydra-amaranth-compat () + (should + (equal + (macroexpand + '(defhydra hydra-vi + (:pre + (set-cursor-color "#e52b50") + :post + (set-cursor-color "#ffffff") + :color amaranth) + "vi" + ("j" next-line) + ("k" previous-line) + ("q" nil "quit"))) + (macroexpand + '(defhydra hydra-vi + (:pre + (set-cursor-color "#e52b50") + :post + (set-cursor-color "#ffffff") + :foreign-keys warn) + "vi" + ("j" next-line) + ("k" previous-line) + ("q" nil "quit")))))) + +(ert-deftest hydra-pink-compat () + (should + (equal + (macroexpand + '(defhydra hydra-zoom (global-map "<f2>" + :color pink) + "zoom" + ("g" text-scale-increase "in") + ("l" text-scale-decrease "out") + ("q" nil "quit"))) + (macroexpand + '(defhydra hydra-zoom (global-map "<f2>" + :foreign-keys run) + "zoom" + ("g" text-scale-increase "in") + ("l" text-scale-decrease "out") + ("q" nil "quit")))))) + +(ert-deftest hydra-teal-compat () + (should + (equal + (macroexpand + '(defhydra hydra-zoom (global-map "<f2>" + :color teal) + "zoom" + ("g" text-scale-increase "in") + ("l" text-scale-decrease "out") + ("q" nil "quit"))) + (macroexpand + '(defhydra hydra-zoom (global-map "<f2>" + :foreign-keys warn + :exit t) + "zoom" + ("g" text-scale-increase "in") + ("l" text-scale-decrease "out") + ("q" nil "quit")))))) + +(ert-deftest hydra-format () + (should (equal + (let ((hydra-fontify-head-function + 'hydra-fontify-head-greyscale)) + (hydra--format + 'hydra-toggle + nil + " +_a_ abbrev-mode: %`abbrev-mode +_d_ debug-on-error: %`debug-on-error +_f_ auto-fill-mode: %`auto-fill-function +" '(("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 "quit")))) + '(concat (format "%s abbrev-mode: %S +%s debug-on-error: %S +%s auto-fill-mode: %S +" "{a}" abbrev-mode "{d}" debug-on-error "{f}" auto-fill-function) "[[q]]: quit")))) + +(ert-deftest hydra-format-with-sexp () + (should (equal + (let ((hydra-fontify-head-function + 'hydra-fontify-head-greyscale)) + (hydra--format + 'hydra-toggle nil + "\n_n_ narrow-or-widen-dwim %(progn (message \"checking\")(buffer-narrowed-p))asdf\n" + '(("n" narrow-to-region nil) ("q" nil "cancel")))) + '(concat (format "%s narrow-or-widen-dwim %Sasdf\n" + "{n}" + (progn + (message "checking") + (buffer-narrowed-p))) + "[[q]]: cancel")))) + +(ert-deftest hydra-compat-colors-1 () + (should (equal (hydra--head-color + '("e" (message "Exiting now") "blue") + '(nil nil :color blue)) + 'blue)) + (should (equal (hydra--head-color + '("c" (message "Continuing") "red" :color red) + '(nil nil :color blue)) + 'red)) + (should (equal (hydra--head-color + '("e" (message "Exiting now") "blue") + '(nil nil :exit t)) + 'blue)) + (should (equal (hydra--head-color + '("c" (message "Continuing") "red" :exit nil) + '(nil nil :exit t)) + 'red)) + (equal (hydra--head-color + '("a" abbrev-mode nil) + '(nil nil :color teal)) + 'teal) + (equal (hydra--head-color + '("a" abbrev-mode :exit nil) + '(nil nil :color teal)) + 'amaranth)) + +(ert-deftest hydra-compat-colors-2 () + (should + (equal + (macroexpand + '(defhydra hydra-test (:color amaranth) + ("a" fun-a) + ("b" fun-b :color blue) + ("c" fun-c :color blue) + ("d" fun-d :color blue) + ("e" fun-e :color blue) + ("f" fun-f :color blue))) + (macroexpand + '(defhydra hydra-test (:color teal) + ("a" fun-a :color red) + ("b" fun-b) + ("c" fun-c) + ("d" fun-d) + ("e" fun-e) + ("f" fun-f)))))) + +(ert-deftest hydra-compat-colors-3 () + (should + (equal + (macroexpand + '(defhydra hydra-test () + ("a" fun-a) + ("b" fun-b :color blue) + ("c" fun-c :color blue) + ("d" fun-d :color blue) + ("e" fun-e :color blue) + ("f" fun-f :color blue))) + (macroexpand + '(defhydra hydra-test (:color blue) + ("a" fun-a :color red) + ("b" fun-b) + ("c" fun-c) + ("d" fun-d) + ("e" fun-e) + ("f" fun-f)))))) + +(ert-deftest hydra-compat-colors-4 () + (should + (equal + (macroexpand + '(defhydra hydra-test () + ("a" fun-a) + ("b" fun-b :exit t) + ("c" fun-c :exit t) + ("d" fun-d :exit t) + ("e" fun-e :exit t) + ("f" fun-f :exit t))) + (macroexpand + '(defhydra hydra-test (:exit t) + ("a" fun-a :exit nil) + ("b" fun-b) + ("c" fun-c) + ("d" fun-d) + ("e" fun-e) + ("f" fun-f)))))) + +(ert-deftest hydra-zoom-duplicate-1 () + (should + (equal + (macroexpand + '(defhydra hydra-zoom () + "zoom" + ("r" (text-scale-set 0) "reset") + ("0" (text-scale-set 0) :bind nil :exit t) + ("1" (text-scale-set 0) nil :bind nil :exit t))) + '(progn + (defun hydra-zoom/lambda-r nil "Create a hydra with no body and the heads: + +\"r\": `(text-scale-set 0)', +\"0\": `(text-scale-set 0)', +\"1\": `(text-scale-set 0)' + +The body can be accessed via `hydra-zoom/body'. + +Call the head: `(text-scale-set 0)'." (interactive) (hydra-disable) (catch (quote hydra-disable) - (when hydra-is-helpful (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)))) + (condition-case err (prog1 t (call-interactively (function (lambda nil (interactive) + (text-scale-set 0))))) + ((quit error) + (message "%S" err) + (unless hydra-lv (sit-for 0.8)) + nil)) + (when hydra-is-helpful (hydra-zoom/hint)) (setq hydra-last (hydra-set-transient-map (setq hydra-curr-map - (quote (keymap (113 . toggle/nil) - (97 . toggle/abbrev-mode) - (102 . toggle/auto-fill-mode) - (116 . toggle/toggle-truncate-lines) + (quote (keymap (7 . hydra-keyboard-quit) + (114 . hydra-zoom/lambda-r) (kp-subtract . hydra--negative-argument) (kp-9 . hydra--digit-argument) (kp-8 . hydra--digit-argument) @@ -347,220 +856,239 @@ The body can be accessed via `toggle/body'." (52 . hydra--digit-argument) (51 . hydra--digit-argument) (50 . hydra--digit-argument) - (49 . hydra--digit-argument) - (48 . hydra--digit-argument) + (49 . hydra-zoom/lambda-0) + (48 . hydra-zoom/lambda-0) (45 . hydra--negative-argument) (21 . hydra--universal-argument)))) - t)) + t (lambda nil (hydra-cleanup)))))) + (defun hydra-zoom/lambda-0 nil "Create a hydra with no body and the heads: + +\"r\": `(text-scale-set 0)', +\"0\": `(text-scale-set 0)', +\"1\": `(text-scale-set 0)' + +The body can be accessed via `hydra-zoom/body'. + +Call the head: `(text-scale-set 0)'." + (interactive) + (hydra-disable) + (hydra-cleanup) + (catch (quote hydra-disable) + (call-interactively (function (lambda nil (interactive) + (text-scale-set 0)))))) + (defun hydra-zoom/hint nil + (if hydra-lv (lv-message (format #("zoom: [r 0]: reset." 7 8 (face hydra-face-red) + 9 10 (face hydra-face-blue)))) + (message (format #("zoom: [r 0]: reset." 7 8 (face hydra-face-red) + 9 10 (face hydra-face-blue)))))) + (defun hydra-zoom/body nil "Create a hydra with no body and the heads: + +\"r\": `(text-scale-set 0)', +\"0\": `(text-scale-set 0)', +\"1\": `(text-scale-set 0)' + +The body can be accessed via `hydra-zoom/body'." + (interactive) + (hydra-disable) + (catch (quote hydra-disable) + (when hydra-is-helpful (hydra-zoom/hint)) + (setq hydra-last + (hydra-set-transient-map + (setq hydra-curr-map + (quote (keymap (7 . hydra-keyboard-quit) + (114 . hydra-zoom/lambda-r) + (kp-subtract . hydra--negative-argument) + (kp-9 . hydra--digit-argument) + (kp-8 . hydra--digit-argument) + (kp-7 . hydra--digit-argument) + (kp-6 . hydra--digit-argument) + (kp-5 . hydra--digit-argument) + (kp-4 . hydra--digit-argument) + (kp-3 . hydra--digit-argument) + (kp-2 . hydra--digit-argument) + (kp-1 . hydra--digit-argument) + (kp-0 . hydra--digit-argument) + (57 . hydra--digit-argument) + (56 . hydra--digit-argument) + (55 . hydra--digit-argument) + (54 . hydra--digit-argument) + (53 . hydra--digit-argument) + (52 . hydra--digit-argument) + (51 . hydra--digit-argument) + (50 . hydra--digit-argument) + (49 . hydra-zoom/lambda-0) + (48 . hydra-zoom/lambda-0) + (45 . hydra--negative-argument) + (21 . hydra--universal-argument)))) + t (lambda nil (hydra-cleanup)))) (setq prefix-arg current-prefix-arg))))))) -(ert-deftest hydra-amaranth-vi () - (unless (version< emacs-version "24.4") - (should - (equal - (macroexpand - '(defhydra hydra-vi - (:pre - (set-cursor-color "#e52b50") - :post - (set-cursor-color "#ffffff") - :color amaranth) - "vi" - ("j" next-line) - ("k" previous-line) - ("q" nil "quit"))) - '(progn - (defun hydra-vi/next-line nil "Create a hydra with no body and the heads: +(ert-deftest hydra-zoom-duplicate-2 () + (should + (equal + (macroexpand + '(defhydra hydra-zoom () + "zoom" + ("r" (text-scale-set 0) "reset") + ("0" (text-scale-set 0) :bind nil :exit t) + ("1" (text-scale-set 0) nil :bind nil))) + '(progn + (defun hydra-zoom/lambda-r nil "Create a hydra with no body and the heads: -\"j\": `next-line', -\"k\": `previous-line', -\"q\": `nil' +\"r\": `(text-scale-set 0)', +\"0\": `(text-scale-set 0)', +\"1\": `(text-scale-set 0)' -The body can be accessed via `hydra-vi/body'. +The body can be accessed via `hydra-zoom/body'. -Call the head: `next-line'." - (interactive) - (set-cursor-color "#e52b50") - (hydra-disable) - (catch (quote hydra-disable) - (condition-case err (prog1 t (call-interactively (function next-line))) - ((debug error) - (message "%S" err) - (sit-for 0.8) - nil)) - (when hydra-is-helpful (message #("vi: j, k, [q]: quit." 4 5 (face hydra-face-amaranth) - 7 8 (face hydra-face-amaranth) - 11 12 (face hydra-face-blue)))) - (setq hydra-last - (hydra-set-transient-map - (setq hydra-curr-map - (quote (keymap (7 lambda nil (interactive) - (hydra-disable) - (set-cursor-color "#ffffff")) - (t lambda nil (interactive) - (message "An amaranth Hydra can only exit through a blue head") - (hydra-set-transient-map hydra-curr-map t) - (when hydra-is-helpful (sit-for 0.8) - (message #("vi: j, k, [q]: quit." 4 5 (face hydra-face-amaranth) - 7 8 (face hydra-face-amaranth) - 11 12 (face hydra-face-blue))))) - (113 . hydra-vi/nil) - (107 . hydra-vi/previous-line) - (106 . hydra-vi/next-line) - (kp-subtract . hydra--negative-argument) - (kp-9 . hydra--digit-argument) - (kp-8 . hydra--digit-argument) - (kp-7 . hydra--digit-argument) - (kp-6 . hydra--digit-argument) - (kp-5 . hydra--digit-argument) - (kp-4 . hydra--digit-argument) - (kp-3 . hydra--digit-argument) - (kp-2 . hydra--digit-argument) - (kp-1 . hydra--digit-argument) - (kp-0 . hydra--digit-argument) - (57 . hydra--digit-argument) - (56 . hydra--digit-argument) - (55 . hydra--digit-argument) - (54 . hydra--digit-argument) - (53 . hydra--digit-argument) - (52 . hydra--digit-argument) - (51 . hydra--digit-argument) - (50 . hydra--digit-argument) - (49 . hydra--digit-argument) - (48 . hydra--digit-argument) - (45 . hydra--negative-argument) - (21 . hydra--universal-argument)))) - t)))) - (defun hydra-vi/previous-line nil "Create a hydra with no body and the heads: +Call the head: `(text-scale-set 0)'." + (interactive) + (hydra-disable) + (catch (quote hydra-disable) + (condition-case err (prog1 t (call-interactively (function (lambda nil (interactive) + (text-scale-set 0))))) + ((quit error) + (message "%S" err) + (unless hydra-lv (sit-for 0.8)) + nil)) + (when hydra-is-helpful (hydra-zoom/hint)) + (setq hydra-last + (hydra-set-transient-map + (setq hydra-curr-map + (quote (keymap (7 . hydra-keyboard-quit) + (114 . hydra-zoom/lambda-r) + (kp-subtract . hydra--negative-argument) + (kp-9 . hydra--digit-argument) + (kp-8 . hydra--digit-argument) + (kp-7 . hydra--digit-argument) + (kp-6 . hydra--digit-argument) + (kp-5 . hydra--digit-argument) + (kp-4 . hydra--digit-argument) + (kp-3 . hydra--digit-argument) + (kp-2 . hydra--digit-argument) + (kp-1 . hydra--digit-argument) + (kp-0 . hydra--digit-argument) + (57 . hydra--digit-argument) + (56 . hydra--digit-argument) + (55 . hydra--digit-argument) + (54 . hydra--digit-argument) + (53 . hydra--digit-argument) + (52 . hydra--digit-argument) + (51 . hydra--digit-argument) + (50 . hydra--digit-argument) + (49 . hydra-zoom/lambda-r) + (48 . hydra-zoom/lambda-0) + (45 . hydra--negative-argument) + (21 . hydra--universal-argument)))) + t (lambda nil (hydra-cleanup)))))) + (defun hydra-zoom/lambda-0 nil "Create a hydra with no body and the heads: -\"j\": `next-line', -\"k\": `previous-line', -\"q\": `nil' +\"r\": `(text-scale-set 0)', +\"0\": `(text-scale-set 0)', +\"1\": `(text-scale-set 0)' -The body can be accessed via `hydra-vi/body'. +The body can be accessed via `hydra-zoom/body'. -Call the head: `previous-line'." - (interactive) - (set-cursor-color "#e52b50") - (hydra-disable) - (catch (quote hydra-disable) - (condition-case err (prog1 t (call-interactively (function previous-line))) - ((debug error) - (message "%S" err) - (sit-for 0.8) - nil)) - (when hydra-is-helpful (message #("vi: j, k, [q]: quit." 4 5 (face hydra-face-amaranth) - 7 8 (face hydra-face-amaranth) - 11 12 (face hydra-face-blue)))) - (setq hydra-last - (hydra-set-transient-map - (setq hydra-curr-map - (quote (keymap (7 lambda nil (interactive) - (hydra-disable) - (set-cursor-color "#ffffff")) - (t lambda nil (interactive) - (message "An amaranth Hydra can only exit through a blue head") - (hydra-set-transient-map hydra-curr-map t) - (when hydra-is-helpful (sit-for 0.8) - (message #("vi: j, k, [q]: quit." 4 5 (face hydra-face-amaranth) - 7 8 (face hydra-face-amaranth) - 11 12 (face hydra-face-blue))))) - (113 . hydra-vi/nil) - (107 . hydra-vi/previous-line) - (106 . hydra-vi/next-line) - (kp-subtract . hydra--negative-argument) - (kp-9 . hydra--digit-argument) - (kp-8 . hydra--digit-argument) - (kp-7 . hydra--digit-argument) - (kp-6 . hydra--digit-argument) - (kp-5 . hydra--digit-argument) - (kp-4 . hydra--digit-argument) - (kp-3 . hydra--digit-argument) - (kp-2 . hydra--digit-argument) - (kp-1 . hydra--digit-argument) - (kp-0 . hydra--digit-argument) - (57 . hydra--digit-argument) - (56 . hydra--digit-argument) - (55 . hydra--digit-argument) - (54 . hydra--digit-argument) - (53 . hydra--digit-argument) - (52 . hydra--digit-argument) - (51 . hydra--digit-argument) - (50 . hydra--digit-argument) - (49 . hydra--digit-argument) - (48 . hydra--digit-argument) - (45 . hydra--negative-argument) - (21 . hydra--universal-argument)))) - t)))) - (defun hydra-vi/nil nil "Create a hydra with no body and the heads: +Call the head: `(text-scale-set 0)'." + (interactive) + (hydra-disable) + (hydra-cleanup) + (catch (quote hydra-disable) + (call-interactively (function (lambda nil (interactive) + (text-scale-set 0)))))) + (defun hydra-zoom/hint nil + (if hydra-lv (lv-message (format #("zoom: [r 0]: reset." 7 8 (face hydra-face-red) + 9 10 (face hydra-face-blue)))) + (message (format #("zoom: [r 0]: reset." 7 8 (face hydra-face-red) + 9 10 (face hydra-face-blue)))))) + (defun hydra-zoom/body nil "Create a hydra with no body and the heads: -\"j\": `next-line', -\"k\": `previous-line', -\"q\": `nil' +\"r\": `(text-scale-set 0)', +\"0\": `(text-scale-set 0)', +\"1\": `(text-scale-set 0)' -The body can be accessed via `hydra-vi/body'. +The body can be accessed via `hydra-zoom/body'." + (interactive) + (hydra-disable) + (catch (quote hydra-disable) + (when hydra-is-helpful (hydra-zoom/hint)) + (setq hydra-last + (hydra-set-transient-map + (setq hydra-curr-map + (quote (keymap (7 . hydra-keyboard-quit) + (114 . hydra-zoom/lambda-r) + (kp-subtract . hydra--negative-argument) + (kp-9 . hydra--digit-argument) + (kp-8 . hydra--digit-argument) + (kp-7 . hydra--digit-argument) + (kp-6 . hydra--digit-argument) + (kp-5 . hydra--digit-argument) + (kp-4 . hydra--digit-argument) + (kp-3 . hydra--digit-argument) + (kp-2 . hydra--digit-argument) + (kp-1 . hydra--digit-argument) + (kp-0 . hydra--digit-argument) + (57 . hydra--digit-argument) + (56 . hydra--digit-argument) + (55 . hydra--digit-argument) + (54 . hydra--digit-argument) + (53 . hydra--digit-argument) + (52 . hydra--digit-argument) + (51 . hydra--digit-argument) + (50 . hydra--digit-argument) + (49 . hydra-zoom/lambda-r) + (48 . hydra-zoom/lambda-0) + (45 . hydra--negative-argument) + (21 . hydra--universal-argument)))) + t (lambda nil (hydra-cleanup)))) + (setq prefix-arg current-prefix-arg))))))) -Call the head: `nil'." - (interactive) - (set-cursor-color "#e52b50") - (hydra-disable) - (catch (quote hydra-disable) - (set-cursor-color "#ffffff"))) - (defun hydra-vi/body nil "Create a hydra with no body and the heads: +(ert-deftest hydra--pad () + (should (equal (hydra--pad '(a b c) 3) + '(a b c))) + (should (equal (hydra--pad '(a) 3) + '(a nil nil)))) -\"j\": `next-line', -\"k\": `previous-line', -\"q\": `nil' +(ert-deftest hydra--matrix () + (should (equal (hydra--matrix '(a b c) 2 2) + '((a b) (c nil)))) + (should (equal (hydra--matrix '(a b c d e f g h i) 4 3) + '((a b c d) (e f g h) (i nil nil nil))))) -The body can be accessed via `hydra-vi/body'." - (interactive) - (set-cursor-color "#e52b50") - (hydra-disable) - (catch (quote hydra-disable) - (when hydra-is-helpful (message #("vi: j, k, [q]: quit." 4 5 (face hydra-face-amaranth) - 7 8 (face hydra-face-amaranth) - 11 12 (face hydra-face-blue)))) - (setq hydra-last - (hydra-set-transient-map - (setq hydra-curr-map - (quote (keymap (7 lambda nil (interactive) - (hydra-disable) - (set-cursor-color "#ffffff")) - (t lambda nil (interactive) - (message "An amaranth Hydra can only exit through a blue head") - (hydra-set-transient-map hydra-curr-map t) - (when hydra-is-helpful (sit-for 0.8) - (message #("vi: j, k, [q]: quit." 4 5 (face hydra-face-amaranth) - 7 8 (face hydra-face-amaranth) - 11 12 (face hydra-face-blue))))) - (113 . hydra-vi/nil) - (107 . hydra-vi/previous-line) - (106 . hydra-vi/next-line) - (kp-subtract . hydra--negative-argument) - (kp-9 . hydra--digit-argument) - (kp-8 . hydra--digit-argument) - (kp-7 . hydra--digit-argument) - (kp-6 . hydra--digit-argument) - (kp-5 . hydra--digit-argument) - (kp-4 . hydra--digit-argument) - (kp-3 . hydra--digit-argument) - (kp-2 . hydra--digit-argument) - (kp-1 . hydra--digit-argument) - (kp-0 . hydra--digit-argument) - (57 . hydra--digit-argument) - (56 . hydra--digit-argument) - (55 . hydra--digit-argument) - (54 . hydra--digit-argument) - (53 . hydra--digit-argument) - (52 . hydra--digit-argument) - (51 . hydra--digit-argument) - (50 . hydra--digit-argument) - (49 . hydra--digit-argument) - (48 . hydra--digit-argument) - (45 . hydra--negative-argument) - (21 . hydra--universal-argument)))) - t)) - (setq prefix-arg current-prefix-arg)))))))) +(ert-deftest hydra--cell () + (should (equal (hydra--cell "% -75s %%`%s" '(hydra-lv hydra-verbose)) + "When non-nil, `lv-message' (not `message') will be used to display hints. %`hydra-lv^^^^^ +When non-nil, hydra will issue some non essential style warnings. %`hydra-verbose"))) + +(ert-deftest hydra--vconcat () + (should (equal (hydra--vconcat '("abc\ndef" "012\n34" "def\nabc")) + "abc012def\ndef34abc"))) + +(defhydradio hydra-tng () + (picard "_p_ Captain Jean Luc Picard:") + (riker "_r_ Commander William Riker:") + (data "_d_ Lieutenant Commander Data:") + (worf "_w_ Worf:") + (la-forge "_f_ Geordi La Forge:") + (troi "_t_ Deanna Troi:") + (dr-crusher "_c_ Doctor Beverly Crusher:") + (phaser "_h_ Set phasers to " [stun kill])) + +(ert-deftest hydra--table () + (let ((hydra-cell-format "% -30s %% -8`%s")) + (should (equal (hydra--table hydra-tng/names 5 2) + (substring " +_p_ Captain Jean Luc Picard: % -8`hydra-tng/picard^^ _t_ Deanna Troi: % -8`hydra-tng/troi^^^^^^ +_r_ Commander William Riker: % -8`hydra-tng/riker^^^ _c_ Doctor Beverly Crusher: % -8`hydra-tng/dr-crusher +_d_ Lieutenant Commander Data: % -8`hydra-tng/data^^^^ _h_ Set phasers to % -8`hydra-tng/phaser^^^^ +_w_ Worf: % -8`hydra-tng/worf^^^^ +_f_ Geordi La Forge: % -8`hydra-tng/la-forge" 1))) + (should (equal (hydra--table hydra-tng/names 4 3) + (substring " +_p_ Captain Jean Luc Picard: % -8`hydra-tng/picard _f_ Geordi La Forge: % -8`hydra-tng/la-forge^^ +_r_ Commander William Riker: % -8`hydra-tng/riker^ _t_ Deanna Troi: % -8`hydra-tng/troi^^^^^^ +_d_ Lieutenant Commander Data: % -8`hydra-tng/data^^ _c_ Doctor Beverly Crusher: % -8`hydra-tng/dr-crusher +_w_ Worf: % -8`hydra-tng/worf^^ _h_ Set phasers to % -8`hydra-tng/phaser^^^^" 1))))) (provide 'hydra-test) diff --git a/packages/hydra/hydra.el b/packages/hydra/hydra.el index 2770fbc..dcdf03b 100644 --- a/packages/hydra/hydra.el +++ b/packages/hydra/hydra.el @@ -5,7 +5,7 @@ ;; Author: Oleh Krehel <ohwoeo...@gmail.com> ;; Maintainer: Oleh Krehel <ohwoeo...@gmail.com> ;; URL: https://github.com/abo-abo/hydra -;; Version: 0.9.0 +;; Version: 0.11.0 ;; Keywords: bindings ;; Package-Requires: ((cl-lib "0.5")) @@ -77,11 +77,26 @@ ;;; Code: ;;* Requires (require 'cl-lib) +(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) + (with-no-warnings + (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 @@ -99,18 +114,53 @@ 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' (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 "#7F0055" :bold t))) + '((t (:foreground "#FF0000" :bold t))) "Red Hydra heads will persist indefinitely." :group 'hydra) (defface hydra-face-blue - '((t (:foreground "#758BC6" :bold t))) + '((t (:foreground "#0000FF" :bold t))) "Blue Hydra heads will vanquish the Hydra.") (defface hydra-face-amaranth '((t (:foreground "#E52B50" :bold t))) - "Amaranth Hydra can exit only through a blue head.") + "Amaranth body has red heads and warns on intercepting non-heads. +Vanquishable only through a blue head.") + +(defface hydra-face-pink + '((t (:foreground "#FF6EB4" :bold t))) + "Pink body has red heads and on intercepting non-heads calls them without quitting. +Vanquishable only through a blue head.") + +(defface hydra-face-teal + '((t (:foreground "#367588" :bold t))) + "Teal body has blue heads an warns on intercepting non-heads. +Vanquishable only through a blue head.") + +;;* Fontification +(defun hydra-add-font-lock () + "Fontify `defhydra' statements." + (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))))) ;;* Universal Argument (defvar hydra-base-map @@ -166,6 +216,21 @@ It's possible to set this to nil.") (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 @@ -180,7 +245,7 @@ It's possible to set this to nil.") (defun hydra--make-callable (x) "Generate a callable symbol from X. If X is a function symbol or a lambda, return it. Otherwise, it -should be a single statement. Wrap it in an interactive lambda." +should be a single statement. Wrap it in an interactive lambda." (if (or (symbolp x) (functionp x)) x `(lambda () @@ -190,42 +255,124 @@ should be a single statement. Wrap it in an interactive lambda." (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 (stringp (cl-caddr h)) - (cl-cdddr h) - (cddr h)))) + (let ((plist (cl-cdddr h))) (if (memq prop h) (plist-get plist prop) default))) -(defun hydra--color (h body-color) - "Return the color of a Hydra head H with BODY-COLOR." - (if (null (cadr h)) - 'blue - (or (hydra--head-property h :color) body-color))) - -(defun hydra--face (h body-color) - "Return the face for a Hydra head H with BODY-COLOR." - (cl-case (hydra--color h body-color) +(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'" + (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) + (pink 'hydra-face-pink) + (teal 'hydra-face-teal) (t (error "Unknown color for %S" h)))) -(defun hydra--hint (docstring heads body-color) - "Generate a hint from DOCSTRING and HEADS and BODY-COLOR. -It's intended for the echo area, when a Hydra is active." - (format "%s: %s." - docstring - (mapconcat - (lambda (h) - (format - (if (stringp (cl-caddr h)) - (concat "[%s]: " (cl-caddr h)) - "%s") - (propertize - (car h) 'face - (hydra--face h body-color)))) - heads ", "))) +(defun hydra-cleanup () + "Clean up after a Hydra." + (when (window-live-p lv-wnd) + (let ((buf (window-buffer lv-wnd))) + (delete-window lv-wnd) + (kill-buffer buf)))) + +(defun hydra-keyboard-quit () + "Quitting function similar to `keyboard-quit'." + (interactive) + (hydra-disable) + (hydra-cleanup) + (cancel-timer hydra-timer) + nil) (defun hydra-disable () "Disable the current Hydra." @@ -234,17 +381,149 @@ It's intended for the echo area, when a Hydra is active." ((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. +Otherwise, add PREFIX to the symbol name." + (let ((sym (intern-soft str))) + (if (boundp sym) + sym + (intern (concat prefix "/" str))))) + +(defun hydra--hint (name body docstring heads) + "Generate a hint for the echo area. +NAME, BODY, DOCSTRING and HEADS are parameters to `defhydra'." + (let (alist) + (dolist (h heads) + (let ((val (assoc (cadr h) alist)) + (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 (cl-caddr h))) + 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, BODY, DOCSTRING and HEADS are parameters of `defhydra'. +The expressions can be auto-expanded according to NAME." + (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 + offset) + (while (setq start + (string-match + "\\(?:%\\( ?-?[0-9]*s?\\)\\(`[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 + (let* ((spec (match-string 1 docstring)) + (lspec (length spec))) + (setq offset + (with-temp-buffer + (insert (substring docstring (+ 1 start (length spec)))) + (goto-char (point-min)) + (push (read (current-buffer)) varlist) + (point))) + (when (or (zerop lspec) + (/= (aref spec (1- (length spec))) ?s)) + (setq spec (concat spec "S"))) + (setq docstring + (concat + (substring docstring 0 start) + "%" spec + (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. +Set `hydra-lv' to choose the echo area. +NAME, BODY, DOCSTRING, and HEADS are parameters of `defhydra'." + (let ((format-expr (hydra--format name body docstring heads))) + `(if hydra-lv + (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. @@ -262,71 +541,236 @@ HEADS is a list of heads." 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) - (catch 'hydra-disable - ,@(delq nil - (if (eq color 'blue) - `(,(when cmd `(call-interactively #',cmd)) - ,body-post) - `(,(when cmd - `(condition-case err - (prog1 t - (call-interactively #',cmd)) - ((debug error) - (message "%S" err) - (sit-for 0.8) - nil))) - (when hydra-is-helpful - (message ,hint)) - (setq hydra-last - (hydra-set-transient-map - (setq hydra-curr-map ',keymap) - t - ,@(if (and (not (eq body-color 'amaranth)) body-post) - `((lambda () ,body-post))))) - ,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)) + (body-timeout (plist-get body :timeout))) + `(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))))) + ,(or other-post + (when body-timeout + `(hydra-timeout ,body-timeout)))))))))) + +(defun hydra-pink-fallback () + "On intercepting a non-head, try to run it." + (let ((keys (this-command-keys)) + kb) + (when (equal keys [backspace]) + (setq keys "")) + (setq kb (key-binding keys)) + (if kb + (if (commandp kb) + (condition-case err + (call-interactively kb) + ((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)))) + +(defvar hydra-timer (timer-create) + "Timer for `hydra-timeout'.") + +(defun hydra-timeout (secs &optional function) + "In SECS seconds call FUNCTION. +FUNCTION defaults to `hydra-disable'. +Cancel the previous `hydra-timeout'." + (cancel-timer hydra-timer) + (setq hydra-timer (timer-create)) + (timer-set-time hydra-timer + (timer-relative-time nil secs)) + (timer-set-function + hydra-timer + (or function #'hydra-keyboard-quit)) + (timer-activate hydra-timer)) ;;* Macros -;;** hydra-create -;;;###autoload -(defmacro hydra-create (body heads &optional method) - "Create a hydra with a BODY prefix and HEADS with METHOD. -This will result in `global-set-key' statements with the keys -being the concatenation of BODY and each head in HEADS. HEADS is -an list of (KEY FUNCTION &optional HINT). - -After one of the HEADS is called via BODY+KEY, it and the other -HEADS can be called with only KEY (no need for BODY). This state -is broken once any key binding that is not in HEADS is called. - -METHOD is a lambda takes two arguments: a KEY and a COMMAND. -It defaults to `global-set-key'. -When `(keymapp METHOD)`, it becomes: - - (lambda (key command) (define-key METHOD key command))" - (declare (indent 1) - (obsolete defhydra "0.8.0")) - `(defhydra ,(intern - (concat - "hydra-" (replace-regexp-in-string " " "_" body))) - ,(cond ((hydra--callablep method) - method) - ((null method) - `(global-map ,body)) - (t - (list method body))) - "hydra" - ,@(eval heads))) - ;;** defhydra ;;;###autoload (defmacro defhydra (name body &optional docstring &rest heads) @@ -349,8 +793,18 @@ format: BODY-MAP is a keymap; `global-map' is used quite often. Each function generated from HEADS will be bound in BODY-MAP to -BODY-KEY + KEY, and will set the transient map so that all -following heads can be called though KEY only. +BODY-KEY + KEY (both are strings passed to `kbd'), and will set +the transient map so that all following heads can be called +though KEY only. + +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 +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 +explicitly to nil. The heads inherit their PLIST from the body and are allowed to override each key. The keys recognized are :color and :bind. @@ -363,70 +817,65 @@ except a blue head can stop the Hydra state. :bind can be: - nil: this head will not be bound in BODY-MAP. -- a lambda taking KEY and CMD used to bind a head" - (declare (indent 2)) - (unless (stringp docstring) - (setq heads (cons docstring heads)) - (setq docstring "hydra")) +- 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 +result of `defhydra'." + (declare (indent defun)) + (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))) (body-key (unless (hydra--callablep body) (cadr body))) - (body-color (if (hydra--callablep body) - 'red - (or (plist-get (cddr body) :color) - 'red))) + (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))) - (hint (hydra--hint docstring heads body-color)) - (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 (eq body-color 'amaranth) - (if (cl-some `(lambda (h) - (eq (hydra--color h ',body-color) 'blue)) - heads) - (define-key keymap [t] - `(lambda () - (interactive) - (message "An amaranth Hydra can only exit through a blue head") - (hydra-set-transient-map hydra-curr-map t) - (when hydra-is-helpful - (sit-for 0.8) - (message ,hint)))) - (error "An amaranth Hydra must have at least one blue head in order to exit")) - (when hydra-keyboard-quit - (define-key keymap hydra-keyboard-quit - `(lambda () - (interactive) - (hydra-disable) - ,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--color head body-color) - (format "%s\n\nCall the head: `%S'." doc (cadr head)) - hint 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)) @@ -434,34 +883,112 @@ except a blue head can stop the Hydra state. (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)) - ,(hydra--make-defun body-name nil nil doc hint keymap - body-color body-pre body-post - '(setq prefix-arg current-prefix-arg))))) + (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 + 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. +BODY specifies the options; there are none currently. +HEADS have the format: + + (TOGGLE-NAME &optional VALUE DOC) + +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 +inialize the variable. +VALUE defaults to [nil t]. +DOC defaults to TOGGLE-NAME split and capitalized." + (declare (indent defun)) + `(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))) + (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 () + (hydra--cycle-radio ',full-name))))) + +(defun hydra--quote-maybe (x) + "Quote X if it's a symbol." + (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." + (let* ((val (symbol-value sym)) + (range (get sym 'range)) + (i 0) + (l (length range))) + (setq i (catch 'done + (while (< i l) + (if (equal (aref range i) val) + (throw 'done (1+ i)) + (incf i))) + (error "Val not in range for %S" sym))) + (set sym + (aref range + (if (>= i l) + 0 + i))))) (provide 'hydra) diff --git a/packages/hydra/lv.el b/packages/hydra/lv.el new file mode 100644 index 0000000..7b19074 --- /dev/null +++ b/packages/hydra/lv.el @@ -0,0 +1,75 @@ +;;; lv.el --- Other echo area + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Oleh Krehel + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This package provides `lv-message' intended to be used in place of +;; `message' when semi-permanent hints are needed, in order to not +;; interfere with Echo Area. +;; +;; "Я тихо-тихо пiдглядаю, +;; І тiшуся собi, як бачу то, +;; Шо страшить i не пiдпускає, +;; А iншi п’ють тебе, як воду пiсок." +;; -- Андрій Кузьменко, L.V. + +;;; Code: + +(defvar lv-wnd nil + "Holds the current LV window.") + +(defun lv-window () + "Ensure that LV window is live and return it." + (if (window-live-p lv-wnd) + lv-wnd + (let ((ori (selected-window)) + (golden-ratio-mode nil) + buf) + (prog1 (setq lv-wnd + (select-window + (split-window + (frame-root-window) -1 'below))) + (if (setq buf (get-buffer "*LV*")) + (switch-to-buffer buf) + (switch-to-buffer "*LV*") + (setq truncate-lines nil) + (setq mode-line-format nil) + (setq cursor-type nil) + (set-window-dedicated-p lv-wnd t) + (set-window-parameter lv-wnd 'no-other-window t)) + (select-window ori))))) + +(defun lv-message (format-string &rest args) + "Set LV window contents to (`format' FORMAT-STRING ARGS)." + (let ((ori (selected-window)) + (str (apply #'format format-string args)) + deactivate-mark) + (select-window (lv-window)) + (unless (string= (buffer-string) str) + (delete-region (point-min) (point-max)) + (insert str) + (fit-window-to-buffer nil nil 1)) + (goto-char (point-min)) + (select-window ori))) + +(provide 'lv) + +;;; lv.el ends here