From: Andreas Gerler Date: Fri, 31 Jan 2020 16:30:42 +0000 (+0100) Subject: update hydra X-Git-Url: http://git.bundesbrandschatzamt.de/?a=commitdiff_plain;h=6c7aba0e2275706f5c24f9141e7f9d3f2d3d8534;p=emacsconfig.git update hydra --- diff --git a/elpa/hydra-20190821.939/hydra-autoloads.el b/elpa/hydra-20190821.939/hydra-autoloads.el deleted file mode 100644 index d3428dda..00000000 --- a/elpa/hydra-20190821.939/hydra-autoloads.el +++ /dev/null @@ -1,79 +0,0 @@ -;;; hydra-autoloads.el --- automatically extracted autoloads -;; -;;; Code: -(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path)))) - -;;;### (autoloads nil "hydra" "hydra.el" (23994 42600 207958 9000)) -;;; Generated autoloads from hydra.el - -(autoload 'defhydra "hydra" "\ -Create a Hydra - a family of functions with prefix NAME. - -NAME should be a symbol, it will be the prefix of all functions -defined here. - -BODY has the format: - - (BODY-MAP BODY-KEY &rest BODY-PLIST) - -DOCSTRING will be displayed in the echo area to identify the -Hydra. When DOCSTRING starts with a newline, special Ruby-style -substitution will be performed by `hydra--format'. - -Functions are created on basis of HEADS, each of which has the -format: - - (KEY CMD &optional HINT &rest PLIST) - -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 (both are strings passed to `kbd'), and will set -the transient map so that all following heads can be called -though KEY only. BODY-KEY can be an empty string. - -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 BODY-PLIST and are allowed to -override some keys. The keys recognized are :exit, :bind, and :column. -:exit can be: - -- nil (default): this head will continue the Hydra state. -- t: this head will 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. - -:column is a string that sets the column for all subsequent heads. - -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'. - -\(fn NAME BODY &optional DOCSTRING &rest HEADS)" nil t) - -(function-put 'defhydra 'lisp-indent-function 'defun) - -(function-put 'defhydra 'doc-string-elt '3) - -;;;*** - -;;;### (autoloads nil nil ("hydra-examples.el" "hydra-ox.el" "hydra-pkg.el") -;;;;;; (23994 42600 209767 474000)) - -;;;*** - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; End: -;;; hydra-autoloads.el ends here diff --git a/elpa/hydra-20190821.939/hydra-examples.el b/elpa/hydra-20190821.939/hydra-examples.el deleted file mode 100644 index 5262ec60..00000000 --- a/elpa/hydra-20190821.939/hydra-examples.el +++ /dev/null @@ -1,393 +0,0 @@ -;;; hydra-examples.el --- Some applications for 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 . - -;;; Commentary: -;; -;; These are the sample Hydras. -;; -;; If you want to use them plainly, set `hydra-examples-verbatim' to t -;; before requiring this file. But it's probably better to only look -;; at them and use them as templates for building your own. - -;;; Code: - -(require 'hydra) - -;;* Examples -;;** Example 1: text scale -(when (bound-and-true-p hydra-examples-verbatim) - (defhydra hydra-zoom (global-map "") - "zoom" - ("g" text-scale-increase "in") - ("l" text-scale-decrease "out"))) - -;; This example generates three commands: -;; -;; `hydra-zoom/text-scale-increase' -;; `hydra-zoom/text-scale-decrease' -;; `hydra-zoom/body' -;; -;; In addition, two of them are bound like this: -;; -;; (global-set-key (kbd " g") 'hydra-zoom/text-scale-increase) -;; (global-set-key (kbd " l") 'hydra-zoom/text-scale-decrease) -;; -;; Note that you can substitute `global-map' with e.g. `emacs-lisp-mode-map' if you need. -;; The functions generated will be the same, except the binding code will change to: -;; -;; (define-key emacs-lisp-mode-map [f2 103] -;; (function hydra-zoom/text-scale-increase)) -;; (define-key emacs-lisp-mode-map [f2 108] -;; (function hydra-zoom/text-scale-decrease)) - -;;** Example 2: move window splitter -(when (bound-and-true-p hydra-examples-verbatim) - (defhydra hydra-splitter (global-map "C-M-s") - "splitter" - ("h" hydra-move-splitter-left) - ("j" hydra-move-splitter-down) - ("k" hydra-move-splitter-up) - ("l" hydra-move-splitter-right))) - -;;** Example 3: jump to error -(when (bound-and-true-p hydra-examples-verbatim) - (defhydra hydra-error (global-map "M-g") - "goto-error" - ("h" first-error "first") - ("j" next-error "next") - ("k" previous-error "prev") - ("v" recenter-top-bottom "recenter") - ("q" nil "quit"))) - -;; This example introduces only one new thing: since the command -;; passed to the "q" head is nil, it will quit the Hydra without doing -;; anything. Heads that quit the Hydra instead of continuing are -;; referred to as having blue :color. All the other heads have red -;; :color, unless other is specified. - -;;** Example 4: toggle rarely used modes -(when (bound-and-true-p hydra-examples-verbatim) - (defvar whitespace-mode nil) - (global-set-key - (kbd "C-c C-v") - (defhydra hydra-toggle-simple (:color blue) - "toggle" - ("a" abbrev-mode "abbrev") - ("d" toggle-debug-on-error "debug") - ("f" auto-fill-mode "fill") - ("t" toggle-truncate-lines "truncate") - ("w" whitespace-mode "whitespace") - ("q" nil "cancel")))) - -;; Note that in this case, `defhydra' returns the `hydra-toggle-simple/body' -;; symbol, which is then passed to `global-set-key'. -;; -;; Another new thing is that both the keymap and the body prefix are -;; skipped. This means that `defhydra' will bind nothing - that's why -;; `global-set-key' is necessary. -;; -;; One more new thing is that you can assign a :color to the body. All -;; heads will inherit this color. The code above is very much equivalent to: -;; -;; (global-set-key (kbd "C-c C-v a") 'abbrev-mode) -;; (global-set-key (kbd "C-c C-v d") 'toggle-debug-on-error) -;; -;; The differences are: -;; -;; * You get a hint immediately after "C-c C-v" -;; * You can cancel and call a command immediately, e.g. "C-c C-v C-n" -;; is equivalent to "C-n" with Hydra approach, while it will error -;; that "C-c C-v C-n" isn't bound with the usual approach. - -;;** Example 5: mini-vi -(defun hydra-vi/pre () - (set-cursor-color "#e52b50")) - -(defun hydra-vi/post () - (set-cursor-color "#ffffff")) - -(when (bound-and-true-p hydra-examples-verbatim) - (global-set-key - (kbd "C-z") - (defhydra hydra-vi (:pre hydra-vi/pre :post hydra-vi/post :color amaranth) - "vi" - ("l" forward-char) - ("h" backward-char) - ("j" next-line) - ("k" previous-line) - ("m" set-mark-command "mark") - ("a" move-beginning-of-line "beg") - ("e" move-end-of-line "end") - ("d" delete-region "del" :color blue) - ("y" kill-ring-save "yank" :color blue) - ("q" nil "quit"))) - (hydra-set-property 'hydra-vi :verbosity 1)) - -;; This example introduces :color amaranth. It's similar to red, -;; except while you can quit red with any binding which isn't a Hydra -;; head, you can quit amaranth only with a blue head. So you can quit -;; this mode only with "d", "y", "q" or "C-g". -;; -;; Another novelty are the :pre and :post handlers. :pre will be -;; called before each command, while :post will be called when the -;; Hydra quits. In this case, they're used to override the cursor -;; color while Hydra is active. - -;;** Example 6: selective global bind -(when (bound-and-true-p hydra-examples-verbatim) - (defhydra hydra-next-error (global-map "C-x") - "next-error" - ("`" next-error "next") - ("j" next-error "next" :bind nil) - ("k" previous-error "previous" :bind nil))) - -;; 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 -(defvar whitespace-mode nil) -(defhydra hydra-toggle (:color pink) - " -_a_ abbrev-mode: %`abbrev-mode -_d_ debug-on-error: %`debug-on-error -_f_ auto-fill-mode: %`auto-fill-function -_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) - ("t" toggle-truncate-lines nil) - ("w" whitespace-mode nil) - ("q" nil "quit")) -;; Recommended binding: -;; (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 - :hint nil) - " -^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) - ("u" Buffer-menu-unmark) - ("U" Buffer-menu-backup-unmark) - ("d" Buffer-menu-delete) - ("D" Buffer-menu-delete-backwards) - ("s" Buffer-menu-save) - ("~" Buffer-menu-not-modified) - ("x" Buffer-menu-execute) - ("b" Buffer-menu-bury) - ("g" revert-buffer) - ("T" Buffer-menu-toggle-files-only) - ("O" Buffer-menu-multi-occur :color blue) - ("I" Buffer-menu-isearch-buffers :color blue) - ("R" Buffer-menu-isearch-buffers-regexp :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: -(defvar dired-mode-map) -(declare-function dired-mark "dired") -(when (bound-and-true-p hydra-examples-verbatim) - (require '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). - -;;** Example 10: apropos family -(defhydra hydra-apropos (:color blue - :hint nil) - " -_a_propos _c_ommand -_d_ocumentation _l_ibrary -_v_ariable _u_ser-option -^ ^ valu_e_" - ("a" apropos) - ("d" apropos-documentation) - ("v" apropos-variable) - ("c" apropos-command) - ("l" apropos-library) - ("u" apropos-user-option) - ("e" apropos-value)) -;; Recommended binding: -;; (global-set-key (kbd "C-c h") 'hydra-apropos/body) - -;;** Example 11: rectangle-mark-mode -(require 'rect) -(defhydra hydra-rectangle (:body-pre (rectangle-mark-mode 1) - :color pink - :post (deactivate-mark)) - " - ^_k_^ _d_elete _s_tring -_h_ _l_ _o_k _y_ank - ^_j_^ _n_ew-copy _r_eset -^^^^ _e_xchange _u_ndo -^^^^ ^ ^ _x_kill -" - ("h" rectangle-backward-char nil) - ("l" rectangle-forward-char nil) - ("k" rectangle-previous-line nil) - ("j" rectangle-next-line nil) - ("e" hydra-ex-point-mark nil) - ("n" copy-rectangle-as-kill nil) - ("d" delete-rectangle nil) - ("r" (if (region-active-p) - (deactivate-mark) - (rectangle-mark-mode 1)) nil) - ("y" yank-rectangle nil) - ("u" undo nil) - ("s" string-rectangle nil) - ("x" kill-rectangle nil) - ("o" nil nil)) - -;; Recommended binding: -;; (global-set-key (kbd "C-x SPC") 'hydra-rectangle/body) - -;;** Example 12: org-agenda-view -(defun org-agenda-cts () - (and (eq major-mode 'org-agenda-mode) - (let ((args (get-text-property - (min (1- (point-max)) (point)) - 'org-last-args))) - (nth 2 args)))) - -(defhydra hydra-org-agenda-view (:hint none) - " -_d_: ?d? day _g_: time grid=?g? _a_: arch-trees -_w_: ?w? week _[_: inactive _A_: arch-files -_t_: ?t? fortnight _f_: follow=?f? _r_: clock report=?r? -_m_: ?m? month _e_: entry text=?e? _D_: include diary=?D? -_y_: ?y? year _q_: quit _L__l__c_: log = ?l?" - ("SPC" org-agenda-reset-view) - ("d" org-agenda-day-view (if (eq 'day (org-agenda-cts)) "[x]" "[ ]")) - ("w" org-agenda-week-view (if (eq 'week (org-agenda-cts)) "[x]" "[ ]")) - ("t" org-agenda-fortnight-view (if (eq 'fortnight (org-agenda-cts)) "[x]" "[ ]")) - ("m" org-agenda-month-view (if (eq 'month (org-agenda-cts)) "[x]" "[ ]")) - ("y" org-agenda-year-view (if (eq 'year (org-agenda-cts)) "[x]" "[ ]")) - ("l" org-agenda-log-mode (format "% -3S" org-agenda-show-log)) - ("L" (org-agenda-log-mode '(4))) - ("c" (org-agenda-log-mode 'clockcheck)) - ("f" org-agenda-follow-mode (format "% -3S" org-agenda-follow-mode)) - ("a" org-agenda-archives-mode) - ("A" (org-agenda-archives-mode 'files)) - ("r" org-agenda-clockreport-mode (format "% -3S" org-agenda-clockreport-mode)) - ("e" org-agenda-entry-text-mode (format "% -3S" org-agenda-entry-text-mode)) - ("g" org-agenda-toggle-time-grid (format "% -3S" org-agenda-use-time-grid)) - ("D" org-agenda-toggle-diary (format "% -3S" org-agenda-include-diary)) - ("!" org-agenda-toggle-deadlines) - ("[" (let ((org-agenda-include-inactive-timestamps t)) - (org-agenda-check-type t 'timeline 'agenda) - (org-agenda-redo) - (message "Display now includes inactive timestamps as well"))) - ("q" (message "Abort") :exit t) - ("v" nil)) - -;; Recommended binding: -;; (define-key org-agenda-mode-map "v" 'hydra-org-agenda-view/body) - -;;** Example 13: automatic columns -(defhydra hydra-movement () - ("j" next-line "down" :column "Vertical") - ("k" previous-line "up") - ("l" forward-char "forward" :column "Horizontal") - ("h" backward-char "back")) - -;;* Helpers -(require 'windmove) - -(defun hydra-move-splitter-left (arg) - "Move window splitter left." - (interactive "p") - (if (let ((windmove-wrap-around)) - (windmove-find-other-window 'right)) - (shrink-window-horizontally arg) - (enlarge-window-horizontally arg))) - -(defun hydra-move-splitter-right (arg) - "Move window splitter right." - (interactive "p") - (if (let ((windmove-wrap-around)) - (windmove-find-other-window 'right)) - (enlarge-window-horizontally arg) - (shrink-window-horizontally arg))) - -(defun hydra-move-splitter-up (arg) - "Move window splitter up." - (interactive "p") - (if (let ((windmove-wrap-around)) - (windmove-find-other-window 'up)) - (enlarge-window arg) - (shrink-window arg))) - -(defun hydra-move-splitter-down (arg) - "Move window splitter down." - (interactive "p") - (if (let ((windmove-wrap-around)) - (windmove-find-other-window 'up)) - (shrink-window arg) - (enlarge-window arg))) - -(defvar rectangle-mark-mode) -(defun hydra-ex-point-mark () - "Exchange point and mark." - (interactive) - (if rectangle-mark-mode - (rectangle-exchange-point-and-mark) - (let ((mk (mark))) - (rectangle-mark-mode 1) - (goto-char mk)))) - -(provide 'hydra-examples) - -;; Local Variables: -;; no-byte-compile: t -;; End: -;;; hydra-examples.el ends here diff --git a/elpa/hydra-20190821.939/hydra-ox.el b/elpa/hydra-20190821.939/hydra-ox.el deleted file mode 100644 index a992efc2..00000000 --- a/elpa/hydra-20190821.939/hydra-ox.el +++ /dev/null @@ -1,127 +0,0 @@ -;;; 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 . - -;;; Commentary: -;; -;; This shows how a complex dispatch menu can be built with Hydra. - -;;; Code: - -(require 'hydra) -(require 'org) -(declare-function org-html-export-as-html 'ox-html) -(declare-function org-html-export-to-html 'ox-html) -(declare-function org-latex-export-as-latex 'ox-latex) -(declare-function org-latex-export-to-latex 'ox-latex) -(declare-function org-latex-export-to-pdf 'ox-latex) -(declare-function org-ascii-export-as-ascii 'ox-ascii) -(declare-function org-ascii-export-to-ascii 'ox-ascii) - -(defhydradio hydra-ox () - (body-only "Export only the body.") - (export-scope "Export scope." [buffer subtree]) - (async-export "When non-nil, export async.") - (visible-only "When non-nil, export visible only") - (force-publishing "Toggle 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/elpa/hydra-20190821.939/hydra-pkg.el b/elpa/hydra-20190821.939/hydra-pkg.el deleted file mode 100644 index ac073f7e..00000000 --- a/elpa/hydra-20190821.939/hydra-pkg.el +++ /dev/null @@ -1,13 +0,0 @@ -(define-package "hydra" "20190821.939" "Make bindings that stick around." - '((cl-lib "0.5") - (lv "0")) - :keywords - '("bindings") - :authors - '(("Oleh Krehel" . "ohwoeowho@gmail.com")) - :maintainer - '("Oleh Krehel" . "ohwoeowho@gmail.com") - :url "https://github.com/abo-abo/hydra") -;; Local Variables: -;; no-byte-compile: t -;; End: diff --git a/elpa/hydra-20190821.939/hydra.el b/elpa/hydra-20190821.939/hydra.el deleted file mode 100644 index a33be7a3..00000000 --- a/elpa/hydra-20190821.939/hydra.el +++ /dev/null @@ -1,1547 +0,0 @@ -;;; hydra.el --- Make bindings that stick around. -*- lexical-binding: t -*- - -;; Copyright (C) 2015-2019 Free Software Foundation, Inc. - -;; Author: Oleh Krehel -;; Maintainer: Oleh Krehel -;; URL: https://github.com/abo-abo/hydra -;; Version: 0.15.0 -;; Keywords: bindings -;; Package-Requires: ((cl-lib "0.5") (lv "0")) - -;; 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 . - -;;; Commentary: -;; -;; This package can be used to tie related commands into a family of -;; short bindings with a common prefix - a Hydra. -;; -;; Once you summon the Hydra (through the prefixed binding), all the -;; heads can be called in succession with only a short extension. -;; The Hydra is vanquished once Hercules, any binding that isn't the -;; Hydra's head, arrives. Note that Hercules, besides vanquishing the -;; Hydra, will still serve his orignal purpose, calling his proper -;; command. This makes the Hydra very seamless, it's like a minor -;; mode that disables itself automagically. -;; -;; Here's an example Hydra, bound in the global map (you can use any -;; keymap in place of `global-map'): -;; -;; (defhydra hydra-zoom (global-map "") -;; "zoom" -;; ("g" text-scale-increase "in") -;; ("l" text-scale-decrease "out")) -;; -;; It allows to start a command chain either like this: -;; " gg4ll5g", or " lgllg". -;; -;; Here's another approach, when you just want a "callable keymap": -;; -;; (defhydra hydra-toggle (:color blue) -;; "toggle" -;; ("a" abbrev-mode "abbrev") -;; ("d" toggle-debug-on-error "debug") -;; ("f" auto-fill-mode "fill") -;; ("t" toggle-truncate-lines "truncate") -;; ("w" whitespace-mode "whitespace") -;; ("q" nil "cancel")) -;; -;; This binds nothing so far, but if you follow up with: -;; -;; (global-set-key (kbd "C-c C-v") 'hydra-toggle/body) -;; -;; you will have bound "C-c C-v a", "C-c C-v d" etc. -;; -;; Knowing that `defhydra' defines e.g. `hydra-toggle/body' command, -;; you can nest Hydras if you wish, with `hydra-toggle/body' possibly -;; becoming a blue head of another Hydra. -;; -;; If you want to learn all intricacies of using `defhydra' without -;; having to figure it all out from this source code, check out the -;; wiki: https://github.com/abo-abo/hydra/wiki. There's a wealth of -;; information there. Everyone is welcome to bring the existing pages -;; up to date and add new ones. -;; -;; Additionally, the file hydra-examples.el serves to demo most of the -;; functionality. - -;;; Code: -;;* Requires -(require 'cl-lib) -(require 'lv) -(require 'ring) - -(defvar hydra-curr-map nil - "The keymap of the current Hydra called.") - -(defvar hydra-curr-on-exit nil - "The on-exit predicate for the current Hydra.") - -(defvar hydra-curr-foreign-keys nil - "The current :foreign-keys behavior.") - -(defvar hydra-curr-body-fn nil - "The current hydra-.../body function.") - -(defvar hydra-deactivate nil - "If a Hydra head sets this to t, exit the Hydra. -This will be done even if the head wasn't designated for exiting.") - -(defvar hydra-amaranth-warn-message "An amaranth Hydra can only exit through a blue head" - "Amaranth Warning message. Shown when the user tries to press an unbound/non-exit key while in an amaranth head.") - -(defun hydra-set-transient-map (keymap on-exit &optional foreign-keys) - "Set KEYMAP to the highest priority. - -Call ON-EXIT when the KEYMAP is deactivated. - -FOREIGN-KEYS determines the deactivation behavior, when a command -that isn't in KEYMAP is called: - -nil: deactivate KEYMAP and run the command. -run: keep KEYMAP and run the command. -warn: keep KEYMAP and issue a warning instead of running the command." - (if hydra-deactivate - (hydra-keyboard-quit) - (setq hydra-curr-map keymap) - (setq hydra-curr-on-exit on-exit) - (setq hydra-curr-foreign-keys foreign-keys) - (add-hook 'pre-command-hook 'hydra--clearfun) - (internal-push-keymap keymap 'overriding-terminal-local-map))) - -(defun hydra--clearfun () - "Disable the current Hydra unless `this-command' is a head." - (unless (eq this-command 'hydra-pause-resume) - (when (or - (memq this-command '(handle-switch-frame - keyboard-quit)) - (null overriding-terminal-local-map) - (not (or (eq this-command - (lookup-key hydra-curr-map (this-single-command-keys))) - (cl-case hydra-curr-foreign-keys - (warn - (setq this-command 'hydra-amaranth-warn)) - (run - t) - (t nil))))) - (hydra-disable)))) - -(defvar hydra--ignore nil - "When non-nil, don't call `hydra-curr-on-exit'.") - -(defvar hydra--input-method-function nil - "Store overridden `input-method-function' here.") - -(defun hydra-disable () - "Disable the current Hydra." - (setq hydra-deactivate nil) - (remove-hook 'pre-command-hook 'hydra--clearfun) - (unless hydra--ignore - (if (fboundp 'remove-function) - (remove-function input-method-function #'hydra--imf) - (when hydra--input-method-function - (setq input-method-function hydra--input-method-function) - (setq hydra--input-method-function nil)))) - (dolist (frame (frame-list)) - (with-selected-frame frame - (when overriding-terminal-local-map - (internal-pop-keymap hydra-curr-map 'overriding-terminal-local-map)))) - (unless hydra--ignore - (when hydra-curr-on-exit - (let ((on-exit hydra-curr-on-exit)) - (setq hydra-curr-on-exit nil) - (funcall on-exit))))) - -(unless (fboundp 'internal-push-keymap) - (defun internal-push-keymap (keymap symbol) - (let ((map (symbol-value symbol))) - (unless (memq keymap map) - (unless (memq 'add-keymap-witness (symbol-value symbol)) - (setq map (make-composed-keymap nil (symbol-value symbol))) - (push 'add-keymap-witness (cdr map)) - (set symbol map)) - (push keymap (cdr map)))))) - -(unless (fboundp 'internal-pop-keymap) - (defun internal-pop-keymap (keymap symbol) - (let ((map (symbol-value symbol))) - (when (memq keymap map) - (setf (cdr map) (delq keymap (cdr map)))) - (let ((tail (cddr map))) - (and (or (null tail) (keymapp tail)) - (eq 'add-keymap-witness (nth 1 map)) - (set symbol tail)))))) - -(defun hydra-amaranth-warn () - "Issue a warning that the current input was ignored." - (interactive) - (message hydra-amaranth-warn-message)) - -;;* Customize -(defgroup hydra nil - "Make bindings that stick around." - :group 'bindings - :prefix "hydra-") - -(defcustom hydra-is-helpful t - "When t, display a hint with possible bindings in the echo area." - :type 'boolean - :group 'hydra) - -(defcustom hydra-default-hint "" - "Default :hint property to use for heads when not specified in -the body or the head." - :type 'sexp - :group 'hydra) - -(declare-function posframe-show "posframe") -(declare-function posframe-hide "posframe") -(declare-function posframe-poshandler-window-center "posframe") - -(defvar hydra-posframe-show-params - '(:internal-border-width 1 - :internal-border-color "red" - :poshandler posframe-poshandler-window-center) - "List of parameters passed to `posframe-show'.") - -(defvar hydra--posframe-timer nil - "Timer for hiding posframe hint.") - -(defun hydra-posframe-show (str) - (require 'posframe) - (when hydra--posframe-timer - (cancel-timer hydra--posframe-timer)) - (setq hydra--posframe-timer nil) - (apply #'posframe-show - " *hydra-posframe*" - :string str - hydra-posframe-show-params)) - -(defun hydra-posframe-hide () - (require 'posframe) - (unless hydra--posframe-timer - (setq hydra--posframe-timer - (run-with-idle-timer - 0 nil (lambda () - (setq hydra--posframe-timer nil) - (posframe-hide " *hydra-posframe*")))))) - -(defvar hydra-hint-display-alist - (list (list 'lv #'lv-message #'lv-delete-window) - (list 'message #'message (lambda () (message ""))) - (list 'posframe #'hydra-posframe-show #'hydra-posframe-hide)) - "Store the functions for `hydra-hint-display-type'.") - -(defcustom hydra-hint-display-type 'lv - "The utility to show hydra hint" - :type '(choice - (const message) - (const lv) - (const posframe)) - :group 'hydra) - -(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_." - :type 'string) - -(defcustom hydra-doc-format-spec "%s" - "Default `format'-style specifier for ?a? syntax in docstrings." - :type 'string) - -(defcustom hydra-look-for-remap nil - "When non-nil, hydra binding behaves as keymap binding with [remap]. -When calling a head with a simple command, hydra will lookup for a potential -remap command according to the current active keymap and call it instead if -found" - :type 'boolean) - -(make-obsolete-variable - 'hydra-key-format-spec - "Since the docstrings are aligned by hand anyway, this isn't very useful." - "0.13.1") - -(defface hydra-face-red - '((t (:foreground "#FF0000" :bold t))) - "Red Hydra heads don't exit the Hydra. -Every other command exits the Hydra." - :group 'hydra) - -(defface hydra-face-blue - '((((class color) (background light)) - :foreground "#0000FF" :bold t) - (((class color) (background dark)) - :foreground "#8ac6f2" :bold t)) - "Blue Hydra heads exit the Hydra. -Every other command exits as well.") - -(defface hydra-face-amaranth - '((t (:foreground "#E52B50" :bold t))) - "Amaranth body has red heads and warns on intercepting non-heads. -Exitable only through a blue head.") - -(defface hydra-face-pink - '((t (:foreground "#FF6EB4" :bold t))) - "Pink body has red heads and runs intercepted non-heads. -Exitable only through a blue head.") - -(defface hydra-face-teal - '((t (:foreground "#367588" :bold t))) - "Teal body has blue heads and warns on intercepting non-heads. -Exitable 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))))) - -;;* Find Function -(eval-after-load 'find-func - '(defadvice find-function-search-for-symbol - (around hydra-around-find-function-search-for-symbol-advice - (symbol type library) activate) - "Navigate to hydras with `find-function-search-for-symbol'." - (prog1 ad-do-it - (when (symbolp symbol) - ;; The orignial function returns (cons (current-buffer) (point)) - ;; if it found the point. - (unless (cdr ad-return-value) - (with-current-buffer (find-file-noselect library) - (let ((sn (symbol-name symbol))) - (when (and (null type) - (string-match "\\`\\(hydra-[a-z-A-Z0-9]+\\)/\\(.*\\)\\'" sn) - (re-search-forward (concat "(defhydra " (match-string 1 sn)) - nil t)) - (goto-char (match-beginning 0))) - (cons (current-buffer) (point))))))))) - -;;* Universal Argument -(defvar hydra-base-map - (let ((map (make-sparse-keymap))) - (define-key map [?\C-u] 'hydra--universal-argument) - (define-key map [?-] 'hydra--negative-argument) - (define-key map [?0] 'hydra--digit-argument) - (define-key map [?1] 'hydra--digit-argument) - (define-key map [?2] 'hydra--digit-argument) - (define-key map [?3] 'hydra--digit-argument) - (define-key map [?4] 'hydra--digit-argument) - (define-key map [?5] 'hydra--digit-argument) - (define-key map [?6] 'hydra--digit-argument) - (define-key map [?7] 'hydra--digit-argument) - (define-key map [?8] 'hydra--digit-argument) - (define-key map [?9] 'hydra--digit-argument) - (define-key map [kp-0] 'hydra--digit-argument) - (define-key map [kp-1] 'hydra--digit-argument) - (define-key map [kp-2] 'hydra--digit-argument) - (define-key map [kp-3] 'hydra--digit-argument) - (define-key map [kp-4] 'hydra--digit-argument) - (define-key map [kp-5] 'hydra--digit-argument) - (define-key map [kp-6] 'hydra--digit-argument) - (define-key map [kp-7] 'hydra--digit-argument) - (define-key map [kp-8] 'hydra--digit-argument) - (define-key map [kp-9] 'hydra--digit-argument) - (define-key map [kp-subtract] 'hydra--negative-argument) - map) - "Keymap that all Hydras inherit. See `universal-argument-map'.") - -(defun hydra--universal-argument (arg) - "Forward to (`universal-argument' ARG)." - (interactive "P") - (setq prefix-arg (if (consp arg) - (list (* 4 (car arg))) - (if (eq arg '-) - (list -4) - '(4))))) - -(defun hydra--digit-argument (arg) - "Forward to (`digit-argument' ARG)." - (interactive "P") - (let* ((char (if (integerp last-command-event) - last-command-event - (get last-command-event 'ascii-character))) - (digit (- (logand char ?\177) ?0))) - (setq prefix-arg (cond ((integerp arg) - (+ (* arg 10) - (if (< arg 0) - (- digit) - digit))) - ((eq arg '-) - (if (zerop digit) - '- - (- digit))) - (t - digit))))) - -(defun hydra--negative-argument (arg) - "Forward to (`negative-argument' ARG)." - (interactive "P") - (setq prefix-arg (cond ((integerp arg) (- arg)) - ((eq arg '-) nil) - (t '-)))) - -;;* 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 (&optional arg) - "Repeat last command with last prefix arg. -When ARG is non-nil, use that instead." - (interactive "p") - (if (eq arg 1) - (unless (string-match "hydra-repeat$" (symbol-name last-command)) - (setq hydra-repeat--command last-command) - (setq hydra-repeat--prefix-arg last-prefix-arg)) - (setq hydra-repeat--prefix-arg arg)) - (setq current-prefix-arg hydra-repeat--prefix-arg) - (funcall hydra-repeat--command)) - -;;* Misc internals -(defun hydra--callablep (x) - "Test if X is callable." - (or (functionp x) - (and (consp x) - (memq (car x) '(function quote))))) - -(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." - (cond ((or (symbolp x) (functionp x)) - x) - ((and (consp x) (eq (car x) 'function)) - (cadr x)) - (t - `(lambda () - (interactive) - ,x)))) - -(defun hydra-plist-get-default (plist prop default) - "Extract a value from a property list. -PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2...). - -Return the value corresponding to PROP, or DEFAULT if PROP is not -one of the properties on the list." - (if (memq prop plist) - (plist-get plist prop) - default)) - -(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." - (hydra-plist-get-default (cl-cdddr h) prop default)) - -(defun hydra--head-set-property (h prop value) - "In hydra Head H, set a property PROP to the value VALUE." - (cons (car h) (plist-put (cdr h) prop value))) - -(defun hydra--head-has-property (h prop) - "Return non nil if heads H has the property PROP." - (plist-member (cdr h) prop)) - -(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-exit (body) - "Return the exit behavior of BODY." - (or - (plist-get (cddr body) :exit) - (let ((color (plist-get (cddr body) :color))) - (cl-case color - ((blue teal) t) - (t nil))))) - -(defun hydra--normalize-body (body) - "Put BODY in a normalized format. -Add :exit and :foreign-keys if they are not there. -Remove :color key. And sort the plist alphabetically." - (let ((plist (cddr body))) - (plist-put plist :exit (hydra--body-exit body)) - (plist-put plist :foreign-keys (hydra--body-foreign-keys body)) - (let* ((alist0 (cl-loop for (k v) on plist - by #'cddr collect (cons k v))) - (alist1 (assq-delete-all :color alist0)) - (alist2 (cl-sort alist1 #'string< - :key (lambda (x) (symbol-name (car x)))))) - (append (list (car body) (cadr body)) - (cl-mapcan (lambda (x) (list (car x) (cdr x))) alist2))))) - -(defalias 'hydra--imf #'list) - -(defun hydra-default-pre () - "Default setup that happens in each head before :pre." - (when (eq input-method-function 'key-chord-input-method) - (if (fboundp 'add-function) - (add-function :override input-method-function #'hydra--imf) - (unless hydra--input-method-function - (setq hydra--input-method-function input-method-function) - (setq input-method-function nil))))) - -(defvar hydra-timeout-timer (timer-create) - "Timer for `hydra-timeout'.") - -(defvar hydra-message-timer (timer-create) - "Timer for the hint.") - -(defvar hydra--work-around-dedicated t - "When non-nil, assume there's no bug in `pop-to-buffer'. -`pop-to-buffer' should not select a dedicated window.") - -(defun hydra-keyboard-quit () - "Quitting function similar to `keyboard-quit'." - (interactive) - (hydra-disable) - (cancel-timer hydra-timeout-timer) - (cancel-timer hydra-message-timer) - (setq hydra-curr-map nil) - (unless (and hydra--ignore - (null hydra--work-around-dedicated)) - (funcall - (nth 2 (assoc hydra-hint-display-type hydra-hint-display-alist)))) - nil) - -(defvar hydra-head-format "[%s]: " - "The formatter for each head of a plain docstring.") - -(defvar hydra-key-doc-function 'hydra-key-doc-function-default - "The function for formatting key-doc pairs.") - -(defun hydra-key-doc-function-default (key key-width doc doc-width) - (cond - ((equal key " ") (format (format "%%-%ds" (+ 3 key-width doc-width)) doc)) - ((listp doc) - `(format ,(format "%%%ds: %%%ds" key-width (- -1 doc-width)) ,key ,doc)) - (t (format (format "%%%ds: %%%ds" key-width (- -1 doc-width)) key doc)))) - -(defun hydra--to-string (x) - (if (stringp x) - x - (eval x))) - -(defun hydra--eval-and-format (x) - (let ((str (hydra--to-string (cdr x)))) - (format - (if (> (length str) 0) - (concat hydra-head-format str) - "%s") - (car x)))) - -(defun hydra--hint-heads-wocol (body heads) - "Generate a hint for the echo area. -BODY, and HEADS are parameters to `defhydra'. -Works for heads without a property :column." - (let (alist) - (dolist (h heads) - (let ((val (assoc (cadr h) alist)) - (pstr (hydra-fontify-head h body))) - (if val - (setf (cadr val) - (concat (cadr val) " " pstr)) - (push - (cons (cadr h) - (cons pstr (cl-caddr h))) - alist)))) - (let ((keys (nreverse (mapcar #'cdr alist))) - (n-cols (plist-get (cddr body) :columns)) - res) - (setq res - (if n-cols - (let ((n-rows (1+ (/ (length keys) n-cols))) - (max-key-len (apply #'max (mapcar (lambda (x) (length (car x))) keys))) - (max-doc-len (apply #'max (mapcar (lambda (x) - (length (hydra--to-string (cdr x)))) keys)))) - `(concat - "\n" - (mapconcat #'identity - (mapcar - (lambda (x) - (mapconcat - (lambda (y) - (and y - (funcall hydra-key-doc-function - (car y) - ,max-key-len - (hydra--to-string (cdr y)) - ,max-doc-len))) x "")) - ',(hydra--matrix keys n-cols n-rows)) - "\n"))) - - - `(concat - (mapconcat - #'hydra--eval-and-format - ',keys - ", ") - ,(if keys "." "")))) - (if (cl-every #'stringp - (mapcar 'cddr alist)) - (eval res) - res)))) - -(defun hydra--hint (body heads) - "Generate a hint for the echo area. -BODY, and HEADS are parameters to `defhydra'." - (let* ((sorted-heads (hydra--sort-heads (hydra--normalize-heads heads))) - (heads-w-col (cl-remove-if-not (lambda (heads) (hydra--head-property (nth 0 heads) :column)) sorted-heads)) - (heads-wo-col (cl-remove-if (lambda (heads) (hydra--head-property (nth 0 heads) :column)) sorted-heads)) - (hint-w-col (when heads-w-col - (hydra--hint-from-matrix body (hydra--generate-matrix heads-w-col)))) - (hint-wo-col (when heads-wo-col - (hydra--hint-heads-wocol body (car heads-wo-col))))) - (if (null hint-w-col) - hint-wo-col - (if (stringp hint-wo-col) - `(concat ,@hint-w-col ,hint-wo-col) - `(concat ,@hint-w-col ,@(cdr hint-wo-col)))))) - -(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." - (let* ((foreign-keys (hydra--body-foreign-keys body)) - (head-exit (hydra--head-property head :exit)) - (head-color - (if head-exit - (if (eq foreign-keys 'warn) - 'teal - 'blue) - (cl-case foreign-keys - (warn 'amaranth) - (run 'pink) - (t 'red))))) - (when (and (null (cadr head)) - (not head-exit)) - (hydra--complain "nil cmd can only be blue")) - (propertize - (replace-regexp-in-string "%" "%%" (car head)) - 'face - (or (hydra--head-property head :face) - (cl-case head-color - (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" head))))))) - -(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 {}." - (format - (if (hydra--head-property head :exit) - "[%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--strip-align-markers (str) - "Remove ^ from STR, unless they're escaped: \\^." - (let ((start 0)) - (while (setq start (string-match "\\\\?\\^" str start)) - (if (eq (- (match-end 0) (match-beginning 0)) 2) - (progn - (setq str (replace-match "^" nil nil str)) - (cl-incf start)) - (setq str (replace-match "" nil nil str)))) - str)) - -(defvar hydra-docstring-keys-translate-alist - '(("↑" . "") - ("↓" . "") - ("→" . "") - ("←" . "") - ("⌫" . "DEL") - ("⌦" . "") - ("⏎" . "RET"))) - -(defconst hydra-width-spec-regex " ?-?[0-9]*?" - "Regex for the width spec in keys and %` quoted sexps.") - -(defvar hydra-key-regex "\\[\\|]\\|[-\\[:alnum:] ~.,;:/|?<>={}*+#%@!&^↑↓←→⌫⌦⏎'`()\"$]+?" - "Regex for the key quoted in the docstring.") - -(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." - (unless (memq 'elisp--witness--lisp (mapcar #'cadr heads)) - (setq docstring (hydra--strip-align-markers docstring)) - (setq docstring (replace-regexp-in-string "___" "_β_" docstring)) - (let ((rest (if (eq (plist-get (cddr body) :hint) 'none) - "" - (hydra--hint body heads))) - (start 0) - (inner-regex (format "\\(%s\\)\\(%s\\)" hydra-width-spec-regex hydra-key-regex)) - varlist - offset) - (while (setq start - (string-match - (format - "\\(?:%%\\( ?-?[0-9]*s?\\)\\(`[a-z-A-Z/0-9]+\\|(\\)\\)\\|\\(?:_%s_\\)\\|\\(?:[?]%s[?]\\)" - inner-regex - inner-regex) - docstring start)) - (cond ((eq ?? (aref (match-string 0 docstring) 0)) - (let* ((key (match-string 6 docstring)) - (head (assoc key heads))) - (if head - (progn - (push (nth 2 head) varlist) - (setq docstring - (replace-match - (or - hydra-doc-format-spec - (concat "%" (match-string 3 docstring) "s")) - t nil docstring))) - (setq start (match-end 0)) - (warn "Unrecognized key: ?%s?" key)))) - ((eq ?_ (aref (match-string 0 docstring) 0)) - (let* ((key (match-string 4 docstring)) - (key (if (equal key "β") "_" key)) - normal-key - (head (or (assoc key heads) - (when (setq normal-key - (cdr (assoc - key hydra-docstring-keys-translate-alist))) - (assoc normal-key heads))))) - (if head - (progn - (push (hydra-fontify-head (if normal-key - (cons key (cdr head)) - head) - body) - varlist) - (let ((replacement - (or - hydra-key-format-spec - (concat "%" (match-string 3 docstring) "s")))) - (setq docstring - (replace-match replacement t nil docstring)) - (setq start (+ start (length replacement))))) - (setq start (match-end 0)) - (warn "Unrecognized key: _%s_" key)))) - - (t - (let* ((varp (if (eq ?` (aref (match-string 2 docstring) 0)) 1 0)) - (spec (match-string 1 docstring)) - (lspec (length spec))) - (setq offset - (with-temp-buffer - (insert (substring docstring (+ 1 start varp - (length spec)))) - (goto-char (point-min)) - (push (read (current-buffer)) varlist) - (- (point) (point-min)))) - (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 (+ start offset 1 lspec varp)))))))) - (hydra--format-1 docstring rest varlist)))) - -(defun hydra--format-1 (docstring rest varlist) - (cond - ((string= docstring "") - rest) - ((listp rest) - (unless (string-match-p "[:\n]" docstring) - (setq docstring (concat docstring ":\n"))) - (unless (or (string-match-p "\n\\'" docstring) - (equal (cadr rest) "\n")) - (setq docstring (concat docstring "\n"))) - `(concat (format ,(replace-regexp-in-string "\\`\n" "" docstring) ,@(nreverse varlist)) - ,@(cdr rest))) - ((eq ?\n (aref docstring 0)) - `(format ,(concat (substring docstring 1) rest) ,@(nreverse varlist))) - (t - (let ((r `(replace-regexp-in-string - " +$" "" - (concat ,docstring - ,(cond ((string-match-p "\\`\n" rest) - ":") - ((string-match-p "\n" rest) - ":\n") - (t - ": ")) - (replace-regexp-in-string - "\\(%\\)" "\\1\\1" ,rest))))) - (if (stringp rest) - `(format ,(eval r)) - `(format ,r)))))) - -(defun hydra--complain (format-string &rest args) - "Forward to (`message' FORMAT-STRING ARGS) unless `hydra-verbose' is nil." - (if hydra-verbose - (apply #'error format-string args) - (apply #'message format-string args))) - -(defun hydra--doc (body-key body-name heads) - "Generate a part of Hydra docstring. -BODY-KEY is the body key binding. -BODY-NAME is the symbol that identifies the Hydra. -HEADS is a list of heads." - (format - "The heads for the associated hydra are:\n\n%s\n\n%s%s." - (mapconcat - (lambda (x) - (format "\"%s\": `%S'" (car x) (cadr x))) - heads ",\n") - (format "The body can be accessed via `%S'" body-name) - (if body-key - (format ", which is bound to \"%s\"" body-key) - ""))) - -(defun hydra--call-interactively-remap-maybe (cmd) - "`call-interactively' the given CMD or its remapped equivalent. -Only when `hydra-look-for-remap' is non nil." - (let ((remapped-cmd (if hydra-look-for-remap - (command-remapping `,cmd) - nil))) - (if remapped-cmd - (call-interactively `,remapped-cmd) - (call-interactively `,cmd)))) - -(defun hydra--call-interactively (cmd name) - "Generate a `call-interactively' statement for CMD. -Set `this-command' to NAME." - (if (and (symbolp name) - (not (memq name '(nil body)))) - `(progn - (setq this-command ',name) - (hydra--call-interactively-remap-maybe #',cmd)) - `(hydra--call-interactively-remap-maybe #',cmd))) - -(defun hydra--make-defun (name body doc head - keymap body-pre body-before-exit - &optional body-after-exit) - "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 is added to the start of the wrapper. -BODY-BEFORE-EXIT will be called before the hydra quits. -BODY-AFTER-EXIT is added to the end of the wrapper." - (let ((cmd-name (hydra--head-name head name)) - (cmd (when (car head) - (hydra--make-callable - (cadr head)))) - (doc (if (car head) - (format "Call the head `%S' in the \"%s\" hydra.\n\n%s" - (cadr head) name doc) - (format "Call the body in the \"%s\" hydra.\n\n%s" - name doc))) - (hint (intern (format "%S/hint" name))) - (body-foreign-keys (hydra--body-foreign-keys body)) - (body-timeout (plist-get body :timeout)) - (body-idle (plist-get body :idle))) - `(defun ,cmd-name () - ,doc - (interactive) - (require 'hydra) - (hydra-default-pre) - ,@(when body-pre (list body-pre)) - ,@(if (hydra--head-property head :exit) - `((hydra-keyboard-quit) - (setq hydra-curr-body-fn ',(intern (format "%S/body" name))) - ,@(if body-after-exit - `((unwind-protect - ,(when cmd - (hydra--call-interactively cmd (cadr head))) - ,body-after-exit)) - (when cmd - `(,(hydra--call-interactively cmd (cadr head)))))) - (delq - nil - `((let ((hydra--ignore ,(not (eq (cadr head) 'body)))) - (hydra-keyboard-quit) - (setq hydra-curr-body-fn ',(intern (format "%S/body" name)))) - ,(when cmd - `(condition-case err - ,(hydra--call-interactively cmd (cadr head)) - ((quit error) - (message (error-message-string err))))) - ,(if (and body-idle (eq (cadr head) 'body)) - `(hydra-idle-message ,body-idle ,hint ',name) - `(hydra-show-hint ,hint ',name)) - (hydra-set-transient-map - ,keymap - (lambda () (hydra-keyboard-quit) ,body-before-exit) - ,(when body-foreign-keys - (list 'quote body-foreign-keys))) - ,body-after-exit - ,(when body-timeout - `(hydra-timeout ,body-timeout)))))))) - -(defvar hydra-props-alist nil) - -(defun hydra-set-property (name key val) - "Set hydra property. -NAME is the symbolic name of the hydra. -KEY and VAL are forwarded to `plist-put'." - (let ((entry (assoc name hydra-props-alist)) - plist) - (when (null entry) - (add-to-list 'hydra-props-alist (list name)) - (setq entry (assoc name hydra-props-alist))) - (setq plist (cdr entry)) - (setcdr entry (plist-put plist key val)))) - -(defun hydra-get-property (name key) - "Get hydra property. -NAME is the symbolic name of the hydra. -KEY is forwarded to `plist-get'." - (let ((entry (assoc name hydra-props-alist))) - (when entry - (plist-get (cdr entry) key)))) - -(defun hydra-show-hint (hint caller) - (let ((verbosity (plist-get (cdr (assoc caller hydra-props-alist)) - :verbosity))) - (cond ((eq verbosity 0)) - ((eq verbosity 1) - (message (eval hint))) - (t - (when hydra-is-helpful - (funcall - (nth 1 (assoc hydra-hint-display-type hydra-hint-display-alist)) - (eval hint))))))) - -(defmacro hydra--make-funcall (sym) - "Transform SYM into a `funcall' to call it." - `(when (and ,sym (symbolp ,sym)) - (setq ,sym `(funcall #',,sym)))) - -(defun hydra--head-name (h name) - "Return the symbol for head H of hydra with NAME." - (let ((str (format "%S/%s" name - (cond ((symbolp (cadr h)) - (cadr h)) - ((and (consp (cadr h)) - (eq (cl-caadr h) 'function)) - (cadr (cadr h))) - (t - (concat "lambda-" (car h))))))) - (when (and (hydra--head-property h :exit) - (not (memq (cadr h) '(body nil)))) - (setq str (concat str "-and-exit"))) - (intern str))) - -(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 . nil) . hydra-repeat))) - res entry) - (dolist (h heads) - (if (setq entry (assoc (cons (cadr h) - (hydra--head-property h :exit)) - ali)) - (setf (cl-cdddr h) (plist-put (cl-cdddr h) :cmd-name (cdr entry))) - (push (cons (cons (cadr h) - (hydra--head-property h :exit)) - (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))))) - -(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--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")) - -(defvar hydra-cell-format "% -20s %% -8`%s" - "The default format for docstring cells.") - -(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)))) - -;; Following functions deal with automatic docstring table generation from :column head property -(defun hydra--normalize-heads (heads) - "Ensure each head from HEADS have a property :column. -Set it to the same value as preceding head or nil if no previous value -was defined." - (let ((current-col nil)) - (mapcar (lambda (head) - (if (hydra--head-has-property head :column) - (setq current-col (hydra--head-property head :column))) - (hydra--head-set-property head :column current-col)) - heads))) - -(defun hydra--sort-heads (normalized-heads) - "Return a list of heads with non-nil doc grouped by column property. -Each head of NORMALIZED-HEADS must have a column property." - (let* ((heads-wo-nil-doc (cl-remove-if-not (lambda (head) (nth 2 head)) normalized-heads)) - (columns-list (delete-dups (mapcar (lambda (head) (hydra--head-property head :column)) - normalized-heads))) - (get-col-index-fun (lambda (head) (cl-position (hydra--head-property head :column) - columns-list - :test 'equal))) - (heads-sorted (cl-sort heads-wo-nil-doc (lambda (it other) - (< (funcall get-col-index-fun it) - (funcall get-col-index-fun other)))))) - ;; this operation partition the sorted head list into lists of heads with same column property - (cl-loop for head in heads-sorted - for column-name = (hydra--head-property head :column) - with prev-column-name = (hydra--head-property (nth 0 heads-sorted) :column) - unless (equal prev-column-name column-name) collect heads-one-column into heads-all-columns - and do (setq heads-one-column nil) - collect head into heads-one-column - do (setq prev-column-name column-name) - finally return (append heads-all-columns (list heads-one-column))))) - -(defun hydra--pad-heads (heads-groups padding-head) - "Return a copy of HEADS-GROUPS padded where applicable with PADDING-HEAD." - (cl-loop for heads-group in heads-groups - for this-head-group-length = (length heads-group) - with head-group-max-length = (apply #'max (mapcar (lambda (heads) (length heads)) heads-groups)) - if (<= this-head-group-length head-group-max-length) - collect (append heads-group (make-list (- head-group-max-length this-head-group-length) padding-head)) - into balanced-heads-groups - else collect heads-group into balanced-heads-groups - finally return balanced-heads-groups)) - -(defun hydra--generate-matrix (heads-groups) - "Return a copy of HEADS-GROUPS decorated with table formating information. -Details of modification: -2 virtual heads acting as table header were added to each heads-group. -Each head is decorated with 2 new properties max-doc-len and max-key-len -representing the maximum dimension of their owning group. - Every heads-group have equal length by adding padding heads where applicable." - (when heads-groups - (let ((res nil)) - (dolist (heads-group (hydra--pad-heads heads-groups '(" " nil " " :exit t))) - (let* ((column-name (hydra--head-property (nth 0 heads-group) :column)) - (max-key-len (apply #'max (mapcar (lambda (x) (length (car x))) heads-group))) - (max-doc-len (apply #'max - (length column-name) - (mapcar (lambda (x) (length (hydra--to-string (nth 2 x)))) heads-group))) - (header-virtual-head `(" " nil ,column-name :column ,column-name :exit t)) - (separator-virtual-head `(" " nil ,(make-string (+ 2 max-doc-len max-key-len) ?-) :column ,column-name :exit t)) - (decorated-heads (copy-tree (apply 'list header-virtual-head separator-virtual-head heads-group)))) - (push (mapcar (lambda (it) - (hydra--head-set-property it :max-key-len max-key-len) - (hydra--head-set-property it :max-doc-len max-doc-len)) - decorated-heads) res))) - (nreverse res)))) - -(defun hydra-interpose (x lst) - "Insert X in between each element of LST." - (let (res y) - (while (setq y (pop lst)) - (push y res) - (push x res)) - (nreverse (cdr res)))) - -(defun hydra--hint-row (heads body) - (let ((lst (hydra-interpose - "| " - (mapcar (lambda (head) - (funcall hydra-key-doc-function - (hydra-fontify-head head body) - (let ((n (hydra--head-property head :max-key-len))) - (+ n (cl-count ?% (car head)))) - (nth 2 head) ;; doc - (hydra--head-property head :max-doc-len))) - heads)))) - (when (stringp (car (last lst))) - (let ((len (length lst)) - (new-last (replace-regexp-in-string "\s+$" "" (car (last lst))))) - (when (= 0 (length (setf (nth (- len 1) lst) new-last))) - (setf (nth (- len 2) lst) "|")))) - lst)) - - -(defun hydra--hint-from-matrix (body heads-matrix) - "Generate a formated table-style docstring according to BODY and HEADS-MATRIX. -HEADS-MATRIX is expected to be a list of heads with following features: -Each heads must have the same length -Each head must have a property max-key-len and max-doc-len." - (when heads-matrix - (let ((lines (hydra--hint-from-matrix-1 body heads-matrix))) - `(,@(apply #'append (hydra-interpose '("\n") lines)) - "\n")))) - -(defun hydra--hint-from-matrix-1 (body heads-matrix) - (let* ((first-heads-col (nth 0 heads-matrix)) - (last-row-index (- (length first-heads-col) 1)) - (lines nil)) - (dolist (row-index (number-sequence 0 last-row-index)) - (let ((heads-in-row (mapcar - (lambda (heads) (nth row-index heads)) - heads-matrix))) - (push (hydra--hint-row heads-in-row body) - lines))) - (nreverse lines))) - -(defun hydra-idle-message (secs hint name) - "In SECS seconds display HINT." - (cancel-timer hydra-message-timer) - (setq hydra-message-timer (timer-create)) - (timer-set-time hydra-message-timer - (timer-relative-time (current-time) secs)) - (timer-set-function - hydra-message-timer - (lambda () - (hydra-show-hint hint name) - (cancel-timer hydra-message-timer))) - (timer-activate hydra-message-timer)) - -(defun hydra-timeout (secs &optional function) - "In SECS seconds call FUNCTION, then function `hydra-keyboard-quit'. -Cancel the previous `hydra-timeout'." - (cancel-timer hydra-timeout-timer) - (setq hydra-timeout-timer (timer-create)) - (timer-set-time hydra-timeout-timer - (timer-relative-time (current-time) secs)) - (timer-set-function - hydra-timeout-timer - `(lambda () - ,(when function - `(funcall ,function)) - (hydra-keyboard-quit))) - (timer-activate hydra-timeout-timer)) - -;;* Macros -;;;###autoload -(defmacro defhydra (name body &optional docstring &rest heads) - "Create a Hydra - a family of functions with prefix NAME. - -NAME should be a symbol, it will be the prefix of all functions -defined here. - -BODY has the format: - - (BODY-MAP BODY-KEY &rest BODY-PLIST) - -DOCSTRING will be displayed in the echo area to identify the -Hydra. When DOCSTRING starts with a newline, special Ruby-style -substitution will be performed by `hydra--format'. - -Functions are created on basis of HEADS, each of which has the -format: - - (KEY CMD &optional HINT &rest PLIST) - -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 (both are strings passed to `kbd'), and will set -the transient map so that all following heads can be called -though KEY only. BODY-KEY can be an empty string. - -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 BODY-PLIST and are allowed to -override some keys. The keys recognized are :exit, :bind, and :column. -:exit can be: - -- nil (default): this head will continue the Hydra state. -- t: this head will 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. - -:column is a string that sets the column for all subsequent heads. - -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) (doc-string 3)) - (setq heads (copy-tree heads)) - (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 ""))) - (when (keywordp (car body)) - (setq body (cons nil (cons nil body)))) - (setq body (hydra--normalize-body body)) - (condition-case-unless-debug err - (let* ((keymap-name (intern (format "%S/keymap" name))) - (body-name (intern (format "%S/body" name))) - (body-key (cadr body)) - (body-plist (cddr body)) - (base-map (or (eval (plist-get body-plist :base-map)) - hydra-base-map)) - (keymap (copy-keymap base-map)) - (body-map (or (car body) - (plist-get body-plist :bind))) - (body-pre (plist-get body-plist :pre)) - (body-body-pre (plist-get body-plist :body-pre)) - (body-before-exit (or (plist-get body-plist :post) - (plist-get body-plist :before-exit))) - (body-after-exit (plist-get body-plist :after-exit)) - (body-inherit (plist-get body-plist :inherit)) - (body-foreign-keys (hydra--body-foreign-keys body)) - (body-exit (hydra--body-exit body))) - (dolist (base body-inherit) - (setq heads (append heads (copy-sequence (eval base))))) - (dolist (h heads) - (let ((len (length h))) - (cond ((< len 2) - (error "Each head should have at least two items: %S" h)) - ((= len 2) - (setcdr (cdr h) - (list - (hydra-plist-get-default - body-plist :hint hydra-default-hint))) - (setcdr (nthcdr 2 h) (list :exit body-exit))) - (t - (let ((hint (cl-caddr h))) - (unless (or (null hint) - (stringp hint) - (consp hint)) - (let ((inherited-hint - (hydra-plist-get-default - body-plist :hint hydra-default-hint))) - (setcdr (cdr h) (cons - (if (eq 'none inherited-hint) - nil - inherited-hint) - (cddr h)))))) - (let ((hint-and-plist (cddr h))) - (if (null (cdr hint-and-plist)) - (setcdr hint-and-plist (list :exit body-exit)) - (let* ((plist (cl-cdddr h)) - (h-color (plist-get plist :color))) - (if h-color - (progn - (plist-put plist :exit - (cl-case h-color - ((blue teal) t) - (t nil))) - (cl-remf (cl-cdddr h) :color)) - (let ((h-exit (hydra-plist-get-default plist :exit 'default))) - (plist-put plist :exit - (if (eq h-exit 'default) - body-exit - h-exit)))))))))) - (plist-put (cl-cdddr h) :cmd-name (hydra--head-name h name)) - (when (null (cadr h)) (plist-put (cl-cdddr h) :exit t))) - (let ((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) - (hydra--make-funcall body-pre) - (hydra--make-funcall body-body-pre) - (hydra--make-funcall body-before-exit) - (hydra--make-funcall body-after-exit) - (when (memq body-foreign-keys '(run warn)) - (unless (cl-some - (lambda (h) - (hydra--head-property h :exit)) - heads) - (error - "An %S Hydra must have at least one blue head in order to exit" - body-foreign-keys))) - `(progn - (set (defvar ,(intern (format "%S/params" name)) - nil - ,(format "Params of %S." name)) - ',body) - (set (defvar ,(intern (format "%S/docstring" name)) - nil - ,(format "Docstring of %S." name)) - ,docstring) - (set (defvar ,(intern (format "%S/heads" name)) - nil - ,(format "Heads for %S." name)) - ',(mapcar (lambda (h) - (let ((j (copy-sequence h))) - (cl-remf (cl-cdddr j) :cmd-name) - j)) - heads)) - ;; create keymap - (set (defvar ,keymap-name - nil - ,(format "Keymap for %S." name)) - ',keymap) - ;; declare heads - (set - (defvar ,(intern (format "%S/hint" name)) nil - ,(format "Dynamic hint for %S." name)) - ',(hydra--format name body docstring heads)) - ;; create defuns - ,@(mapcar - (lambda (head) - (hydra--make-defun name body doc head keymap-name - body-pre - body-before-exit - body-after-exit)) - heads-nodup) - ;; free up keymap prefix - ,@(unless (or (null body-key) - (null body-map) - (hydra--callablep body-map)) - `((unless (keymapp (lookup-key ,body-map (kbd ,body-key))) - (define-key ,body-map (kbd ,body-key) nil)))) - ;; bind keys - ,@(delq nil - (mapcar - (lambda (head) - (let ((name (hydra--head-property head :cmd-name))) - (when (and (cadr head) - (or body-key body-map)) - (let ((bind (hydra--head-property head :bind body-map)) - (final-key - (if body-key - (vconcat (kbd body-key) (kbd (car head))) - (kbd (car head))))) - (cond ((null bind) nil) - ((hydra--callablep bind) - `(funcall ,bind ,final-key (function ,name))) - ((and (symbolp bind) - (if (boundp bind) - (keymapp (symbol-value bind)) - t)) - `(define-key ,bind ,final-key (quote ,name))) - (t - (error "Invalid :bind property `%S' for head %S" bind head))))))) - heads)) - ,(hydra--make-defun - name body doc '(nil body) - keymap-name - (or body-body-pre body-pre) body-before-exit - '(setq prefix-arg current-prefix-arg))))) - (error - (hydra--complain "Error in defhydra %S: %s" name (cdr err)) - nil))) - -(defmacro defhydra+ (name body &optional docstring &rest heads) - "Redefine an existing hydra by adding new heads. -Arguments are same as of `defhydra'." - (declare (indent defun) (doc-string 3)) - (unless (stringp docstring) - (setq heads - (cons docstring heads)) - (setq docstring nil)) - `(defhydra ,name ,(or body (hydra--prop name "/params")) - ,(or docstring (hydra--prop name "/docstring")) - ,@(cl-delete-duplicates - (append (hydra--prop name "/heads") heads) - :key #'car - :test #'equal))) - -(defun hydra--prop (name prop-name) - (symbol-value (intern (concat (symbol-name name) prop-name)))) - -(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)))) - -(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)) - (cl-incf i))) - (error "Val not in range for %S" sym))) - (set sym - (aref range - (if (>= i l) - 0 - i))))) - -(defvar hydra-pause-ring (make-ring 10) - "Ring for paused hydras.") - -(defun hydra-pause-resume () - "Quit the current hydra and save it to the stack. -If there's no active hydra, pop one from the stack and call its body. -If the stack is empty, call the last hydra's body." - (interactive) - (cond (hydra-curr-map - (ring-insert hydra-pause-ring hydra-curr-body-fn) - (hydra-keyboard-quit)) - ((zerop (ring-length hydra-pause-ring)) - (funcall hydra-curr-body-fn)) - (t - (funcall (ring-remove hydra-pause-ring 0))))) - -;; Local Variables: -;; outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|###autoload\\)\\|(" -;; indent-tabs-mode: nil -;; End: - -(provide 'hydra) - -;;; hydra.el ends here diff --git a/elpa/hydra-20191125.955/hydra-autoloads.el b/elpa/hydra-20191125.955/hydra-autoloads.el new file mode 100644 index 00000000..66f654e9 --- /dev/null +++ b/elpa/hydra-20191125.955/hydra-autoloads.el @@ -0,0 +1,99 @@ +;;; hydra-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "hydra" "hydra.el" (0 0 0 0)) +;;; Generated autoloads from hydra.el + +(autoload 'defhydra "hydra" "\ +Create a Hydra - a family of functions with prefix NAME. + +NAME should be a symbol, it will be the prefix of all functions +defined here. + +BODY has the format: + + (BODY-MAP BODY-KEY &rest BODY-PLIST) + +DOCSTRING will be displayed in the echo area to identify the +Hydra. When DOCSTRING starts with a newline, special Ruby-style +substitution will be performed by `hydra--format'. + +Functions are created on basis of HEADS, each of which has the +format: + + (KEY CMD &optional HINT &rest PLIST) + +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 (both are strings passed to `kbd'), and will set +the transient map so that all following heads can be called +though KEY only. BODY-KEY can be an empty string. + +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 BODY-PLIST and are allowed to +override some keys. The keys recognized are :exit, :bind, and :column. +:exit can be: + +- nil (default): this head will continue the Hydra state. +- t: this head will 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. + +:column is a string that sets the column for all subsequent heads. + +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'. + +\(fn NAME BODY &optional DOCSTRING &rest HEADS)" nil t) + +(function-put 'defhydra 'lisp-indent-function 'defun) + +(function-put 'defhydra 'doc-string-elt '3) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hydra" '("hydra-" "defhydra"))) + +;;;*** + +;;;### (autoloads nil "hydra-examples" "hydra-examples.el" (0 0 0 +;;;;;; 0)) +;;; Generated autoloads from hydra-examples.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hydra-examples" '("hydra-" "org-agenda-cts" "whitespace-mode"))) + +;;;*** + +;;;### (autoloads nil "hydra-ox" "hydra-ox.el" (0 0 0 0)) +;;; Generated autoloads from hydra-ox.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "hydra-ox" '("hydra-ox"))) + +;;;*** + +;;;### (autoloads nil nil ("hydra-pkg.el") (0 0 0 0)) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; hydra-autoloads.el ends here diff --git a/elpa/hydra-20191125.955/hydra-examples.el b/elpa/hydra-20191125.955/hydra-examples.el new file mode 100644 index 00000000..5262ec60 --- /dev/null +++ b/elpa/hydra-20191125.955/hydra-examples.el @@ -0,0 +1,393 @@ +;;; hydra-examples.el --- Some applications for 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 . + +;;; Commentary: +;; +;; These are the sample Hydras. +;; +;; If you want to use them plainly, set `hydra-examples-verbatim' to t +;; before requiring this file. But it's probably better to only look +;; at them and use them as templates for building your own. + +;;; Code: + +(require 'hydra) + +;;* Examples +;;** Example 1: text scale +(when (bound-and-true-p hydra-examples-verbatim) + (defhydra hydra-zoom (global-map "") + "zoom" + ("g" text-scale-increase "in") + ("l" text-scale-decrease "out"))) + +;; This example generates three commands: +;; +;; `hydra-zoom/text-scale-increase' +;; `hydra-zoom/text-scale-decrease' +;; `hydra-zoom/body' +;; +;; In addition, two of them are bound like this: +;; +;; (global-set-key (kbd " g") 'hydra-zoom/text-scale-increase) +;; (global-set-key (kbd " l") 'hydra-zoom/text-scale-decrease) +;; +;; Note that you can substitute `global-map' with e.g. `emacs-lisp-mode-map' if you need. +;; The functions generated will be the same, except the binding code will change to: +;; +;; (define-key emacs-lisp-mode-map [f2 103] +;; (function hydra-zoom/text-scale-increase)) +;; (define-key emacs-lisp-mode-map [f2 108] +;; (function hydra-zoom/text-scale-decrease)) + +;;** Example 2: move window splitter +(when (bound-and-true-p hydra-examples-verbatim) + (defhydra hydra-splitter (global-map "C-M-s") + "splitter" + ("h" hydra-move-splitter-left) + ("j" hydra-move-splitter-down) + ("k" hydra-move-splitter-up) + ("l" hydra-move-splitter-right))) + +;;** Example 3: jump to error +(when (bound-and-true-p hydra-examples-verbatim) + (defhydra hydra-error (global-map "M-g") + "goto-error" + ("h" first-error "first") + ("j" next-error "next") + ("k" previous-error "prev") + ("v" recenter-top-bottom "recenter") + ("q" nil "quit"))) + +;; This example introduces only one new thing: since the command +;; passed to the "q" head is nil, it will quit the Hydra without doing +;; anything. Heads that quit the Hydra instead of continuing are +;; referred to as having blue :color. All the other heads have red +;; :color, unless other is specified. + +;;** Example 4: toggle rarely used modes +(when (bound-and-true-p hydra-examples-verbatim) + (defvar whitespace-mode nil) + (global-set-key + (kbd "C-c C-v") + (defhydra hydra-toggle-simple (:color blue) + "toggle" + ("a" abbrev-mode "abbrev") + ("d" toggle-debug-on-error "debug") + ("f" auto-fill-mode "fill") + ("t" toggle-truncate-lines "truncate") + ("w" whitespace-mode "whitespace") + ("q" nil "cancel")))) + +;; Note that in this case, `defhydra' returns the `hydra-toggle-simple/body' +;; symbol, which is then passed to `global-set-key'. +;; +;; Another new thing is that both the keymap and the body prefix are +;; skipped. This means that `defhydra' will bind nothing - that's why +;; `global-set-key' is necessary. +;; +;; One more new thing is that you can assign a :color to the body. All +;; heads will inherit this color. The code above is very much equivalent to: +;; +;; (global-set-key (kbd "C-c C-v a") 'abbrev-mode) +;; (global-set-key (kbd "C-c C-v d") 'toggle-debug-on-error) +;; +;; The differences are: +;; +;; * You get a hint immediately after "C-c C-v" +;; * You can cancel and call a command immediately, e.g. "C-c C-v C-n" +;; is equivalent to "C-n" with Hydra approach, while it will error +;; that "C-c C-v C-n" isn't bound with the usual approach. + +;;** Example 5: mini-vi +(defun hydra-vi/pre () + (set-cursor-color "#e52b50")) + +(defun hydra-vi/post () + (set-cursor-color "#ffffff")) + +(when (bound-and-true-p hydra-examples-verbatim) + (global-set-key + (kbd "C-z") + (defhydra hydra-vi (:pre hydra-vi/pre :post hydra-vi/post :color amaranth) + "vi" + ("l" forward-char) + ("h" backward-char) + ("j" next-line) + ("k" previous-line) + ("m" set-mark-command "mark") + ("a" move-beginning-of-line "beg") + ("e" move-end-of-line "end") + ("d" delete-region "del" :color blue) + ("y" kill-ring-save "yank" :color blue) + ("q" nil "quit"))) + (hydra-set-property 'hydra-vi :verbosity 1)) + +;; This example introduces :color amaranth. It's similar to red, +;; except while you can quit red with any binding which isn't a Hydra +;; head, you can quit amaranth only with a blue head. So you can quit +;; this mode only with "d", "y", "q" or "C-g". +;; +;; Another novelty are the :pre and :post handlers. :pre will be +;; called before each command, while :post will be called when the +;; Hydra quits. In this case, they're used to override the cursor +;; color while Hydra is active. + +;;** Example 6: selective global bind +(when (bound-and-true-p hydra-examples-verbatim) + (defhydra hydra-next-error (global-map "C-x") + "next-error" + ("`" next-error "next") + ("j" next-error "next" :bind nil) + ("k" previous-error "previous" :bind nil))) + +;; 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 +(defvar whitespace-mode nil) +(defhydra hydra-toggle (:color pink) + " +_a_ abbrev-mode: %`abbrev-mode +_d_ debug-on-error: %`debug-on-error +_f_ auto-fill-mode: %`auto-fill-function +_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) + ("t" toggle-truncate-lines nil) + ("w" whitespace-mode nil) + ("q" nil "quit")) +;; Recommended binding: +;; (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 + :hint nil) + " +^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) + ("u" Buffer-menu-unmark) + ("U" Buffer-menu-backup-unmark) + ("d" Buffer-menu-delete) + ("D" Buffer-menu-delete-backwards) + ("s" Buffer-menu-save) + ("~" Buffer-menu-not-modified) + ("x" Buffer-menu-execute) + ("b" Buffer-menu-bury) + ("g" revert-buffer) + ("T" Buffer-menu-toggle-files-only) + ("O" Buffer-menu-multi-occur :color blue) + ("I" Buffer-menu-isearch-buffers :color blue) + ("R" Buffer-menu-isearch-buffers-regexp :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: +(defvar dired-mode-map) +(declare-function dired-mark "dired") +(when (bound-and-true-p hydra-examples-verbatim) + (require '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). + +;;** Example 10: apropos family +(defhydra hydra-apropos (:color blue + :hint nil) + " +_a_propos _c_ommand +_d_ocumentation _l_ibrary +_v_ariable _u_ser-option +^ ^ valu_e_" + ("a" apropos) + ("d" apropos-documentation) + ("v" apropos-variable) + ("c" apropos-command) + ("l" apropos-library) + ("u" apropos-user-option) + ("e" apropos-value)) +;; Recommended binding: +;; (global-set-key (kbd "C-c h") 'hydra-apropos/body) + +;;** Example 11: rectangle-mark-mode +(require 'rect) +(defhydra hydra-rectangle (:body-pre (rectangle-mark-mode 1) + :color pink + :post (deactivate-mark)) + " + ^_k_^ _d_elete _s_tring +_h_ _l_ _o_k _y_ank + ^_j_^ _n_ew-copy _r_eset +^^^^ _e_xchange _u_ndo +^^^^ ^ ^ _x_kill +" + ("h" rectangle-backward-char nil) + ("l" rectangle-forward-char nil) + ("k" rectangle-previous-line nil) + ("j" rectangle-next-line nil) + ("e" hydra-ex-point-mark nil) + ("n" copy-rectangle-as-kill nil) + ("d" delete-rectangle nil) + ("r" (if (region-active-p) + (deactivate-mark) + (rectangle-mark-mode 1)) nil) + ("y" yank-rectangle nil) + ("u" undo nil) + ("s" string-rectangle nil) + ("x" kill-rectangle nil) + ("o" nil nil)) + +;; Recommended binding: +;; (global-set-key (kbd "C-x SPC") 'hydra-rectangle/body) + +;;** Example 12: org-agenda-view +(defun org-agenda-cts () + (and (eq major-mode 'org-agenda-mode) + (let ((args (get-text-property + (min (1- (point-max)) (point)) + 'org-last-args))) + (nth 2 args)))) + +(defhydra hydra-org-agenda-view (:hint none) + " +_d_: ?d? day _g_: time grid=?g? _a_: arch-trees +_w_: ?w? week _[_: inactive _A_: arch-files +_t_: ?t? fortnight _f_: follow=?f? _r_: clock report=?r? +_m_: ?m? month _e_: entry text=?e? _D_: include diary=?D? +_y_: ?y? year _q_: quit _L__l__c_: log = ?l?" + ("SPC" org-agenda-reset-view) + ("d" org-agenda-day-view (if (eq 'day (org-agenda-cts)) "[x]" "[ ]")) + ("w" org-agenda-week-view (if (eq 'week (org-agenda-cts)) "[x]" "[ ]")) + ("t" org-agenda-fortnight-view (if (eq 'fortnight (org-agenda-cts)) "[x]" "[ ]")) + ("m" org-agenda-month-view (if (eq 'month (org-agenda-cts)) "[x]" "[ ]")) + ("y" org-agenda-year-view (if (eq 'year (org-agenda-cts)) "[x]" "[ ]")) + ("l" org-agenda-log-mode (format "% -3S" org-agenda-show-log)) + ("L" (org-agenda-log-mode '(4))) + ("c" (org-agenda-log-mode 'clockcheck)) + ("f" org-agenda-follow-mode (format "% -3S" org-agenda-follow-mode)) + ("a" org-agenda-archives-mode) + ("A" (org-agenda-archives-mode 'files)) + ("r" org-agenda-clockreport-mode (format "% -3S" org-agenda-clockreport-mode)) + ("e" org-agenda-entry-text-mode (format "% -3S" org-agenda-entry-text-mode)) + ("g" org-agenda-toggle-time-grid (format "% -3S" org-agenda-use-time-grid)) + ("D" org-agenda-toggle-diary (format "% -3S" org-agenda-include-diary)) + ("!" org-agenda-toggle-deadlines) + ("[" (let ((org-agenda-include-inactive-timestamps t)) + (org-agenda-check-type t 'timeline 'agenda) + (org-agenda-redo) + (message "Display now includes inactive timestamps as well"))) + ("q" (message "Abort") :exit t) + ("v" nil)) + +;; Recommended binding: +;; (define-key org-agenda-mode-map "v" 'hydra-org-agenda-view/body) + +;;** Example 13: automatic columns +(defhydra hydra-movement () + ("j" next-line "down" :column "Vertical") + ("k" previous-line "up") + ("l" forward-char "forward" :column "Horizontal") + ("h" backward-char "back")) + +;;* Helpers +(require 'windmove) + +(defun hydra-move-splitter-left (arg) + "Move window splitter left." + (interactive "p") + (if (let ((windmove-wrap-around)) + (windmove-find-other-window 'right)) + (shrink-window-horizontally arg) + (enlarge-window-horizontally arg))) + +(defun hydra-move-splitter-right (arg) + "Move window splitter right." + (interactive "p") + (if (let ((windmove-wrap-around)) + (windmove-find-other-window 'right)) + (enlarge-window-horizontally arg) + (shrink-window-horizontally arg))) + +(defun hydra-move-splitter-up (arg) + "Move window splitter up." + (interactive "p") + (if (let ((windmove-wrap-around)) + (windmove-find-other-window 'up)) + (enlarge-window arg) + (shrink-window arg))) + +(defun hydra-move-splitter-down (arg) + "Move window splitter down." + (interactive "p") + (if (let ((windmove-wrap-around)) + (windmove-find-other-window 'up)) + (shrink-window arg) + (enlarge-window arg))) + +(defvar rectangle-mark-mode) +(defun hydra-ex-point-mark () + "Exchange point and mark." + (interactive) + (if rectangle-mark-mode + (rectangle-exchange-point-and-mark) + (let ((mk (mark))) + (rectangle-mark-mode 1) + (goto-char mk)))) + +(provide 'hydra-examples) + +;; Local Variables: +;; no-byte-compile: t +;; End: +;;; hydra-examples.el ends here diff --git a/elpa/hydra-20191125.955/hydra-ox.el b/elpa/hydra-20191125.955/hydra-ox.el new file mode 100644 index 00000000..a992efc2 --- /dev/null +++ b/elpa/hydra-20191125.955/hydra-ox.el @@ -0,0 +1,127 @@ +;;; 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 . + +;;; Commentary: +;; +;; This shows how a complex dispatch menu can be built with Hydra. + +;;; Code: + +(require 'hydra) +(require 'org) +(declare-function org-html-export-as-html 'ox-html) +(declare-function org-html-export-to-html 'ox-html) +(declare-function org-latex-export-as-latex 'ox-latex) +(declare-function org-latex-export-to-latex 'ox-latex) +(declare-function org-latex-export-to-pdf 'ox-latex) +(declare-function org-ascii-export-as-ascii 'ox-ascii) +(declare-function org-ascii-export-to-ascii 'ox-ascii) + +(defhydradio hydra-ox () + (body-only "Export only the body.") + (export-scope "Export scope." [buffer subtree]) + (async-export "When non-nil, export async.") + (visible-only "When non-nil, export visible only") + (force-publishing "Toggle 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/elpa/hydra-20191125.955/hydra-pkg.el b/elpa/hydra-20191125.955/hydra-pkg.el new file mode 100644 index 00000000..a6887567 --- /dev/null +++ b/elpa/hydra-20191125.955/hydra-pkg.el @@ -0,0 +1,13 @@ +(define-package "hydra" "20191125.955" "Make bindings that stick around." + '((cl-lib "0.5") + (lv "0")) + :keywords + '("bindings") + :authors + '(("Oleh Krehel" . "ohwoeowho@gmail.com")) + :maintainer + '("Oleh Krehel" . "ohwoeowho@gmail.com") + :url "https://github.com/abo-abo/hydra") +;; Local Variables: +;; no-byte-compile: t +;; End: diff --git a/elpa/hydra-20191125.955/hydra.el b/elpa/hydra-20191125.955/hydra.el new file mode 100644 index 00000000..35085327 --- /dev/null +++ b/elpa/hydra-20191125.955/hydra.el @@ -0,0 +1,1547 @@ +;;; hydra.el --- Make bindings that stick around. -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2019 Free Software Foundation, Inc. + +;; Author: Oleh Krehel +;; Maintainer: Oleh Krehel +;; URL: https://github.com/abo-abo/hydra +;; Version: 0.15.0 +;; Keywords: bindings +;; Package-Requires: ((cl-lib "0.5") (lv "0")) + +;; 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 . + +;;; Commentary: +;; +;; This package can be used to tie related commands into a family of +;; short bindings with a common prefix - a Hydra. +;; +;; Once you summon the Hydra (through the prefixed binding), all the +;; heads can be called in succession with only a short extension. +;; The Hydra is vanquished once Hercules, any binding that isn't the +;; Hydra's head, arrives. Note that Hercules, besides vanquishing the +;; Hydra, will still serve his original purpose, calling his proper +;; command. This makes the Hydra very seamless, it's like a minor +;; mode that disables itself automagically. +;; +;; Here's an example Hydra, bound in the global map (you can use any +;; keymap in place of `global-map'): +;; +;; (defhydra hydra-zoom (global-map "") +;; "zoom" +;; ("g" text-scale-increase "in") +;; ("l" text-scale-decrease "out")) +;; +;; It allows to start a command chain either like this: +;; " gg4ll5g", or " lgllg". +;; +;; Here's another approach, when you just want a "callable keymap": +;; +;; (defhydra hydra-toggle (:color blue) +;; "toggle" +;; ("a" abbrev-mode "abbrev") +;; ("d" toggle-debug-on-error "debug") +;; ("f" auto-fill-mode "fill") +;; ("t" toggle-truncate-lines "truncate") +;; ("w" whitespace-mode "whitespace") +;; ("q" nil "cancel")) +;; +;; This binds nothing so far, but if you follow up with: +;; +;; (global-set-key (kbd "C-c C-v") 'hydra-toggle/body) +;; +;; you will have bound "C-c C-v a", "C-c C-v d" etc. +;; +;; Knowing that `defhydra' defines e.g. `hydra-toggle/body' command, +;; you can nest Hydras if you wish, with `hydra-toggle/body' possibly +;; becoming a blue head of another Hydra. +;; +;; If you want to learn all intricacies of using `defhydra' without +;; having to figure it all out from this source code, check out the +;; wiki: https://github.com/abo-abo/hydra/wiki. There's a wealth of +;; information there. Everyone is welcome to bring the existing pages +;; up to date and add new ones. +;; +;; Additionally, the file hydra-examples.el serves to demo most of the +;; functionality. + +;;; Code: +;;* Requires +(require 'cl-lib) +(require 'lv) +(require 'ring) + +(defvar hydra-curr-map nil + "The keymap of the current Hydra called.") + +(defvar hydra-curr-on-exit nil + "The on-exit predicate for the current Hydra.") + +(defvar hydra-curr-foreign-keys nil + "The current :foreign-keys behavior.") + +(defvar hydra-curr-body-fn nil + "The current hydra-.../body function.") + +(defvar hydra-deactivate nil + "If a Hydra head sets this to t, exit the Hydra. +This will be done even if the head wasn't designated for exiting.") + +(defvar hydra-amaranth-warn-message "An amaranth Hydra can only exit through a blue head" + "Amaranth Warning message. Shown when the user tries to press an unbound/non-exit key while in an amaranth head.") + +(defun hydra-set-transient-map (keymap on-exit &optional foreign-keys) + "Set KEYMAP to the highest priority. + +Call ON-EXIT when the KEYMAP is deactivated. + +FOREIGN-KEYS determines the deactivation behavior, when a command +that isn't in KEYMAP is called: + +nil: deactivate KEYMAP and run the command. +run: keep KEYMAP and run the command. +warn: keep KEYMAP and issue a warning instead of running the command." + (if hydra-deactivate + (hydra-keyboard-quit) + (setq hydra-curr-map keymap) + (setq hydra-curr-on-exit on-exit) + (setq hydra-curr-foreign-keys foreign-keys) + (add-hook 'pre-command-hook 'hydra--clearfun) + (internal-push-keymap keymap 'overriding-terminal-local-map))) + +(defun hydra--clearfun () + "Disable the current Hydra unless `this-command' is a head." + (unless (eq this-command 'hydra-pause-resume) + (when (or + (memq this-command '(handle-switch-frame + keyboard-quit)) + (null overriding-terminal-local-map) + (not (or (eq this-command + (lookup-key hydra-curr-map (this-single-command-keys))) + (cl-case hydra-curr-foreign-keys + (warn + (setq this-command 'hydra-amaranth-warn)) + (run + t) + (t nil))))) + (hydra-disable)))) + +(defvar hydra--ignore nil + "When non-nil, don't call `hydra-curr-on-exit'.") + +(defvar hydra--input-method-function nil + "Store overridden `input-method-function' here.") + +(defun hydra-disable () + "Disable the current Hydra." + (setq hydra-deactivate nil) + (remove-hook 'pre-command-hook 'hydra--clearfun) + (unless hydra--ignore + (if (fboundp 'remove-function) + (remove-function input-method-function #'hydra--imf) + (when hydra--input-method-function + (setq input-method-function hydra--input-method-function) + (setq hydra--input-method-function nil)))) + (dolist (frame (frame-list)) + (with-selected-frame frame + (when overriding-terminal-local-map + (internal-pop-keymap hydra-curr-map 'overriding-terminal-local-map)))) + (unless hydra--ignore + (when hydra-curr-on-exit + (let ((on-exit hydra-curr-on-exit)) + (setq hydra-curr-on-exit nil) + (funcall on-exit))))) + +(unless (fboundp 'internal-push-keymap) + (defun internal-push-keymap (keymap symbol) + (let ((map (symbol-value symbol))) + (unless (memq keymap map) + (unless (memq 'add-keymap-witness (symbol-value symbol)) + (setq map (make-composed-keymap nil (symbol-value symbol))) + (push 'add-keymap-witness (cdr map)) + (set symbol map)) + (push keymap (cdr map)))))) + +(unless (fboundp 'internal-pop-keymap) + (defun internal-pop-keymap (keymap symbol) + (let ((map (symbol-value symbol))) + (when (memq keymap map) + (setf (cdr map) (delq keymap (cdr map)))) + (let ((tail (cddr map))) + (and (or (null tail) (keymapp tail)) + (eq 'add-keymap-witness (nth 1 map)) + (set symbol tail)))))) + +(defun hydra-amaranth-warn () + "Issue a warning that the current input was ignored." + (interactive) + (message hydra-amaranth-warn-message)) + +;;* Customize +(defgroup hydra nil + "Make bindings that stick around." + :group 'bindings + :prefix "hydra-") + +(defcustom hydra-is-helpful t + "When t, display a hint with possible bindings in the echo area." + :type 'boolean + :group 'hydra) + +(defcustom hydra-default-hint "" + "Default :hint property to use for heads when not specified in +the body or the head." + :type 'sexp + :group 'hydra) + +(declare-function posframe-show "posframe") +(declare-function posframe-hide "posframe") +(declare-function posframe-poshandler-window-center "posframe") + +(defvar hydra-posframe-show-params + '(:internal-border-width 1 + :internal-border-color "red" + :poshandler posframe-poshandler-window-center) + "List of parameters passed to `posframe-show'.") + +(defvar hydra--posframe-timer nil + "Timer for hiding posframe hint.") + +(defun hydra-posframe-show (str) + (require 'posframe) + (when hydra--posframe-timer + (cancel-timer hydra--posframe-timer)) + (setq hydra--posframe-timer nil) + (apply #'posframe-show + " *hydra-posframe*" + :string str + hydra-posframe-show-params)) + +(defun hydra-posframe-hide () + (require 'posframe) + (unless hydra--posframe-timer + (setq hydra--posframe-timer + (run-with-idle-timer + 0 nil (lambda () + (setq hydra--posframe-timer nil) + (posframe-hide " *hydra-posframe*")))))) + +(defvar hydra-hint-display-alist + (list (list 'lv #'lv-message #'lv-delete-window) + (list 'message #'message (lambda () (message ""))) + (list 'posframe #'hydra-posframe-show #'hydra-posframe-hide)) + "Store the functions for `hydra-hint-display-type'.") + +(defcustom hydra-hint-display-type 'lv + "The utility to show hydra hint" + :type '(choice + (const message) + (const lv) + (const posframe)) + :group 'hydra) + +(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_." + :type 'string) + +(defcustom hydra-doc-format-spec "%s" + "Default `format'-style specifier for ?a? syntax in docstrings." + :type 'string) + +(defcustom hydra-look-for-remap nil + "When non-nil, hydra binding behaves as keymap binding with [remap]. +When calling a head with a simple command, hydra will lookup for a potential +remap command according to the current active keymap and call it instead if +found" + :type 'boolean) + +(make-obsolete-variable + 'hydra-key-format-spec + "Since the docstrings are aligned by hand anyway, this isn't very useful." + "0.13.1") + +(defface hydra-face-red + '((t (:foreground "#FF0000" :bold t))) + "Red Hydra heads don't exit the Hydra. +Every other command exits the Hydra." + :group 'hydra) + +(defface hydra-face-blue + '((((class color) (background light)) + :foreground "#0000FF" :bold t) + (((class color) (background dark)) + :foreground "#8ac6f2" :bold t)) + "Blue Hydra heads exit the Hydra. +Every other command exits as well.") + +(defface hydra-face-amaranth + '((t (:foreground "#E52B50" :bold t))) + "Amaranth body has red heads and warns on intercepting non-heads. +Exitable only through a blue head.") + +(defface hydra-face-pink + '((t (:foreground "#FF6EB4" :bold t))) + "Pink body has red heads and runs intercepted non-heads. +Exitable only through a blue head.") + +(defface hydra-face-teal + '((t (:foreground "#367588" :bold t))) + "Teal body has blue heads and warns on intercepting non-heads. +Exitable 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))))) + +;;* Find Function +(eval-after-load 'find-func + '(defadvice find-function-search-for-symbol + (around hydra-around-find-function-search-for-symbol-advice + (symbol type library) activate) + "Navigate to hydras with `find-function-search-for-symbol'." + (prog1 ad-do-it + (when (symbolp symbol) + ;; The original function returns (cons (current-buffer) (point)) + ;; if it found the point. + (unless (cdr ad-return-value) + (with-current-buffer (find-file-noselect library) + (let ((sn (symbol-name symbol))) + (when (and (null type) + (string-match "\\`\\(hydra-[a-z-A-Z0-9]+\\)/\\(.*\\)\\'" sn) + (re-search-forward (concat "(defhydra " (match-string 1 sn)) + nil t)) + (goto-char (match-beginning 0))) + (cons (current-buffer) (point))))))))) + +;;* Universal Argument +(defvar hydra-base-map + (let ((map (make-sparse-keymap))) + (define-key map [?\C-u] 'hydra--universal-argument) + (define-key map [?-] 'hydra--negative-argument) + (define-key map [?0] 'hydra--digit-argument) + (define-key map [?1] 'hydra--digit-argument) + (define-key map [?2] 'hydra--digit-argument) + (define-key map [?3] 'hydra--digit-argument) + (define-key map [?4] 'hydra--digit-argument) + (define-key map [?5] 'hydra--digit-argument) + (define-key map [?6] 'hydra--digit-argument) + (define-key map [?7] 'hydra--digit-argument) + (define-key map [?8] 'hydra--digit-argument) + (define-key map [?9] 'hydra--digit-argument) + (define-key map [kp-0] 'hydra--digit-argument) + (define-key map [kp-1] 'hydra--digit-argument) + (define-key map [kp-2] 'hydra--digit-argument) + (define-key map [kp-3] 'hydra--digit-argument) + (define-key map [kp-4] 'hydra--digit-argument) + (define-key map [kp-5] 'hydra--digit-argument) + (define-key map [kp-6] 'hydra--digit-argument) + (define-key map [kp-7] 'hydra--digit-argument) + (define-key map [kp-8] 'hydra--digit-argument) + (define-key map [kp-9] 'hydra--digit-argument) + (define-key map [kp-subtract] 'hydra--negative-argument) + map) + "Keymap that all Hydras inherit. See `universal-argument-map'.") + +(defun hydra--universal-argument (arg) + "Forward to (`universal-argument' ARG)." + (interactive "P") + (setq prefix-arg (if (consp arg) + (list (* 4 (car arg))) + (if (eq arg '-) + (list -4) + '(4))))) + +(defun hydra--digit-argument (arg) + "Forward to (`digit-argument' ARG)." + (interactive "P") + (let* ((char (if (integerp last-command-event) + last-command-event + (get last-command-event 'ascii-character))) + (digit (- (logand char ?\177) ?0))) + (setq prefix-arg (cond ((integerp arg) + (+ (* arg 10) + (if (< arg 0) + (- digit) + digit))) + ((eq arg '-) + (if (zerop digit) + '- + (- digit))) + (t + digit))))) + +(defun hydra--negative-argument (arg) + "Forward to (`negative-argument' ARG)." + (interactive "P") + (setq prefix-arg (cond ((integerp arg) (- arg)) + ((eq arg '-) nil) + (t '-)))) + +;;* 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 (&optional arg) + "Repeat last command with last prefix arg. +When ARG is non-nil, use that instead." + (interactive "p") + (if (eq arg 1) + (unless (string-match "hydra-repeat$" (symbol-name last-command)) + (setq hydra-repeat--command last-command) + (setq hydra-repeat--prefix-arg last-prefix-arg)) + (setq hydra-repeat--prefix-arg arg)) + (setq current-prefix-arg hydra-repeat--prefix-arg) + (funcall hydra-repeat--command)) + +;;* Misc internals +(defun hydra--callablep (x) + "Test if X is callable." + (or (functionp x) + (and (consp x) + (memq (car x) '(function quote))))) + +(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." + (cond ((or (symbolp x) (functionp x)) + x) + ((and (consp x) (eq (car x) 'function)) + (cadr x)) + (t + `(lambda () + (interactive) + ,x)))) + +(defun hydra-plist-get-default (plist prop default) + "Extract a value from a property list. +PLIST is a property list, which is a list of the form +\(PROP1 VALUE1 PROP2 VALUE2...). + +Return the value corresponding to PROP, or DEFAULT if PROP is not +one of the properties on the list." + (if (memq prop plist) + (plist-get plist prop) + default)) + +(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." + (hydra-plist-get-default (cl-cdddr h) prop default)) + +(defun hydra--head-set-property (h prop value) + "In hydra Head H, set a property PROP to the value VALUE." + (cons (car h) (plist-put (cdr h) prop value))) + +(defun hydra--head-has-property (h prop) + "Return non nil if heads H has the property PROP." + (plist-member (cdr h) prop)) + +(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-exit (body) + "Return the exit behavior of BODY." + (or + (plist-get (cddr body) :exit) + (let ((color (plist-get (cddr body) :color))) + (cl-case color + ((blue teal) t) + (t nil))))) + +(defun hydra--normalize-body (body) + "Put BODY in a normalized format. +Add :exit and :foreign-keys if they are not there. +Remove :color key. And sort the plist alphabetically." + (let ((plist (cddr body))) + (plist-put plist :exit (hydra--body-exit body)) + (plist-put plist :foreign-keys (hydra--body-foreign-keys body)) + (let* ((alist0 (cl-loop for (k v) on plist + by #'cddr collect (cons k v))) + (alist1 (assq-delete-all :color alist0)) + (alist2 (cl-sort alist1 #'string< + :key (lambda (x) (symbol-name (car x)))))) + (append (list (car body) (cadr body)) + (cl-mapcan (lambda (x) (list (car x) (cdr x))) alist2))))) + +(defalias 'hydra--imf #'list) + +(defun hydra-default-pre () + "Default setup that happens in each head before :pre." + (when (eq input-method-function 'key-chord-input-method) + (if (fboundp 'add-function) + (add-function :override input-method-function #'hydra--imf) + (unless hydra--input-method-function + (setq hydra--input-method-function input-method-function) + (setq input-method-function nil))))) + +(defvar hydra-timeout-timer (timer-create) + "Timer for `hydra-timeout'.") + +(defvar hydra-message-timer (timer-create) + "Timer for the hint.") + +(defvar hydra--work-around-dedicated t + "When non-nil, assume there's no bug in `pop-to-buffer'. +`pop-to-buffer' should not select a dedicated window.") + +(defun hydra-keyboard-quit () + "Quitting function similar to `keyboard-quit'." + (interactive) + (hydra-disable) + (cancel-timer hydra-timeout-timer) + (cancel-timer hydra-message-timer) + (setq hydra-curr-map nil) + (unless (and hydra--ignore + (null hydra--work-around-dedicated)) + (funcall + (nth 2 (assoc hydra-hint-display-type hydra-hint-display-alist)))) + nil) + +(defvar hydra-head-format "[%s]: " + "The formatter for each head of a plain docstring.") + +(defvar hydra-key-doc-function 'hydra-key-doc-function-default + "The function for formatting key-doc pairs.") + +(defun hydra-key-doc-function-default (key key-width doc doc-width) + (cond + ((equal key " ") (format (format "%%-%ds" (+ 3 key-width doc-width)) doc)) + ((listp doc) + `(format ,(format "%%%ds: %%%ds" key-width (- -1 doc-width)) ,key ,doc)) + (t (format (format "%%%ds: %%%ds" key-width (- -1 doc-width)) key doc)))) + +(defun hydra--to-string (x) + (if (stringp x) + x + (eval x))) + +(defun hydra--eval-and-format (x) + (let ((str (hydra--to-string (cdr x)))) + (format + (if (> (length str) 0) + (concat hydra-head-format str) + "%s") + (car x)))) + +(defun hydra--hint-heads-wocol (body heads) + "Generate a hint for the echo area. +BODY, and HEADS are parameters to `defhydra'. +Works for heads without a property :column." + (let (alist) + (dolist (h heads) + (let ((val (assoc (cadr h) alist)) + (pstr (hydra-fontify-head h body))) + (if val + (setf (cadr val) + (concat (cadr val) " " pstr)) + (push + (cons (cadr h) + (cons pstr (cl-caddr h))) + alist)))) + (let ((keys (nreverse (mapcar #'cdr alist))) + (n-cols (plist-get (cddr body) :columns)) + res) + (setq res + (if n-cols + (let ((n-rows (1+ (/ (length keys) n-cols))) + (max-key-len (apply #'max (mapcar (lambda (x) (length (car x))) keys))) + (max-doc-len (apply #'max (mapcar (lambda (x) + (length (hydra--to-string (cdr x)))) keys)))) + `(concat + "\n" + (mapconcat #'identity + (mapcar + (lambda (x) + (mapconcat + (lambda (y) + (and y + (funcall hydra-key-doc-function + (car y) + ,max-key-len + (hydra--to-string (cdr y)) + ,max-doc-len))) x "")) + ',(hydra--matrix keys n-cols n-rows)) + "\n"))) + + + `(concat + (mapconcat + #'hydra--eval-and-format + ',keys + ", ") + ,(if keys "." "")))) + (if (cl-every #'stringp + (mapcar 'cddr alist)) + (eval res) + res)))) + +(defun hydra--hint (body heads) + "Generate a hint for the echo area. +BODY, and HEADS are parameters to `defhydra'." + (let* ((sorted-heads (hydra--sort-heads (hydra--normalize-heads heads))) + (heads-w-col (cl-remove-if-not (lambda (heads) (hydra--head-property (nth 0 heads) :column)) sorted-heads)) + (heads-wo-col (cl-remove-if (lambda (heads) (hydra--head-property (nth 0 heads) :column)) sorted-heads)) + (hint-w-col (when heads-w-col + (hydra--hint-from-matrix body (hydra--generate-matrix heads-w-col)))) + (hint-wo-col (when heads-wo-col + (hydra--hint-heads-wocol body (car heads-wo-col))))) + (if (null hint-w-col) + hint-wo-col + (if (stringp hint-wo-col) + `(concat ,@hint-w-col ,hint-wo-col) + `(concat ,@hint-w-col ,@(cdr hint-wo-col)))))) + +(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." + (let* ((foreign-keys (hydra--body-foreign-keys body)) + (head-exit (hydra--head-property head :exit)) + (head-color + (if head-exit + (if (eq foreign-keys 'warn) + 'teal + 'blue) + (cl-case foreign-keys + (warn 'amaranth) + (run 'pink) + (t 'red))))) + (when (and (null (cadr head)) + (not head-exit)) + (hydra--complain "nil cmd can only be blue")) + (propertize + (replace-regexp-in-string "%" "%%" (car head)) + 'face + (or (hydra--head-property head :face) + (cl-case head-color + (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" head))))))) + +(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 {}." + (format + (if (hydra--head-property head :exit) + "[%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--strip-align-markers (str) + "Remove ^ from STR, unless they're escaped: \\^." + (let ((start 0)) + (while (setq start (string-match "\\\\?\\^" str start)) + (if (eq (- (match-end 0) (match-beginning 0)) 2) + (progn + (setq str (replace-match "^" nil nil str)) + (cl-incf start)) + (setq str (replace-match "" nil nil str)))) + str)) + +(defvar hydra-docstring-keys-translate-alist + '(("↑" . "") + ("↓" . "") + ("→" . "") + ("←" . "") + ("⌫" . "DEL") + ("⌦" . "") + ("⏎" . "RET"))) + +(defconst hydra-width-spec-regex " ?-?[0-9]*?" + "Regex for the width spec in keys and %` quoted sexps.") + +(defvar hydra-key-regex "\\[\\|]\\|[-\\[:alnum:] ~.,;:/|?<>={}*+#%@!&^↑↓←→⌫⌦⏎'`()\"$]+?" + "Regex for the key quoted in the docstring.") + +(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." + (unless (memq 'elisp--witness--lisp (mapcar #'cadr heads)) + (setq docstring (hydra--strip-align-markers docstring)) + (setq docstring (replace-regexp-in-string "___" "_β_" docstring)) + (let ((rest (if (eq (plist-get (cddr body) :hint) 'none) + "" + (hydra--hint body heads))) + (start 0) + (inner-regex (format "\\(%s\\)\\(%s\\)" hydra-width-spec-regex hydra-key-regex)) + varlist + offset) + (while (setq start + (string-match + (format + "\\(?:%%\\( ?-?[0-9]*s?\\)\\(`[a-z-A-Z/0-9]+\\|(\\)\\)\\|\\(?:_%s_\\)\\|\\(?:[?]%s[?]\\)" + inner-regex + inner-regex) + docstring start)) + (cond ((eq ?? (aref (match-string 0 docstring) 0)) + (let* ((key (match-string 6 docstring)) + (head (assoc key heads))) + (if head + (progn + (push (nth 2 head) varlist) + (setq docstring + (replace-match + (or + hydra-doc-format-spec + (concat "%" (match-string 3 docstring) "s")) + t nil docstring))) + (setq start (match-end 0)) + (warn "Unrecognized key: ?%s?" key)))) + ((eq ?_ (aref (match-string 0 docstring) 0)) + (let* ((key (match-string 4 docstring)) + (key (if (equal key "β") "_" key)) + normal-key + (head (or (assoc key heads) + (when (setq normal-key + (cdr (assoc + key hydra-docstring-keys-translate-alist))) + (assoc normal-key heads))))) + (if head + (progn + (push (hydra-fontify-head (if normal-key + (cons key (cdr head)) + head) + body) + varlist) + (let ((replacement + (or + hydra-key-format-spec + (concat "%" (match-string 3 docstring) "s")))) + (setq docstring + (replace-match replacement t nil docstring)) + (setq start (+ start (length replacement))))) + (setq start (match-end 0)) + (warn "Unrecognized key: _%s_" key)))) + + (t + (let* ((varp (if (eq ?` (aref (match-string 2 docstring) 0)) 1 0)) + (spec (match-string 1 docstring)) + (lspec (length spec))) + (setq offset + (with-temp-buffer + (insert (substring docstring (+ 1 start varp + (length spec)))) + (goto-char (point-min)) + (push (read (current-buffer)) varlist) + (- (point) (point-min)))) + (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 (+ start offset 1 lspec varp)))))))) + (hydra--format-1 docstring rest varlist)))) + +(defun hydra--format-1 (docstring rest varlist) + (cond + ((string= docstring "") + rest) + ((listp rest) + (unless (string-match-p "[:\n]" docstring) + (setq docstring (concat docstring ":\n"))) + (unless (or (string-match-p "\n\\'" docstring) + (equal (cadr rest) "\n")) + (setq docstring (concat docstring "\n"))) + `(concat (format ,(replace-regexp-in-string "\\`\n" "" docstring) ,@(nreverse varlist)) + ,@(cdr rest))) + ((eq ?\n (aref docstring 0)) + `(format ,(concat (substring docstring 1) rest) ,@(nreverse varlist))) + (t + (let ((r `(replace-regexp-in-string + " +$" "" + (concat ,docstring + ,(cond ((string-match-p "\\`\n" rest) + ":") + ((string-match-p "\n" rest) + ":\n") + (t + ": ")) + (replace-regexp-in-string + "\\(%\\)" "\\1\\1" ,rest))))) + (if (stringp rest) + `(format ,(eval r)) + `(format ,r)))))) + +(defun hydra--complain (format-string &rest args) + "Forward to (`message' FORMAT-STRING ARGS) unless `hydra-verbose' is nil." + (if hydra-verbose + (apply #'error format-string args) + (apply #'message format-string args))) + +(defun hydra--doc (body-key body-name heads) + "Generate a part of Hydra docstring. +BODY-KEY is the body key binding. +BODY-NAME is the symbol that identifies the Hydra. +HEADS is a list of heads." + (format + "The heads for the associated hydra are:\n\n%s\n\n%s%s." + (mapconcat + (lambda (x) + (format "\"%s\": `%S'" (car x) (cadr x))) + heads ",\n") + (format "The body can be accessed via `%S'" body-name) + (if body-key + (format ", which is bound to \"%s\"" body-key) + ""))) + +(defun hydra--call-interactively-remap-maybe (cmd) + "`call-interactively' the given CMD or its remapped equivalent. +Only when `hydra-look-for-remap' is non nil." + (let ((remapped-cmd (if hydra-look-for-remap + (command-remapping `,cmd) + nil))) + (if remapped-cmd + (call-interactively `,remapped-cmd) + (call-interactively `,cmd)))) + +(defun hydra--call-interactively (cmd name) + "Generate a `call-interactively' statement for CMD. +Set `this-command' to NAME." + (if (and (symbolp name) + (not (memq name '(nil body)))) + `(progn + (setq this-command ',name) + (hydra--call-interactively-remap-maybe #',cmd)) + `(hydra--call-interactively-remap-maybe #',cmd))) + +(defun hydra--make-defun (name body doc head + keymap body-pre body-before-exit + &optional body-after-exit) + "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 is added to the start of the wrapper. +BODY-BEFORE-EXIT will be called before the hydra quits. +BODY-AFTER-EXIT is added to the end of the wrapper." + (let ((cmd-name (hydra--head-name head name)) + (cmd (when (car head) + (hydra--make-callable + (cadr head)))) + (doc (if (car head) + (format "Call the head `%S' in the \"%s\" hydra.\n\n%s" + (cadr head) name doc) + (format "Call the body in the \"%s\" hydra.\n\n%s" + name doc))) + (hint (intern (format "%S/hint" name))) + (body-foreign-keys (hydra--body-foreign-keys body)) + (body-timeout (plist-get body :timeout)) + (body-idle (plist-get body :idle))) + `(defun ,cmd-name () + ,doc + (interactive) + (require 'hydra) + (hydra-default-pre) + ,@(when body-pre (list body-pre)) + ,@(if (hydra--head-property head :exit) + `((hydra-keyboard-quit) + (setq hydra-curr-body-fn ',(intern (format "%S/body" name))) + ,@(if body-after-exit + `((unwind-protect + ,(when cmd + (hydra--call-interactively cmd (cadr head))) + ,body-after-exit)) + (when cmd + `(,(hydra--call-interactively cmd (cadr head)))))) + (delq + nil + `((let ((hydra--ignore ,(not (eq (cadr head) 'body)))) + (hydra-keyboard-quit) + (setq hydra-curr-body-fn ',(intern (format "%S/body" name)))) + ,(when cmd + `(condition-case err + ,(hydra--call-interactively cmd (cadr head)) + ((quit error) + (message (error-message-string err))))) + ,(if (and body-idle (eq (cadr head) 'body)) + `(hydra-idle-message ,body-idle ,hint ',name) + `(hydra-show-hint ,hint ',name)) + (hydra-set-transient-map + ,keymap + (lambda () (hydra-keyboard-quit) ,body-before-exit) + ,(when body-foreign-keys + (list 'quote body-foreign-keys))) + ,body-after-exit + ,(when body-timeout + `(hydra-timeout ,body-timeout)))))))) + +(defvar hydra-props-alist nil) + +(defun hydra-set-property (name key val) + "Set hydra property. +NAME is the symbolic name of the hydra. +KEY and VAL are forwarded to `plist-put'." + (let ((entry (assoc name hydra-props-alist)) + plist) + (when (null entry) + (add-to-list 'hydra-props-alist (list name)) + (setq entry (assoc name hydra-props-alist))) + (setq plist (cdr entry)) + (setcdr entry (plist-put plist key val)))) + +(defun hydra-get-property (name key) + "Get hydra property. +NAME is the symbolic name of the hydra. +KEY is forwarded to `plist-get'." + (let ((entry (assoc name hydra-props-alist))) + (when entry + (plist-get (cdr entry) key)))) + +(defun hydra-show-hint (hint caller) + (let ((verbosity (plist-get (cdr (assoc caller hydra-props-alist)) + :verbosity))) + (cond ((eq verbosity 0)) + ((eq verbosity 1) + (message (eval hint))) + (t + (when hydra-is-helpful + (funcall + (nth 1 (assoc hydra-hint-display-type hydra-hint-display-alist)) + (eval hint))))))) + +(defmacro hydra--make-funcall (sym) + "Transform SYM into a `funcall' to call it." + `(when (and ,sym (symbolp ,sym)) + (setq ,sym `(funcall #',,sym)))) + +(defun hydra--head-name (h name) + "Return the symbol for head H of hydra with NAME." + (let ((str (format "%S/%s" name + (cond ((symbolp (cadr h)) + (cadr h)) + ((and (consp (cadr h)) + (eq (cl-caadr h) 'function)) + (cadr (cadr h))) + (t + (concat "lambda-" (car h))))))) + (when (and (hydra--head-property h :exit) + (not (memq (cadr h) '(body nil)))) + (setq str (concat str "-and-exit"))) + (intern str))) + +(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 . nil) . hydra-repeat))) + res entry) + (dolist (h heads) + (if (setq entry (assoc (cons (cadr h) + (hydra--head-property h :exit)) + ali)) + (setf (cl-cdddr h) (plist-put (cl-cdddr h) :cmd-name (cdr entry))) + (push (cons (cons (cadr h) + (hydra--head-property h :exit)) + (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))))) + +(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--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")) + +(defvar hydra-cell-format "% -20s %% -8`%s" + "The default format for docstring cells.") + +(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 variables NAMES to their defaults. +NAMES should be defined by `defhydradio' or similar." + (dolist (n names) + (set n (aref (get n 'range) 0)))) + +;; Following functions deal with automatic docstring table generation from :column head property +(defun hydra--normalize-heads (heads) + "Ensure each head from HEADS have a property :column. +Set it to the same value as preceding head or nil if no previous value +was defined." + (let ((current-col nil)) + (mapcar (lambda (head) + (if (hydra--head-has-property head :column) + (setq current-col (hydra--head-property head :column))) + (hydra--head-set-property head :column current-col)) + heads))) + +(defun hydra--sort-heads (normalized-heads) + "Return a list of heads with non-nil doc grouped by column property. +Each head of NORMALIZED-HEADS must have a column property." + (let* ((heads-wo-nil-doc (cl-remove-if-not (lambda (head) (nth 2 head)) normalized-heads)) + (columns-list (delete-dups (mapcar (lambda (head) (hydra--head-property head :column)) + normalized-heads))) + (get-col-index-fun (lambda (head) (cl-position (hydra--head-property head :column) + columns-list + :test 'equal))) + (heads-sorted (cl-sort heads-wo-nil-doc (lambda (it other) + (< (funcall get-col-index-fun it) + (funcall get-col-index-fun other)))))) + ;; this operation partition the sorted head list into lists of heads with same column property + (cl-loop for head in heads-sorted + for column-name = (hydra--head-property head :column) + with prev-column-name = (hydra--head-property (nth 0 heads-sorted) :column) + unless (equal prev-column-name column-name) collect heads-one-column into heads-all-columns + and do (setq heads-one-column nil) + collect head into heads-one-column + do (setq prev-column-name column-name) + finally return (append heads-all-columns (list heads-one-column))))) + +(defun hydra--pad-heads (heads-groups padding-head) + "Return a copy of HEADS-GROUPS padded where applicable with PADDING-HEAD." + (cl-loop for heads-group in heads-groups + for this-head-group-length = (length heads-group) + with head-group-max-length = (apply #'max (mapcar (lambda (heads) (length heads)) heads-groups)) + if (<= this-head-group-length head-group-max-length) + collect (append heads-group (make-list (- head-group-max-length this-head-group-length) padding-head)) + into balanced-heads-groups + else collect heads-group into balanced-heads-groups + finally return balanced-heads-groups)) + +(defun hydra--generate-matrix (heads-groups) + "Return a copy of HEADS-GROUPS decorated with table formatting information. +Details of modification: +2 virtual heads acting as table header were added to each heads-group. +Each head is decorated with 2 new properties max-doc-len and max-key-len +representing the maximum dimension of their owning group. + Every heads-group have equal length by adding padding heads where applicable." + (when heads-groups + (let ((res nil)) + (dolist (heads-group (hydra--pad-heads heads-groups '(" " nil " " :exit t))) + (let* ((column-name (hydra--head-property (nth 0 heads-group) :column)) + (max-key-len (apply #'max (mapcar (lambda (x) (length (car x))) heads-group))) + (max-doc-len (apply #'max + (length column-name) + (mapcar (lambda (x) (length (hydra--to-string (nth 2 x)))) heads-group))) + (header-virtual-head `(" " nil ,column-name :column ,column-name :exit t)) + (separator-virtual-head `(" " nil ,(make-string (+ 2 max-doc-len max-key-len) ?-) :column ,column-name :exit t)) + (decorated-heads (copy-tree (apply 'list header-virtual-head separator-virtual-head heads-group)))) + (push (mapcar (lambda (it) + (hydra--head-set-property it :max-key-len max-key-len) + (hydra--head-set-property it :max-doc-len max-doc-len)) + decorated-heads) res))) + (nreverse res)))) + +(defun hydra-interpose (x lst) + "Insert X in between each element of LST." + (let (res y) + (while (setq y (pop lst)) + (push y res) + (push x res)) + (nreverse (cdr res)))) + +(defun hydra--hint-row (heads body) + (let ((lst (hydra-interpose + "| " + (mapcar (lambda (head) + (funcall hydra-key-doc-function + (hydra-fontify-head head body) + (let ((n (hydra--head-property head :max-key-len))) + (+ n (cl-count ?% (car head)))) + (nth 2 head) ;; doc + (hydra--head-property head :max-doc-len))) + heads)))) + (when (stringp (car (last lst))) + (let ((len (length lst)) + (new-last (replace-regexp-in-string "\s+$" "" (car (last lst))))) + (when (= 0 (length (setf (nth (- len 1) lst) new-last))) + (setf (nth (- len 2) lst) "|")))) + lst)) + + +(defun hydra--hint-from-matrix (body heads-matrix) + "Generate a formatted table-style docstring according to BODY and HEADS-MATRIX. +HEADS-MATRIX is expected to be a list of heads with following features: +Each heads must have the same length +Each head must have a property max-key-len and max-doc-len." + (when heads-matrix + (let ((lines (hydra--hint-from-matrix-1 body heads-matrix))) + `(,@(apply #'append (hydra-interpose '("\n") lines)) + "\n")))) + +(defun hydra--hint-from-matrix-1 (body heads-matrix) + (let* ((first-heads-col (nth 0 heads-matrix)) + (last-row-index (- (length first-heads-col) 1)) + (lines nil)) + (dolist (row-index (number-sequence 0 last-row-index)) + (let ((heads-in-row (mapcar + (lambda (heads) (nth row-index heads)) + heads-matrix))) + (push (hydra--hint-row heads-in-row body) + lines))) + (nreverse lines))) + +(defun hydra-idle-message (secs hint name) + "In SECS seconds display HINT." + (cancel-timer hydra-message-timer) + (setq hydra-message-timer (timer-create)) + (timer-set-time hydra-message-timer + (timer-relative-time (current-time) secs)) + (timer-set-function + hydra-message-timer + (lambda () + (hydra-show-hint hint name) + (cancel-timer hydra-message-timer))) + (timer-activate hydra-message-timer)) + +(defun hydra-timeout (secs &optional function) + "In SECS seconds call FUNCTION, then function `hydra-keyboard-quit'. +Cancel the previous `hydra-timeout'." + (cancel-timer hydra-timeout-timer) + (setq hydra-timeout-timer (timer-create)) + (timer-set-time hydra-timeout-timer + (timer-relative-time (current-time) secs)) + (timer-set-function + hydra-timeout-timer + `(lambda () + ,(when function + `(funcall ,function)) + (hydra-keyboard-quit))) + (timer-activate hydra-timeout-timer)) + +;;* Macros +;;;###autoload +(defmacro defhydra (name body &optional docstring &rest heads) + "Create a Hydra - a family of functions with prefix NAME. + +NAME should be a symbol, it will be the prefix of all functions +defined here. + +BODY has the format: + + (BODY-MAP BODY-KEY &rest BODY-PLIST) + +DOCSTRING will be displayed in the echo area to identify the +Hydra. When DOCSTRING starts with a newline, special Ruby-style +substitution will be performed by `hydra--format'. + +Functions are created on basis of HEADS, each of which has the +format: + + (KEY CMD &optional HINT &rest PLIST) + +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 (both are strings passed to `kbd'), and will set +the transient map so that all following heads can be called +though KEY only. BODY-KEY can be an empty string. + +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 BODY-PLIST and are allowed to +override some keys. The keys recognized are :exit, :bind, and :column. +:exit can be: + +- nil (default): this head will continue the Hydra state. +- t: this head will 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. + +:column is a string that sets the column for all subsequent heads. + +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) (doc-string 3)) + (setq heads (copy-tree heads)) + (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 ""))) + (when (keywordp (car body)) + (setq body (cons nil (cons nil body)))) + (setq body (hydra--normalize-body body)) + (condition-case-unless-debug err + (let* ((keymap-name (intern (format "%S/keymap" name))) + (body-name (intern (format "%S/body" name))) + (body-key (cadr body)) + (body-plist (cddr body)) + (base-map (or (eval (plist-get body-plist :base-map)) + hydra-base-map)) + (keymap (copy-keymap base-map)) + (body-map (or (car body) + (plist-get body-plist :bind))) + (body-pre (plist-get body-plist :pre)) + (body-body-pre (plist-get body-plist :body-pre)) + (body-before-exit (or (plist-get body-plist :post) + (plist-get body-plist :before-exit))) + (body-after-exit (plist-get body-plist :after-exit)) + (body-inherit (plist-get body-plist :inherit)) + (body-foreign-keys (hydra--body-foreign-keys body)) + (body-exit (hydra--body-exit body))) + (dolist (base body-inherit) + (setq heads (append heads (copy-sequence (eval base))))) + (dolist (h heads) + (let ((len (length h))) + (cond ((< len 2) + (error "Each head should have at least two items: %S" h)) + ((= len 2) + (setcdr (cdr h) + (list + (hydra-plist-get-default + body-plist :hint hydra-default-hint))) + (setcdr (nthcdr 2 h) (list :exit body-exit))) + (t + (let ((hint (cl-caddr h))) + (unless (or (null hint) + (stringp hint) + (consp hint)) + (let ((inherited-hint + (hydra-plist-get-default + body-plist :hint hydra-default-hint))) + (setcdr (cdr h) (cons + (if (eq 'none inherited-hint) + nil + inherited-hint) + (cddr h)))))) + (let ((hint-and-plist (cddr h))) + (if (null (cdr hint-and-plist)) + (setcdr hint-and-plist (list :exit body-exit)) + (let* ((plist (cl-cdddr h)) + (h-color (plist-get plist :color))) + (if h-color + (progn + (plist-put plist :exit + (cl-case h-color + ((blue teal) t) + (t nil))) + (cl-remf (cl-cdddr h) :color)) + (let ((h-exit (hydra-plist-get-default plist :exit 'default))) + (plist-put plist :exit + (if (eq h-exit 'default) + body-exit + h-exit)))))))))) + (plist-put (cl-cdddr h) :cmd-name (hydra--head-name h name)) + (when (null (cadr h)) (plist-put (cl-cdddr h) :exit t))) + (let ((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) + (hydra--make-funcall body-pre) + (hydra--make-funcall body-body-pre) + (hydra--make-funcall body-before-exit) + (hydra--make-funcall body-after-exit) + (when (memq body-foreign-keys '(run warn)) + (unless (cl-some + (lambda (h) + (hydra--head-property h :exit)) + heads) + (error + "An %S Hydra must have at least one blue head in order to exit" + body-foreign-keys))) + `(progn + (set (defvar ,(intern (format "%S/params" name)) + nil + ,(format "Params of %S." name)) + ',body) + (set (defvar ,(intern (format "%S/docstring" name)) + nil + ,(format "Docstring of %S." name)) + ,docstring) + (set (defvar ,(intern (format "%S/heads" name)) + nil + ,(format "Heads for %S." name)) + ',(mapcar (lambda (h) + (let ((j (copy-sequence h))) + (cl-remf (cl-cdddr j) :cmd-name) + j)) + heads)) + ;; create keymap + (set (defvar ,keymap-name + nil + ,(format "Keymap for %S." name)) + ',keymap) + ;; declare heads + (set + (defvar ,(intern (format "%S/hint" name)) nil + ,(format "Dynamic hint for %S." name)) + ',(hydra--format name body docstring heads)) + ;; create defuns + ,@(mapcar + (lambda (head) + (hydra--make-defun name body doc head keymap-name + body-pre + body-before-exit + body-after-exit)) + heads-nodup) + ;; free up keymap prefix + ,@(unless (or (null body-key) + (null body-map) + (hydra--callablep body-map)) + `((unless (keymapp (lookup-key ,body-map (kbd ,body-key))) + (define-key ,body-map (kbd ,body-key) nil)))) + ;; bind keys + ,@(delq nil + (mapcar + (lambda (head) + (let ((name (hydra--head-property head :cmd-name))) + (when (and (cadr head) + (or body-key body-map)) + (let ((bind (hydra--head-property head :bind body-map)) + (final-key + (if body-key + (vconcat (kbd body-key) (kbd (car head))) + (kbd (car head))))) + (cond ((null bind) nil) + ((hydra--callablep bind) + `(funcall ,bind ,final-key (function ,name))) + ((and (symbolp bind) + (if (boundp bind) + (keymapp (symbol-value bind)) + t)) + `(define-key ,bind ,final-key (quote ,name))) + (t + (error "Invalid :bind property `%S' for head %S" bind head))))))) + heads)) + ,(hydra--make-defun + name body doc '(nil body) + keymap-name + (or body-body-pre body-pre) body-before-exit + '(setq prefix-arg current-prefix-arg))))) + (error + (hydra--complain "Error in defhydra %S: %s" name (cdr err)) + nil))) + +(defmacro defhydra+ (name body &optional docstring &rest heads) + "Redefine an existing hydra by adding new heads. +Arguments are same as of `defhydra'." + (declare (indent defun) (doc-string 3)) + (unless (stringp docstring) + (setq heads + (cons docstring heads)) + (setq docstring nil)) + `(defhydra ,name ,(or body (hydra--prop name "/params")) + ,(or docstring (hydra--prop name "/docstring")) + ,@(cl-delete-duplicates + (append (hydra--prop name "/heads") heads) + :key #'car + :test #'equal))) + +(defun hydra--prop (name prop-name) + (symbol-value (intern (concat (symbol-name name) prop-name)))) + +(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)))) + +(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)) + (cl-incf i))) + (error "Val not in range for %S" sym))) + (set sym + (aref range + (if (>= i l) + 0 + i))))) + +(defvar hydra-pause-ring (make-ring 10) + "Ring for paused hydras.") + +(defun hydra-pause-resume () + "Quit the current hydra and save it to the stack. +If there's no active hydra, pop one from the stack and call its body. +If the stack is empty, call the last hydra's body." + (interactive) + (cond (hydra-curr-map + (ring-insert hydra-pause-ring hydra-curr-body-fn) + (hydra-keyboard-quit)) + ((zerop (ring-length hydra-pause-ring)) + (funcall hydra-curr-body-fn)) + (t + (funcall (ring-remove hydra-pause-ring 0))))) + +;; Local Variables: +;; outline-regexp: ";;\\([;*]+ [^\s\t\n]\\|###autoload\\)\\|(" +;; indent-tabs-mode: nil +;; End: + +(provide 'hydra) + +;;; hydra.el ends here diff --git a/elpa/hydra-readme.txt b/elpa/hydra-readme.txt new file mode 100644 index 00000000..300c6fac --- /dev/null +++ b/elpa/hydra-readme.txt @@ -0,0 +1,51 @@ +This package can be used to tie related commands into a family of +short bindings with a common prefix - a Hydra. + +Once you summon the Hydra (through the prefixed binding), all the +heads can be called in succession with only a short extension. +The Hydra is vanquished once Hercules, any binding that isn't the +Hydra's head, arrives. Note that Hercules, besides vanquishing the +Hydra, will still serve his original purpose, calling his proper +command. This makes the Hydra very seamless, it's like a minor +mode that disables itself automagically. + +Here's an example Hydra, bound in the global map (you can use any +keymap in place of `global-map'): + + (defhydra hydra-zoom (global-map "") + "zoom" + ("g" text-scale-increase "in") + ("l" text-scale-decrease "out")) + +It allows to start a command chain either like this: +" gg4ll5g", or " lgllg". + +Here's another approach, when you just want a "callable keymap": + + (defhydra hydra-toggle (:color blue) + "toggle" + ("a" abbrev-mode "abbrev") + ("d" toggle-debug-on-error "debug") + ("f" auto-fill-mode "fill") + ("t" toggle-truncate-lines "truncate") + ("w" whitespace-mode "whitespace") + ("q" nil "cancel")) + +This binds nothing so far, but if you follow up with: + + (global-set-key (kbd "C-c C-v") 'hydra-toggle/body) + +you will have bound "C-c C-v a", "C-c C-v d" etc. + +Knowing that `defhydra' defines e.g. `hydra-toggle/body' command, +you can nest Hydras if you wish, with `hydra-toggle/body' possibly +becoming a blue head of another Hydra. + +If you want to learn all intricacies of using `defhydra' without +having to figure it all out from this source code, check out the +wiki: https://github.com/abo-abo/hydra/wiki. There's a wealth of +information there. Everyone is welcome to bring the existing pages +up to date and add new ones. + +Additionally, the file hydra-examples.el serves to demo most of the +functionality.