+++ /dev/null
-;;; hydra-autoloads.el --- automatically extracted autoloads
-;;
-;;; Code:
-
-(add-to-list 'load-path (directory-file-name
- (or (file-name-directory #$) (car load-path))))
-
-\f
-;;;### (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 and :bind.
-: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.
-
-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-" "defhydradio")))
-
-;;;***
-\f
-;;;### (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")))
-
-;;;***
-\f
-;;;### (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")))
-
-;;;***
-\f
-;;;### (autoloads nil "lv" "lv.el" (0 0 0 0))
-;;; Generated autoloads from lv.el
-
-(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lv" '("lv-")))
-
-;;;***
-\f
-;;;### (autoloads nil nil ("hydra-pkg.el") (0 0 0 0))
-
-;;;***
-\f
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; coding: utf-8
-;; End:
-;;; hydra-autoloads.el ends here
+++ /dev/null
-;;; 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 <http://www.gnu.org/licenses/>.
-
-;;; 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 "<f2>")
- "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 "<f2> g") 'hydra-zoom/text-scale-increase)
-;; (global-set-key (kbd "<f2> 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
-^^^^ ^ ^ _p_aste
-"
- ("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)
- ("p" 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)
-
-;;* 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
+++ /dev/null
-;;; hydra-ox.el --- Org mode export widget implemented in Hydra
-
-;; Copyright (C) 2015 Free Software Foundation, Inc.
-
-;; Author: Oleh Krehel
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This shows how a complex dispatch menu can be built with Hydra.
-
-;;; Code:
-
-(require '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
+++ /dev/null
-(define-package "hydra" "20181128.1716" "Make bindings that stick around."
- '((cl-lib "0.5"))
- :keywords
- '("bindings")
- :authors
- '(("Oleh Krehel" . "ohwoeowhoNOSPAMgmail.com"))
- :maintainer
- '("Oleh Krehel" . "ohwoeowhoNOSPAMgmail.com")
- :url "https://github.com/abo-abo/hydra")
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+++ /dev/null
-;;; hydra.el --- Make bindings that stick around. -*- lexical-binding: t -*-
-
-;; Copyright (C) 2015 Free Software Foundation, Inc.
-
-;; Author: Oleh Krehel <ohwoeowhoNOSPAMgmail.com>
-;; Maintainer: Oleh Krehel <ohwoeowho@gmail.com>
-;; URL: https://github.com/abo-abo/hydra
-;; Version: 0.14.0
-;; Keywords: bindings
-;; Package-Requires: ((cl-lib "0.5"))
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This package 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 "<f2>")
-;; "zoom"
-;; ("g" text-scale-increase "in")
-;; ("l" text-scale-decrease "out"))
-;;
-;; It allows to start a command chain either like this:
-;; "<f2> gg4ll5g", or "<f2> 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)
-
-(defcustom hydra-lv t
- "When non-nil, `lv-message' (not `message') will be used to display hints."
- :type 'boolean)
-
-(defcustom hydra-verbose nil
- "When non-nil, hydra will issue some non essential style warnings."
- :type 'boolean)
-
-(defcustom hydra-key-format-spec "%s"
- "Default `format'-style specifier for _a_ syntax in docstrings.
-When nil, you can specify your own at each location like this: _ 5a_."
- :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'."
- ad-do-it
- ;; 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)))))
-
-(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))
- (if hydra-lv
- (lv-delete-window)
- (message "")))
- 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)
- "Doc"
- (cond
- ((equal key " ") (format (format "%%-%ds" (+ 3 key-width doc-width)) 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--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)))
- (unless (not (stringp (cl-caddr h)))
- (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
- (lambda (x)
- (let ((str (hydra--to-string (cdr x))))
- (format
- (if (> (length str) 0)
- (concat hydra-head-format str)
- "%s")
- (car x))))
- ',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)))
- (concat (when heads-w-col
- (hydra--hint-from-matrix body (hydra--generate-matrix heads-w-col)))
- (when heads-wo-col
- (hydra--hint-heads-wocol body (car heads-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
- '(("↑" . "<up>")
- ("↓" . "<down>")
- ("→" . "<right>")
- ("←" . "<left>")
- ("⌫" . "DEL")
- ("⌦" . "<deletechar>")
- ("⏎" . "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))))))))
- (cond
- ((string= docstring "")
- rest)
- ((eq ?\n (aref docstring 0))
- `(concat (format ,(substring docstring 1) ,@(nreverse varlist))
- ,rest))
- (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))
- (unless hydra-lv
- (sit-for 0.8)))))
- ,(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
- (if hydra-lv
- (lv-message (eval hint))
- (message (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--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* ((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 (replace-regexp-in-string
- "\s+$" ""
- (mapconcat (lambda (head)
- (funcall hydra-key-doc-function
- (hydra-fontify-head head body) ;; key
- (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-in-row "| "))
- lines)))
- (concat (mapconcat #'identity (nreverse lines) "\n") "\n"))))
-
-;; previous functions dealt with automatic docstring table generation from :column head property
-
-(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 and :bind.
-: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.
-
-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))))
- (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
- ;; create keymap
- (set (defvar ,keymap-name
- nil
- ,(format "Keymap for %S." name))
- ',keymap)
- ;; declare heads
- (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))
- (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 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
+++ /dev/null
-;;; lv.el --- Other echo area
-
-;; Copyright (C) 2015 Free Software Foundation, Inc.
-
-;; Author: Oleh Krehel
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This package provides `lv-message' intended to be used in place of
-;; `message' when semi-permanent hints are needed, in order to not
-;; interfere with Echo Area.
-;;
-;; "Я тихо-тихо пiдглядаю,
-;; І тiшуся собi, як бачу то,
-;; Шо страшить i не пiдпускає,
-;; А iншi п’ють тебе, як воду пiсок."
-;; -- Андрій Кузьменко, L.V.
-
-;;; Code:
-
-(defgroup lv nil
- "The other echo area."
- :group 'minibuffer
- :group 'hydra)
-
-(defcustom lv-use-separator nil
- "Whether to draw a line between the LV window and the Echo Area."
- :group 'lv
- :type 'boolean)
-
-(defface lv-separator
- '((((class color) (background light)) :background "grey80")
- (((class color) (background dark)) :background "grey30"))
- "Face used to draw line between the lv window and the echo area.
-This is only used if option `lv-use-separator' is non-nil.
-Only the background color is significant."
- :group 'lv)
-
-(defvar lv-wnd nil
- "Holds the current LV window.")
-
-(defvar display-line-numbers)
-
-(defun lv-window ()
- "Ensure that LV window is live and return it."
- (if (window-live-p lv-wnd)
- lv-wnd
- (let ((ori (selected-window))
- buf)
- (prog1 (setq lv-wnd
- (select-window
- (let ((ignore-window-parameters t))
- (split-window
- (frame-root-window) -1 'below))))
- (if (setq buf (get-buffer " *LV*"))
- (switch-to-buffer buf)
- (switch-to-buffer " *LV*")
- (set-window-hscroll lv-wnd 0)
- (setq window-size-fixed t)
- (setq mode-line-format nil)
- (setq cursor-type nil)
- (setq display-line-numbers nil)
- (set-window-dedicated-p lv-wnd t)
- (set-window-parameter lv-wnd 'no-other-window t))
- (select-window ori)))))
-
-(defvar golden-ratio-mode)
-
-(defvar lv-force-update nil
- "When non-nil, `lv-message' will refresh even for the same string.")
-
-(defun lv-message (format-string &rest args)
- "Set LV window contents to (`format' FORMAT-STRING ARGS)."
- (let* ((str (apply #'format format-string args))
- (n-lines (cl-count ?\n str))
- deactivate-mark
- golden-ratio-mode)
- (with-selected-window (lv-window)
- (unless (and (string= (buffer-string) str)
- (null lv-force-update))
- (delete-region (point-min) (point-max))
- (insert str)
- (when (and (window-system) lv-use-separator)
- (unless (looking-back "\n" nil)
- (insert "\n"))
- (insert
- (propertize "__" 'face 'lv-separator 'display '(space :height (1)))
- (propertize "\n" 'face 'lv-separator 'line-height t)))
- (set (make-local-variable 'window-min-height) n-lines)
- (setq truncate-lines (> n-lines 1))
- (let ((window-resize-pixelwise t)
- (window-size-fixed nil))
- (fit-window-to-buffer nil nil 1)))
- (goto-char (point-min)))))
-
-(defun lv-delete-window ()
- "Delete LV window and kill its buffer."
- (when (window-live-p lv-wnd)
- (let ((buf (window-buffer lv-wnd)))
- (delete-window lv-wnd)
- (kill-buffer buf))))
-
-(provide 'lv)
-
-;;; lv.el ends here
--- /dev/null
+;;; hydra-autoloads.el --- automatically extracted autoloads
+;;
+;;; Code:
+(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
+\f
+;;;### (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)
+
+;;;***
+\f
+;;;### (autoloads nil nil ("hydra-examples.el" "hydra-ox.el" "hydra-pkg.el")
+;;;;;; (23994 42600 209767 474000))
+
+;;;***
+\f
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; End:
+;;; hydra-autoloads.el ends here
--- /dev/null
+;;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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 "<f2>")
+ "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 "<f2> g") 'hydra-zoom/text-scale-increase)
+;; (global-set-key (kbd "<f2> 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
--- /dev/null
+;;; hydra-ox.el --- Org mode export widget implemented in Hydra
+
+;; Copyright (C) 2015 Free Software Foundation, Inc.
+
+;; Author: Oleh Krehel
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This shows how a complex dispatch menu can be built with Hydra.
+
+;;; Code:
+
+(require '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
--- /dev/null
+(define-package "hydra" "20190821.939" "Make bindings that stick around."
+ '((cl-lib "0.5")
+ (lv "0"))
+ :keywords
+ '("bindings")
+ :authors
+ '(("Oleh Krehel" . "ohwoeowhoNOSPAMgmail.com"))
+ :maintainer
+ '("Oleh Krehel" . "ohwoeowhoNOSPAMgmail.com")
+ :url "https://github.com/abo-abo/hydra")
+;; Local Variables:
+;; no-byte-compile: t
+;; End:
--- /dev/null
+;;; hydra.el --- Make bindings that stick around. -*- lexical-binding: t -*-
+
+;; Copyright (C) 2015-2019 Free Software Foundation, Inc.
+
+;; Author: Oleh Krehel <ohwoeowhoNOSPAMgmail.com>
+;; Maintainer: Oleh Krehel <ohwoeowhoNOSPAMgmail.com>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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 "<f2>")
+;; "zoom"
+;; ("g" text-scale-increase "in")
+;; ("l" text-scale-decrease "out"))
+;;
+;; It allows to start a command chain either like this:
+;; "<f2> gg4ll5g", or "<f2> 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
+ '(("↑" . "<up>")
+ ("↓" . "<down>")
+ ("→" . "<right>")
+ ("←" . "<left>")
+ ("⌫" . "DEL")
+ ("⌦" . "<deletechar>")
+ ("⏎" . "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
projects / emacsconfig.git / commitdiff