Feature/auto describe more binding types

which-key-tests.el

@@ -21,12 +21,13 @@
 ;;; Commentary:
 
 ;; Tests for which-key.el
-
 ;;; Code:
 
 (require 'which-key)
 (require 'ert)
 
+;; For some reason I'm not seeing ert-deftest in an interactive session
+
 (ert-deftest which-key-test-prefix-declaration ()
   "Test `which-key-declare-prefixes' and
 `which-key-declare-prefixes-for-mode'. See Bug #109."
@@ -45,5 +46,161 @@
               "C-c C-c" (cdr (assq 'test-mode which-key-key-based-description-replacement-alist)))
              '("C-c C-c" . ("complete" . "complete title"))))))
 
+(ert-deftest which-key-test-duplicate-key-elimination ()
+  "Make sure we eliminate shadowed keys from our current keymap"
+  (let ((our-map '(keymap (?a . first-match)
+                           (keymap (?a . second-match)))))
+    (should (equal
+             (which-key--describe-immediate-bindings our-map)
+             '(("a" . "first-match"))))))
+
+(ert-deftest which-key-test-esc-maps ()
+  (let ((our-map '(keymap (27 .
+                              (keymap (?a . command-a)
+                                      (?b . command-b)
+                                      (27 . double-escape)))))
+        (pred (lambda (a b)
+                (string-lessp (car a)
+                              (car b)))))
+
+    (should
+     (equal (reverse (which-key--describe-immediate-bindings our-map))
+            '(("M-a" . "command-a")
+              ("M-b" . "command-b")
+              ("ESC ESC" . "double-escape"))))))
+
+
+(ert-deftest which-key-test-fancy-descriptions ()
+  ;; menu items and lexical scope get a bit weird...
+  (put 'which-key-test--our-toggle 'is-on nil)
+  (let ((our-map '(keymap (?a menu-item (if (get 'which-key-test--our-toggle 'is-on)
+                                             "[*] toggle"
+                                           "[ ] toggle")
+                               menu-command))))
+    (should (equal (which-key--describe-immediate-bindings our-map)
+                   '(("a" . "[ ] toggle"))))
+    (put 'which-key-test--our-toggle 'is-on t)
+    (should (equal (which-key--describe-immediate-bindings our-map)
+                   '(("a" . "[*] toggle"))))
+    ))
+
+
+(ert-deftest which-key-test-simplify-base-binding-plain-symbol ()
+  "Given a binding, which--key-simpify-base-binding should return a symbol or
+a list"
+  (should (equal (which-key--simplify-base-binding 'symbol)
+              'symbol)))
+
+(ert-deftest which-key-test-simplify-base-binding-simple-menu-item-with-help ()
+  "An old 'simple' menu item with help maps to an appropriate (menu-item ...)"
+  (should
+   (equal (which-key--simplify-base-binding '("desc" "help string" .
+                                              (keymap (f1 . help-command))))
+          '(menu-item "desc" (keymap (f1 . help-command))
+                      :help "help string"))))
+
+(ert-deftest which-key-test-simplify-base-binding-simple-menu-item-without-help ()
+  (should (equal (which-key--simplify-base-binding '("desc" . 'symbol))
+                 '(menu-item "desc" 'symbol))))
+
+
+(ert-deftest which-key-test-describe-binding-for-simple-cases ()
+  (should (equal (which-key--describe-binding 'symbol)
+                 "symbol"))
+  (should (equal (which-key--describe-binding '(keymap (1 . foo)))
+                 "Prefix Command"))
+  (should (equal (which-key--describe-binding '(keymap "desc" (1 . foo)))
+                 "desc")))
+
+(ert-deftest which-key-test-describe-menu-item-0 ()
+  (should (equal (which-key--describe-binding '(menu-item "desc" foo))
+                 "desc")))
+
+(ert-deftest which-key-test-describe-menu-item-1 ()
+  (should (equal (which-key--describe-binding '(menu-item "desc" symbol :help "help"))
+                 "desc")))
+
+(ert-deftest which-key-test-describe-menu-item-2 ()
+  (should (equal (which-key--describe-binding '(menu-item (or nil "desc") cmd))
+                 "desc"))
+  (should (equal (which-key--describe-binding
+                  '(menu-item "desc" cmd
+                              :enable (or nil t)))
+                 "desc")))
+
+;; We're following whether these affect the keybinding; it may be that we'd
+;; like :visible to affect which-key's hinting. Should probably be an option,
+;; I supppose.
+(ert-deftest which-key-test-describe-menu-item-visible-is-ignored ()
+  "It seems that the :visible test is ignored except when building menus"
+  (should (equal (which-key--describe-binding
+                  '(menu-item "desc" cmd
+                              :visible nil))
+                 "desc")))
+
+;;; Same issues as for :visible
+(ert-deftest which-key-test-describe-enable-is-ignored ()
+  "And the same for :enable"
+  (should (equal (which-key--describe-binding
+                  '(menu-item "desc" cmd
+                              :enable (or nil nil)))
+                 "desc")))
+
+(ert-deftest which-key-test-describe-menu-item-4 ()
+  (should (equal (which-key--describe-binding
+                  '(menu-item "desc" cmd
+                              :filter (lambda (_)
+                                        'newline-and-indent)))
+                 "newline-and-indent")))
+
+
+(ert-deftest which-key-test-describe-menu-item-5 ()
+  (should (equal (which-key--describe-binding
+                  '(menu-item "desc" cmd
+                              :filter (lambda (_)
+                                        (lambda ()
+                                          (interactive)
+                                          (newline-and-indent)))))
+
+                 "desc")))
+
+(ert-deftest which-key-test-describe-menu-item-4 ()
+  (should (equal (which-key--describe-binding
+                  '(menu-item "desc" cmd
+                              :filter (lambda (_)
+                                        (lambda ()
+                                          "inner-desc"
+                                          (newline-and-indent)))))
+                 "inner-desc")))
+
+
+
+(ert-deftest which-key-test-describe-menu-item-5 ()
+  (should (equal (which-key--describe-binding
+                  '(menu-item "desc" cmd
+                              :filter (lambda (_)
+                                        '("inner-desc" . 'newline-and-indent))))
+                 "inner-desc")))
+
+
+(ert-deftest which-key-test-describe-lambda-without-docstr ()
+  (should (equal (which-key--describe-binding
+                  (lambda ()
+                    (interactive)))
+                 "lambda")))
+
+(ert-deftest which-key-test-describe-lambda-with-long-docstr ()
+  (should (equal (which-key--describe-binding
+                  (lambda ()
+                    "desc
+
+With a bunch of extended documentatation"
+                    (interactive)))
+                 "desc")))
+
+(ert-deftest which-key-test-describe-translation ()
+  (should (equal (which-key--describe-binding [?¤])
+                 "¤")))
+
 (provide 'which-key-tests)
 ;;; which-key-tests.el ends here

which-key.el

@@ -1,6 +1,6 @@
 ;;; which-key.el --- Display available keybindings in popup  -*- lexical-binding: t; -*-
 
-;; Copyright (C) 2015 Justin Burkett
+;; Copyrght (C) 2015 Justin Burkett
 
 ;; Author: Justin Burkett <justin@burkett.cc>
 ;; URL: https://github.com/justbur/emacs-which-key
@@ -966,11 +966,11 @@ call signature in different emacs versions"
      ((eq which-key--multiple-locations t)
       ;; possibly want to switch sides in this case so we can't reuse the window
       (delete-windows-on which-key--buffer)
-      (display-buffer-in-major-side-window which-key--buffer side 0 alist))
+      (window--make-major-side-window which-key--buffer side 0 alist))
      ((get-buffer-window which-key--buffer)
       (display-buffer-reuse-window which-key--buffer alist))
      (t
-      (display-buffer-in-major-side-window which-key--buffer side 0 alist)))))
+      (window--make-major-side-window which-key--buffer side 0 alist)))))
 
 (defun which-key--show-buffer-frame (act-popup-dim)
   "Show which-key buffer when popup type is frame."
@@ -1381,80 +1381,125 @@ alists. Returns a list (key separator description)."
        (unless (and (functionp filter) (funcall filter ev def))
          (cl-pushnew
           (cons (key-description (list ev))
-                (cond ((keymapp def) "Prefix Command")
+                (cond ((vectorp def) (copy-sequence (key-description def)))
+                      ((keymapp def) "Prefix Command")
                       ((symbolp def) (copy-sequence (symbol-name def)))
                       ((eq 'lambda (car-safe def)) "lambda")
                       (t (format "%s" def))))
           bindings :test (lambda (a b) (string= (car a) (car b))))))
      keymap)
     bindings))
 
-;; adapted from helm-descbinds
-(defun which-key--get-current-bindings ()
-  (let ((key-str-qt (regexp-quote (key-description which-key--current-prefix)))
-        (buffer (current-buffer))
-        (ignore-bindings '("self-insert-command" "ignore" "ignore-event" "company-ignore"))
-        (ignore-keys-regexp "mouse-\\|wheel-\\|remap\\|drag-\\|scroll-bar\\|select-window\\|switch-frame\\|-state")
-        (ignore-sections-regexp "\\(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 which-key--current-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)
-            ;; (push (cons header (nreverse section)) bindings)
-            ;; (setq section nil)
-            (setq header-p t))
-           ((looking-at "^[ \t]*$")
-            ;; ignore
-            )
-           ((or (not (string-match-p ignore-sections-regexp header))
-                which-key--current-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)
-                      ;; key (replace-regexp-in-string"^[ \t\n]+" "" key)
-                      ;; key (replace-regexp-in-string"[ \t\n]+$" "" key)
-                      )
-                (setq binding (buffer-substring-no-properties
-                               binding-start
-                               (line-end-position)))
-                (save-match-data
-                  (cond
-                   ((member binding ignore-bindings))
-                   ((string-match-p ignore-keys-regexp key))
-                   ((and which-key--current-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) binding) bindings)))
-                   ((and which-key--current-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 binding) bindings))))
-                   ((string-match "^\\([^ \t]+\\|[^ \t]+ \\.\\. [^ \t]+\\)[ \t]+$" key)
-                    (unless (assoc-string (match-string 1 key) bindings)
-                      (push (cons (match-string 1 key) binding) bindings)))))))))
-          (forward-line))
-        (nreverse bindings)))))
+(defun which-key--describe-immediate-bindings (keymap)
+  (when (keymapp keymap)
+    (let ((ignore-bindings '(self-insert-command ignore ignore-event company-ignore))
+          (ignore-keys-regexp "mouse-\\|wheel-\\|remap\\|drag-\\|scroll-bar\\|select-window\\|switch-frame\\|-state")
+          bindings)
+      (cl-flet* ((push-test (a b)
+                   (and (string= (car a) (car b))))
+                 (interestingp (desc binding)
+                   (and binding
+                        (not (member binding ignore-bindings))
+                        (not (string-match-p ignore-keys-regexp desc))))
+                 (describe-ESC-map (key binding)
+                   (if (keymapp binding)
+                       (map-keymap
+                        (lambda (key binding)
+                          (let ((kdesc (key-description (vector 27 key))))
+                            (when (interestingp kdesc binding)
+                              (let ((binding-desc (which-key--describe-binding binding)))
+                                (when binding-desc
+                                  (cl-pushnew
+                                   (cons kdesc binding-desc)
+                                   bindings
+                                   :test #'push-test))))))
+                        binding)
+                     (cl-pushnew (cons "ESC" (which-key--describe-binding binding))
+                                 bindings
+                                 :test #'push-test))))
+        (map-keymap
+         (lambda (key binding)
+           (if (and (numberp key) (= key 27))
+               (describe-ESC-map key binding)
+             (let ((kdesc (key-description (vector key))))
+               ;; We're only interested in the first binding for a key
+               ;; since that's what the 'real' key look up will use.
+               (when (interestingp kdesc binding)
+                 (let ((binding-desc (which-key--describe-binding binding)))
+                   (if binding-desc
+                       (cl-pushnew
+                        (cons kdesc binding-desc)
+                        bindings
+                        :test #'push-test)))))))
+         keymap))
+      bindings)))
+
+(defun which-key--get-current-bindings (&optional prefix)
+  "Get the current active bindings.
+
+Uses the optional PREFIX argument or the current which-key prefix
+to narrow down the bindings"
+  (let* ((raw-prefix (or prefix which-key--current-prefix))
+         (prefix (if (vectorp raw-prefix)
+                     raw-prefix
+                   (kbd raw-prefix)))
+         (prefix-bindings (key-binding prefix))
+         (translations (lookup-key key-translation-map prefix))
+         (translations (if (listp translations) translations)))
+    (which-key--describe-immediate-bindings
+     (if (not (and prefix-bindings (symbolp prefix-bindings)))
+         (make-composed-keymap translations prefix-bindings)
+       prefix-bindings))))
+
+
+(defun which-key--simplify-base-binding (binding)
+  "Simplify a binding form."
+  (pcase binding
+    ((or (pred functionp)
+         (pred symbolp)
+         (pred keymapp)
+         (pred vectorp)) binding)
+    (`(menu-item ,_ ,_ . ,_) binding)
+    (`(,(and (pred stringp)
+             desc)
+       ,(and (pred stringp)
+             help-str)
+       . ,bound)
+     (if (or (listp bound) (symbolp bound))
+         `(menu-item ,desc ,bound :help ,help-str)))
+    (`(,(and (pred stringp) desc)
+       . ,bound)
+     (if (or (listp bound) (symbolp bound))
+         `(menu-item ,desc ,bound)))))
+
+(defun which-key--describe-binding (binding)
+  (let ((binding (which-key--simplify-base-binding binding)))
+    (pcase binding
+      ((pred symbolp)
+       (copy-sequence (symbol-name binding)))
+      ((pred keymapp)
+       (or (copy-sequence (keymap-prompt binding))
+           "Prefix Command"))
+      ((pred functionp)
+       (let ((doc (documentation binding)))
+           (if doc
+               (substring doc 0 (string-match "\n" doc))
+             "lambda")))
+      (`(menu-item . ,_)
+       (which-key--describe-menu-item binding))
+      ((pred vectorp)
+       (key-description binding)))))
+
+
+(defun which-key--describe-menu-item (menu-item)
+  (pcase-let ((`(menu-item ,desc ,default-binding . ,props) menu-item))
+    (cond ((plist-member props :filter)
+           (let ((map-desc (which-key--describe-binding
+                            (funcall (plist-get props :filter) default-binding))))
+             (if (equal map-desc "lambda")
+                 (eval desc)
+               map-desc)))
+          (t (eval desc)))))
 
 (defun which-key--get-formatted-key-bindings (&optional bindings)
   "Uses `describe-buffer-bindings' to collect the key bindings in