branch: externals/which-key
commit e236920b231ee1d86ae215598f7a9d8294467310
Merge: 1f9c37d d6b56f3
Author: Justin Burkett <jus...@burkett.cc>
Commit: Justin Burkett <jus...@burkett.cc>
Merge branch 'alt-get-bindings'
---
Cask | 1 +
which-key-tests.el | 52 +++++----
which-key.el | 320 +++++++++++++++++++----------------------------------
3 files changed, 147 insertions(+), 226 deletions(-)
diff --git a/Cask b/Cask
index 60fa07c..6ff7bbe 100644
--- a/Cask
+++ b/Cask
@@ -4,4 +4,5 @@
(package-file "which-key.el")
(development
+ (depends-on "evil")
(depends-on "ert"))
diff --git a/which-key-tests.el b/which-key-tests.el
index 1611d51..705099b 100644
--- a/which-key-tests.el
+++ b/which-key-tests.el
@@ -29,20 +29,17 @@
(ert-deftest which-key-test--keymap-based-bindings ()
(let ((map (make-sparse-keymap))
- (emacs-lisp-mode-map (copy-keymap emacs-lisp-mode-map)))
- (emacs-lisp-mode)
- (define-key map "x" 'ignore)
- (define-key emacs-lisp-mode-map "\C-c\C-a" 'complete)
- (define-key emacs-lisp-mode-map "\C-c\C-b" map)
- (which-key-add-keymap-based-replacements emacs-lisp-mode-map
- "C-c C-a" '("mycomplete" . complete)
- "C-c C-b" "mymap")
- (should (equal
- (which-key--maybe-replace '("C-c C-a" . "complete"))
- '("C-c C-a" . "mycomplete")))
- (should (equal
- (which-key--maybe-replace '("C-c C-b" . ""))
- '("C-c C-b" . "mymap")))))
+ (prefix-map (make-sparse-keymap)))
+ (define-key prefix-map "x" 'ignore)
+ (define-key map "\C-a" 'complete)
+ (define-key map "\C-b" prefix-map)
+ (which-key-add-keymap-based-replacements map
+ "C-a" '("mycomplete" . complete)
+ "C-b" "mymap")
+ (should (equal
+ (which-key--get-keymap-bindings map)
+ '(("C-a" . "mycomplete")
+ ("C-b" . "mymap"))))))
(ert-deftest which-key-test--prefix-declaration ()
"Test `which-key-declare-prefixes' and
@@ -141,25 +138,40 @@
(ert-deftest which-key-test--get-keymap-bindings ()
(let ((map (make-sparse-keymap))
+ (evil-local-mode t)
+ (evil-state 'normal)
which-key-replacement-alist)
+ (require 'evil)
(define-key map [which-key-a] '(which-key "blah"))
(define-key map "b" 'ignore)
(define-key map "c" "c")
(define-key map "dd" "dd")
(define-key map "eee" "eee")
(define-key map "f" [123 45 6])
+ (define-key map (kbd "M-g g") "M-gg")
+ (evil-define-key* 'normal map (kbd "C-h") "C-h-normal")
+ (evil-define-key* 'insert map (kbd "C-h") "C-h-insert")
(should (equal
(sort (which-key--get-keymap-bindings map)
(lambda (a b) (string-lessp (car a) (car b))))
- '(("b" . "ignore")
+ '(("M-g" . "prefix")
+ ("c" . "c")
+ ("d" . "prefix")
+ ("e" . "prefix")
+ ("f" . "{ - C-f"))))
+ (should (equal
+ (sort (which-key--get-keymap-bindings map nil nil nil nil t)
+ (lambda (a b) (string-lessp (car a) (car b))))
+ '(("C-h" . "C-h-normal")
+ ("M-g" . "prefix")
("c" . "c")
- ("d" . "Prefix Command")
- ("e" . "Prefix Command")
+ ("d" . "prefix")
+ ("e" . "prefix")
("f" . "{ - C-f"))))
(should (equal
- (sort (which-key--get-keymap-bindings map t)
+ (sort (which-key--get-keymap-bindings map nil nil nil t)
(lambda (a b) (string-lessp (car a) (car b))))
- '(("b" . "ignore")
+ '(("M-g g" . "M-gg")
("c" . "c")
("d d" . "dd")
("e e e" . "eee")
@@ -177,7 +189,7 @@
("A" . "Z")
("b" . "y")
("B" . "Y")
- ("p" . "Prefix")
+ ("p" . "prefix")
("SPC" . "x")
("C-a" . "w"))))
(let ((which-key-sort-uppercase-first t))
diff --git a/which-key.el b/which-key.el
index 6d69482..c133beb 100644
--- a/which-key.el
+++ b/which-key.el
@@ -152,9 +152,7 @@ remapped given the currently active keymaps."
(defcustom which-key-replacement-alist
(delq nil
- `(((nil . "Prefix Command") . (nil . "prefix"))
- ((nil . "\\`\\?\\?\\'") . (nil . "lambda"))
- ((nil . "which-key-show-next-page-no-cycle") . (nil . "wk next pg"))
+ `(((nil . "which-key-show-next-page-no-cycle") . (nil . "wk next pg"))
,@(unless which-key-dont-use-unicode
'((("<left>") . ("←"))
(("<right>") . ("→"))))
@@ -524,24 +522,6 @@ it."
:group 'which-key
:type 'boolean)
-(defcustom which-key-enable-extended-define-key nil
- "Advise `define-key' to make which-key aware of definitions of the form
-
- \(define-key KEYMAP KEY '(\"DESCRIPTION\" . DEF))
-
-With the advice, this definition will have the side effect of
-creating a replacement in `which-key-replacement-alist' that
-replaces DEF with DESCRIPTION when the key sequence ends in
-KEY. Using a cons cell like this is a valid definition for
-`define-key'. All this does is to make which-key aware of it.
-
-Since many higher level keybinding functions use `define-key'
-internally, this will affect most if not all of those as well.
-
-This variable must be set before loading which-key."
- :group 'which-key
- :type 'boolean)
-
;; Hooks
(defcustom which-key-init-buffer-hook '()
"Hook run when which-key buffer is initialized."
@@ -934,12 +914,13 @@ both have the same effect for the \"C-x C-w\" key
binding, but
the latter causes which-key to verify that the key sequence is
actually bound to write-file before performing the replacement."
(while key
- (let ((string (if (stringp replacement)
- replacement
- (car-safe replacement)))
- (command (cdr-safe replacement)))
- (define-key keymap (which-key--pseudo-key (kbd key))
- `(which-key ,(cons string command))))
+ (cond ((consp replacement)
+ (define-key keymap (kbd key) replacement))
+ ((stringp replacement)
+ (define-key keymap (kbd key) (cons replacement
+ (lookup-key keymap (kbd key)))))
+ (t
+ (user-error "replacement is neither a cons cell or a string")))
(setq key (pop more)
replacement (pop more))))
(put 'which-key-add-keymap-based-replacements 'lisp-indent-function 'defun)
@@ -1044,19 +1025,6 @@ If AT-ROOT is non-nil the binding is also placed at the
root of MAP."
(which-key-define-key-recursively df key def t)))
map))
-(defun which-key--process-define-key-args (keymap key def)
- "When DEF takes the form (\"DESCRIPTION\". DEF), make sure
-which-key uses \"DESCRIPTION\" for this binding. This function is
-meant to be used as :before advice for `define-key'."
- (with-demoted-errors "Which-key extended define-key error: %s"
- (when (and (consp def)
- (stringp (car def))
- (symbolp (cdr def)))
- (define-key keymap (which-key--pseudo-key key) `(which-key ,def)))))
-
-(when which-key-enable-extended-define-key
- (advice-add #'define-key :before #'which-key--process-define-key-args))
-
;;; Functions for computing window sizes
(defun which-key--text-width-to-total (text-width)
@@ -1432,7 +1400,9 @@ Uses `string-lessp' after applying lowercase."
(string-lessp (downcase (cdr acons)) (downcase (cdr bcons))))
(defsubst which-key--group-p (description)
- (or (string-match-p "^\\(group:\\|Prefix\\)" description)
+ (or (string-equal description "prefix")
+ (and (length> description 6)
+ (string-equal (substring description 0 6) "group:"))
(keymapp (intern description))))
(defun which-key-prefix-then-key-order (acons bcons)
@@ -1492,20 +1462,6 @@ local bindings coming first. Within these categories
order using
(string-match-p binding-regexp
(cdr key-binding)))))))
-(defun which-key--get-pseudo-binding (key-binding &optional prefix)
- (let* ((key (kbd (car key-binding)))
- (pseudo-binding (key-binding (which-key--pseudo-key key prefix))))
- (when pseudo-binding
- (let* ((command-replacement (cadr pseudo-binding))
- (pseudo-desc (car command-replacement))
- (pseudo-def (cdr command-replacement)))
- (when (and (stringp pseudo-desc)
- (or (null pseudo-def)
- ;; don't verify keymaps
- (keymapp pseudo-def)
- (eq pseudo-def (key-binding key))))
- (cons (car key-binding) pseudo-desc))))))
-
(defsubst which-key--replace-in-binding (key-binding repl)
(cond ((or (not (consp repl)) (null (cdr repl)))
key-binding)
@@ -1541,26 +1497,23 @@ local bindings coming first. Within these categories
order using
"Use `which-key--replacement-alist' to maybe replace KEY-BINDING.
KEY-BINDING is a cons cell of the form \(KEY . BINDING\) each of
which are strings. KEY is of the form produced by `key-binding'."
- (let* ((pseudo-binding (which-key--get-pseudo-binding key-binding prefix)))
- (if pseudo-binding
- pseudo-binding
- (let* ((replacer (if which-key-allow-multiple-replacements
- #'which-key--replace-in-repl-list-many
- #'which-key--replace-in-repl-list-once)))
- (pcase
- (apply replacer
- (list key-binding
- (cdr-safe (assq major-mode
which-key-replacement-alist))))
- (`(replaced . ,repl)
- (if which-key-allow-multiple-replacements
- (pcase (apply replacer (list repl which-key-replacement-alist))
- (`(replaced . ,repl) repl)
- ('() repl))
- repl))
- ('()
- (pcase (apply replacer (list key-binding
which-key-replacement-alist))
+ (let* ((replacer (if which-key-allow-multiple-replacements
+ #'which-key--replace-in-repl-list-many
+ #'which-key--replace-in-repl-list-once)))
+ (pcase
+ (apply replacer
+ (list key-binding
+ (cdr-safe (assq major-mode which-key-replacement-alist))))
+ (`(replaced . ,repl)
+ (if which-key-allow-multiple-replacements
+ (pcase (apply replacer (list repl which-key-replacement-alist))
(`(replaced . ,repl) repl)
- ('() key-binding))))))))
+ ('() repl))
+ repl))
+ ('()
+ (pcase (apply replacer (list key-binding which-key-replacement-alist))
+ (`(replaced . ,repl) repl)
+ ('() key-binding))))))
(defsubst which-key--current-key-list (&optional key-str)
(append (listify-key-sequence (which-key--current-prefix))
@@ -1592,12 +1545,6 @@ which are strings. KEY is of the form produced by
`key-binding'."
(or (eq lookup (intern (cdr keydesc)))
(and (keymapp lookup) (string= (cdr keydesc) "Prefix Command"))))))
-(defun which-key--pseudo-key (key &optional prefix)
- "Replace the last key in the sequence KEY by a special symbol
-in order for which-key to allow looking up a description for the key."
- (let ((seq (listify-key-sequence key)))
- (vconcat (or prefix (butlast seq)) [which-key] (last seq))))
-
(defun which-key--maybe-get-prefix-title (keys)
"KEYS is a string produced by `key-description'.
A title is possibly returned using
@@ -1789,137 +1736,99 @@ alists. Returns a list (key separator description)."
new-list))))
(nreverse new-list)))
-(defun which-key--get-keymap-bindings (keymap &optional all prefix)
- "Retrieve top-level bindings from KEYMAP.
-If ALL is non-nil, get all bindings, not just the top-level
-ones. PREFIX is for internal use and should not be used."
- (let (bindings)
- (map-keymap
- (lambda (ev def)
- (let* ((key (append prefix (list ev)))
- (key-desc (key-description key)))
- (cond ((or (string-match-p
- which-key--ignore-non-evil-keys-regexp key-desc)
- (eq ev 'menu-bar)))
- ;; extract evil keys corresponding to current state
- ((and (keymapp def)
- (boundp 'evil-state)
- (bound-and-true-p evil-local-mode)
- (string-match-p (format "<%s-state>$" evil-state)
key-desc))
- (setq bindings
- ;; this function keeps the latter of the two duplicates
- ;; which will be the evil binding
- (cl-remove-duplicates
- (append bindings
- (which-key--get-keymap-bindings def all prefix))
- :test (lambda (a b) (string= (car a) (car b))))))
- ((and (keymapp def)
- (string-match-p which-key--evil-keys-regexp key-desc)))
- ((and (keymapp def)
- (or all
- ;; event 27 is escape, so this will pick up meta
- ;; bindings and hopefully not too much more
- (and (numberp ev) (= ev 27))))
- (setq bindings
- (append bindings
- (which-key--get-keymap-bindings def t key))))
- (t
- (when def
- (cl-pushnew
- (cons key-desc
- (cond
- ((keymapp def) "Prefix Command")
- ((symbolp def) (copy-sequence (symbol-name def)))
- ((eq 'lambda (car-safe def)) "lambda")
- ((eq 'menu-item (car-safe def)) "menu-item")
- ((stringp def) def)
- ((vectorp def) (key-description def))
- ((consp def) (car def))
- (t "unknown")))
- bindings :test (lambda (a b) (string= (car a) (car
b)))))))))
- keymap)
- bindings))
-
(defun which-key--compute-binding (binding)
"Replace BINDING with remapped binding if it exists.
Requires `which-key-compute-remaps' to be non-nil"
(let (remap)
(if (and which-key-compute-remaps
- (setq remap (command-remapping (intern binding))))
+ (setq remap (command-remapping binding)))
(copy-sequence (symbol-name remap))
- binding)))
+ (copy-sequence (symbol-name binding)))))
+
+(defun which-key--get-menu-item-binding (def)
+ "Retrieve binding for menu-item"
+ ;; see `keymap--menu-item-binding'
+ (let* ((binding (nth 2 def))
+ (plist (nthcdr 3 def))
+ (filter (plist-get plist :filter)))
+ (if filter (funcall filter binding) binding)))
+
+(defun which-key--get-keymap-bindings-1
+ (keymap start &optional prefix filter all ignore-commands)
+ "See `which-key--get-keymap-bindings'."
+ (let ((bindings start)
+ (prefix-map (if prefix (lookup-key keymap prefix) keymap)))
+ (when (keymapp prefix-map)
+ (map-keymap
+ (lambda (ev def)
+ (let* ((key (vconcat prefix (list ev)))
+ (key-desc (key-description key)))
+ (cond
+ ((assoc key-desc bindings))
+ ((and (listp ignore-commands) (symbolp def) (memq def
ignore-commands)))
+ ((or (string-match-p
+ which-key--ignore-non-evil-keys-regexp key-desc)
+ (eq ev 'menu-bar)))
+ ((and (keymapp def)
+ (string-match-p which-key--evil-keys-regexp key-desc)))
+ ((and (keymapp def)
+ (or all
+ ;; event 27 is escape, so this will pick up meta
+ ;; bindings and hopefully not too much more
+ (and (numberp ev) (= ev 27))))
+ (setq bindings
+ (which-key--get-keymap-bindings-1
+ keymap bindings key nil all ignore-commands)))
+ (def
+ (let* ((def (if (eq 'menu-item (car-safe def))
+ (which-key--get-menu-item-binding def)
+ def))
+ (binding
+ (cons key-desc
+ (cond
+ ((keymapp def) "prefix")
+ ((symbolp def) (which-key--compute-binding def))
+ ((eq 'lambda (car-safe def)) "lambda")
+ ((stringp def) def)
+ ((vectorp def) (key-description def))
+ ((consp def) (concat (when (keymapp (cdr-safe def))
+ "group:")
+ (car def)))
+ (t "unknown")))))
+ (when (or (null filter)
+ (and (functionp filter)
+ (funcall filter binding)))
+ (push binding bindings)))))))
+ prefix-map))
+ bindings))
-(defun which-key--get-current-bindings (&optional prefix)
+(defun which-key--get-keymap-bindings
+ (keymap &optional start prefix filter all evil)
+ "Retrieve top-level bindings from KEYMAP.
+PREFIX limits bindings to those starting with this key
+sequence. START is a list of existing bindings to add to. If ALL
+is non-nil, recursively retrieve all bindings below PREFIX. If
+EVIL is non-nil, extract active evil bidings."
+ (let ((bindings start)
+ (ignore '(self-insert-command ignore ignore-event company-ignore))
+ (evil-map
+ (when (and evil (bound-and-true-p evil-local-mode))
+ (lookup-key keymap (kbd (format "<%s-state>" evil-state))))))
+ (when (keymapp evil-map)
+ (setq bindings (which-key--get-keymap-bindings-1
+ evil-map bindings prefix filter all ignore)))
+ (which-key--get-keymap-bindings-1
+ keymap bindings prefix filter all ignore)))
+
+(defun which-key--get-current-bindings (&optional prefix filter)
"Generate a list of current active bindings."
- (let ((key-str-qt (regexp-quote (key-description prefix)))
- (buffer (current-buffer))
- (ignore-bindings '("self-insert-command" "ignore"
- "ignore-event" "company-ignore"))
- (ignore-sections-regexp
- (eval-when-compile
- (regexp-opt '("Key translations" "Function key map translations"
- "Input decoding map translations")))))
- (with-temp-buffer
- (setq-local indent-tabs-mode t)
- (setq-local tab-width 8)
- (describe-buffer-bindings buffer prefix)
- (goto-char (point-min))
- (let ((header-p (not (= (char-after) ?\f)))
- bindings header)
- (while (not (eobp))
- (cond
- (header-p
- (setq header (buffer-substring-no-properties
- (point)
- (line-end-position)))
- (setq header-p nil)
- (forward-line 3))
- ((= (char-after) ?\f)
- (setq header-p t))
- ((looking-at "^[ \t]*$"))
- ((or (not (string-match-p ignore-sections-regexp header)) prefix)
- (let ((binding-start (save-excursion
- (and (re-search-forward "\t+" nil t)
- (match-end 0))))
- key binding)
- (when binding-start
- (setq key (buffer-substring-no-properties
- (point) binding-start))
- (setq binding (buffer-substring-no-properties
- binding-start
- (line-end-position)))
- (save-match-data
- (cond
- ((member binding ignore-bindings))
- ((string-match-p which-key--ignore-keys-regexp key))
- ((and prefix
- (string-match (format "^%s[ \t]\\([^ \t]+\\)[ \t]+$"
- key-str-qt) key))
- (unless (assoc-string (match-string 1 key) bindings)
- (push (cons (match-string 1 key)
- (which-key--compute-binding binding))
- bindings)))
- ((and prefix
- (string-match
- (format
- "^%s[ \t]\\([^ \t]+\\) \\.\\. %s[ \t]\\([^ \t]+\\)[
\t]+$"
- key-str-qt key-str-qt) key))
- (let ((stripped-key (concat (match-string 1 key)
- " \.\. "
- (match-string 2 key))))
- (unless (assoc-string stripped-key bindings)
- (push (cons stripped-key
- (which-key--compute-binding binding))
- bindings))))
- ((string-match
- "^\\([^ \t]+\\|[^ \t]+ \\.\\. [^ \t]+\\)[ \t]+$" key)
- (unless (assoc-string (match-string 1 key) bindings)
- (push (cons (match-string 1 key)
- (which-key--compute-binding binding))
- bindings)))))))))
- (forward-line))
- (nreverse bindings)))))
+ (let (bindings)
+ (dolist (map (current-active-maps t) bindings)
+ (when (cdr map)
+ (setq bindings
+ (which-key--get-keymap-bindings
+ map bindings prefix filter))))))
(defun which-key--get-bindings (&optional prefix keymap filter recursive)
"Collect key bindings.
@@ -1929,13 +1838,12 @@ is a function to use to filter the bindings. If
RECURSIVE is
non-nil, then bindings are collected recursively for all prefixes."
(let* ((unformatted
(cond ((keymapp keymap)
- (which-key--get-keymap-bindings keymap recursive))
+ (which-key--get-keymap-bindings
+ keymap prefix filter recursive))
(keymap
(error "%s is not a keymap" keymap))
(t
- (which-key--get-current-bindings prefix)))))
- (when filter
- (setq unformatted (cl-remove-if-not filter unformatted)))
+ (which-key--get-current-bindings prefix filter)))))
(when which-key-sort-order
(setq unformatted
(sort unformatted which-key-sort-order)))
