You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1554 lines
59 KiB
1554 lines
59 KiB
;;; hydra.el --- Make bindings that stick around. -*- lexical-binding: t -*- |
|
|
|
;; Copyright (C) 2015-2019 Free Software Foundation, Inc. |
|
|
|
;; Author: Oleh Krehel <ohwoeowho@gmail.com> |
|
;; Maintainer: Oleh Krehel <ohwoeowho@gmail.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) |
|
|
|
(define-obsolete-variable-alias |
|
'hydra-lv 'hydra-hint-display-type "0.14.0" |
|
"Use either `hydra-hint-display-type' or `hydra-set-property' :verbosity.") |
|
|
|
(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))))) |
|
|
|
(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
|
|
|