[elpa] externals/which-key e236920 14/32: Merge branch 'alt-get-bindings'

[ELPA Syncer]

branch: externals/which-key
commit e236920b231ee1d86ae215598f7a9d8294467310
Merge: 1f9c37d d6b56f3
Author: Justin Burkett <justin@burkett.cc>
Commit: Justin Burkett <justin@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)))