bug#13948: no key-binding-locus

[Nicolas Richard]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

>>> This list of advertized vars could be built dynamically mimicking
>>> current-active-maps.

Here's another attempt. Like the previous patch, I define
key-binding-keymap which finds the keymap by mimicking key-binding, and
describe-key--binding-locus which matches the keymap to a symbol and
makes a description suitable for describe-key.

Sorry it is a bit lengthy but I'm afraid I don't know better.

diff --git a/lisp/help.el b/lisp/help.el
index 72a9524..9721fcf 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -647,6 +647,74 @@ temporarily enables it to allow getting help on disabled 
items and buttons."
        (princ (format "%s%s is undefined" key-desc mouse-msg))
       (princ (format "%s%s runs the command %S" key-desc mouse-msg defn)))))
 
+(defun key-binding-keymap (key &optional accept-default no-remap position)
+  "Return a keymap holding a binding for KEY within current keymaps.
+The effect of the arguments KEY, ACCEPT-DEFAULT, NO-REMAP and
+POSITION is as documented in the function `key-binding'."
+  (let* ((active-maps (current-active-maps t position))
+         map found)
+    ;; we loop over active maps like key-binding does.
+    (while (and
+            (not found)
+            (setq map (pop active-maps)))
+      (setq found (lookup-key
+                   map
+                   key
+                   accept-default))
+      (when (integerp found)
+        ;; prefix was found but not the whole sequence
+        (setq found nil)))
+    (when found
+      (if (and (symbolp found)
+               (not no-remap)
+               (command-remapping found))
+          (key-binding-keymap (vector 'remap found))
+        map))))
+
+(defun describe-key--binding-locus (key position)
+  "Describe in which keymap KEY is defined.
+Return the description (a string)."
+  (or
+   (let ((map (key-binding-keymap key t nil position)))
+     (when map
+       (let ((advertised-syms (nconc
+                               (list 'overriding-terminal-local-map
+                                     'overriding-local-map)
+                               (delq nil
+                                     (mapcar
+                                      (lambda (mode)
+                                        (when
+                                            (symbol-value mode)
+                                          (intern
+                                           (format "%s-map" mode))))
+                                      minor-mode-list)) 
+                               (list 'global-map
+                                     (intern (format "%s-map" major-mode)))))
+             found)
+         ;; look into these advertised symbols first
+         (while (and (not found) advertised-syms)
+           (let ((sym (pop advertised-syms)))
+             (setq found
+                   (when (and
+                          (boundp sym)
+                          (eq map (symbol-value sym)))
+                     sym))))
+         ;; only look in other symbols otherwise
+         (when (not found)
+           (mapatoms
+            (lambda (x)
+              (when (and (boundp x)
+                         ;; avoid let-bound symbols
+                         (special-variable-p x)
+                         (eq (symbol-value x) map))
+                (push x found))))
+           (when (and (consp found)
+                      (null (cdr found)))
+             (setq found (car found))))
+         (when found
+           (format " (found in %s)" found)))))
+   ""))
+
 (defun describe-key (&optional key untranslated up-event)
   "Display documentation of the function invoked by KEY.
 KEY can be any kind of a key sequence; it can include keyboard events,
@@ -709,6 +777,7 @@ temporarily enables it to allow getting help on disabled 
items and buttons."
         (mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers)
                            (memq 'drag modifiers)) " at that spot" ""))
         (defn (key-binding key t))
+         key-locus key-locus-up key-locus-up-tricky
         defn-up defn-up-tricky ev-type
         mouse-1-remapped mouse-1-tricky)
 
@@ -747,15 +816,17 @@ temporarily enables it to allow getting help on disabled 
items and buttons."
                   (setcar up-event (elt mouse-1-remapped 0)))
                  (t (setcar up-event 'mouse-2))))
          (setq defn-up (key-binding sequence nil nil (event-start up-event)))
+          (setq key-locus-up (describe-key--binding-locus sequence 
(event-start up-event)))
          (when mouse-1-tricky
            (setq sequence (vector up-event))
            (aset sequence 0 'mouse-1)
-           (setq defn-up-tricky (key-binding sequence nil nil (event-start 
up-event))))))
+           (setq defn-up-tricky (key-binding sequence nil nil (event-start 
up-event)))
+            (setq key-locus-up-tricky (describe-key--binding-locus sequence 
(event-start up-event))))))
+      (setq key-locus (describe-key--binding-locus key (event-start event)))
       (with-help-window (help-buffer)
        (princ (help-key-description key untranslated))
-       (princ (format "\
-%s runs the command %S, which is "
-                      mouse-msg defn))
+       (princ (format "%s runs the command %S%s, which is "
+                      mouse-msg defn key-locus))
        (describe-function-1 defn)
        (when up-event
          (unless (or (null defn-up)
@@ -765,13 +836,13 @@ temporarily enables it to allow getting help on disabled 
items and buttons."
 
 ----------------- up-event %s----------------
 
-%s%s%s runs the command %S, which is "
+%s%s%s runs the command %S%s, which is "
                           (if mouse-1-tricky "(short click) " "")
                           (key-description (vector up-event))
                           mouse-msg
                           (if mouse-1-remapped
                                " is remapped to <mouse-2>, which" "")
-                          defn-up))
+                          defn-up key-locus-up))
            (describe-function-1 defn-up))
          (unless (or (null defn-up-tricky)
                      (integerp defn-up-tricky)
@@ -781,10 +852,10 @@ temporarily enables it to allow getting help on disabled 
items and buttons."
 ----------------- up-event (long click) ----------------
 
 Pressing <%S>%s for longer than %d milli-seconds
-runs the command %S, which is "
+runs the command %S%s, which is "
                           ev-type mouse-msg
                           mouse-1-click-follows-link
-                          defn-up-tricky))
+                          defn-up-tricky key-locus-up-tricky))
            (describe-function-1 defn-up-tricky)))))))
 
 (defun describe-mode (&optional buffer)

-- 
Nico.