[Emacs-diffs] master 2bd32ed 1/2: Refactor key describing commands

[Noam Postavsky]

branch: master
commit 2bd32ede1ce05b88278bab15f6cc603c97a1fb2f
Author: Noam Postavsky <address@hidden>
Commit: Noam Postavsky <address@hidden>

    Refactor key describing commands
    
    * lisp/help.el (help-read-key-sequence, help--analyze-key): New
    functions, extracted from `describe-key' and `describe-key-briefly'.
    (describe-key, describe-key-briefly): Use them.
---
 lisp/help.el | 251 ++++++++++++++++++++++++-----------------------------------
 1 file changed, 103 insertions(+), 148 deletions(-)

diff --git a/lisp/help.el b/lisp/help.el
index 361ab2a..78687a9 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -593,6 +593,39 @@ If INSERT (the prefix arg) is non-nil, insert the message 
in the buffer."
            string
          (format "%s (translated from %s)" string otherstring))))))
 
+(defun help--analyze-key (key untranslated)
+  "Get information about KEY its corresponding UNTRANSLATED events.
+Returns a list of the form (BRIEF-DESC DEFN EVENT MOUSE-MSG)."
+  (if (numberp untranslated)
+      (setq untranslated (this-single-command-raw-keys)))
+  (let* ((event (aref key (if (and (symbolp (aref key 0))
+                                  (> (length key) 1)
+                                  (consp (aref key 1)))
+                             1
+                           0)))
+        (modifiers (event-modifiers event))
+        (mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers)
+                           (memq 'drag modifiers)) " at that spot" ""))
+        (defn (key-binding key t)))
+    ;; Handle the case where we faked an entry in "Select and Paste" menu.
+    (when (and (eq defn nil)
+              (stringp (aref key (1- (length key))))
+              (eq (key-binding (substring key 0 -1)) 'yank-menu))
+      (setq defn 'menu-bar-select-yank))
+    ;; Don't bother user with strings from (e.g.) the select-paste menu.
+    (when (stringp (aref key (1- (length key))))
+      (aset key (1- (length key)) "(any string)"))
+    (when (and untranslated
+               (stringp (aref untranslated (1- (length untranslated)))))
+      (aset untranslated (1- (length untranslated)) "(any string)"))
+    (list
+     ;; Now describe the key, perhaps as changed.
+     (let ((key-desc (help-key-description key untranslated)))
+       (if (or (null defn) (integerp defn) (equal defn 'undefined))
+           (format "%s%s is undefined" key-desc mouse-msg)
+         (format "%s%s runs the command %S" key-desc mouse-msg defn)))
+     defn event mouse-msg)))
+
 (defun describe-key-briefly (&optional key insert untranslated)
   "Print the name of the function KEY invokes.  KEY is a string.
 If INSERT (the prefix arg) is non-nil, insert the message in the buffer.
@@ -603,73 +636,10 @@ the last key hit are used.
 If KEY is a menu item or a tool-bar button that is disabled, this command
 temporarily enables it to allow getting help on disabled items and buttons."
   (interactive
-   (let ((enable-disabled-menus-and-buttons t)
-        (cursor-in-echo-area t)
-        saved-yank-menu)
-     (unwind-protect
-        (let (key)
-          ;; If yank-menu is empty, populate it temporarily, so that
-          ;; "Select and Paste" menu can generate a complete event.
-          (when (null (cdr yank-menu))
-            (setq saved-yank-menu (copy-sequence yank-menu))
-            (menu-bar-update-yank-menu "(any string)" nil))
-           (while
-               (progn
-                 (setq key (read-key-sequence "Describe the following key, 
mouse click, or menu item: "))
-                 (and (vectorp key)
-                      (consp (aref key 0))
-                      (symbolp (car (aref key 0)))
-                      (string-match "\\(mouse\\|down\\|click\\|drag\\)"
-                                    (symbol-name (car (aref key 0))))
-                      (not (sit-for (/ double-click-time 1000.0) t)))))
-          ;; Clear the echo area message (Bug#7014).
-          (message nil)
-          ;; If KEY is a down-event, read and discard the
-          ;; corresponding up-event.  Note that there are also
-          ;; down-events on scroll bars and mode lines: the actual
-          ;; event then is in the second element of the vector.
-          (and (vectorp key)
-               (let ((last-idx (1- (length key))))
-                 (and (eventp (aref key last-idx))
-                      (memq 'down (event-modifiers (aref key last-idx)))))
-               (read-event))
-          (list
-           key
-           (if current-prefix-arg (prefix-numeric-value current-prefix-arg))
-           1))
-       ;; Put yank-menu back as it was, if we changed it.
-       (when saved-yank-menu
-        (setq yank-menu (copy-sequence saved-yank-menu))
-        (fset 'yank-menu (cons 'keymap yank-menu))))))
-  (if (numberp untranslated)
-      (setq untranslated (this-single-command-raw-keys)))
-  (let* ((event (if (and (symbolp (aref key 0))
-                        (> (length key) 1)
-                        (consp (aref key 1)))
-                   (aref key 1)
-                 (aref key 0)))
-        (modifiers (event-modifiers event))
-        (standard-output (if insert (current-buffer) standard-output))
-        (mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers)
-                           (memq 'drag modifiers)) " at that spot" ""))
-        (defn (key-binding key t))
-        key-desc)
-    ;; Handle the case where we faked an entry in "Select and Paste" menu.
-    (if (and (eq defn nil)
-            (stringp (aref key (1- (length key))))
-            (eq (key-binding (substring key 0 -1)) 'yank-menu))
-       (setq defn 'menu-bar-select-yank))
-    ;; Don't bother user with strings from (e.g.) the select-paste menu.
-    (if (stringp (aref key (1- (length key))))
-       (aset key (1- (length key)) "(any string)"))
-    (if (and (> (length untranslated) 0)
-            (stringp (aref untranslated (1- (length untranslated)))))
-       (aset untranslated (1- (length untranslated)) "(any string)"))
-    ;; Now describe the key, perhaps as changed.
-    (setq key-desc (help-key-description key untranslated))
-    (if (or (null defn) (integerp defn) (equal defn 'undefined))
-       (princ (format "%s%s is undefined" key-desc mouse-msg))
-      (princ (format "%s%s runs the command %S" key-desc mouse-msg defn)))))
+   (pcase-let ((`(,key ,_up-event) (help-read-key-sequence)))
+     `(,key ,current-prefix-arg 1)))
+  (princ (car (help--analyze-key key untranslated))
+         (if insert (current-buffer) standard-output)))
 
 (defun help--key-binding-keymap (key &optional accept-default no-remap 
position)
   "Return a keymap holding a binding for KEY within current keymaps.
@@ -734,6 +704,55 @@ function `key-binding'."
                (throw 'found x))))
           nil)))))
 
+(defun help-read-key-sequence ()
+  "Reads a key sequence from the user.
+Returns a list of the form (KEY UP-EVENT), where KEY is the key
+sequence, and UP-EVENT is the up-event that was discarded by
+reading KEY, or nil."
+  (let ((enable-disabled-menus-and-buttons t)
+        (cursor-in-echo-area t)
+        saved-yank-menu)
+    (unwind-protect
+        (let (key)
+          ;; If yank-menu is empty, populate it temporarily, so that
+          ;; "Select and Paste" menu can generate a complete event.
+          (when (null (cdr yank-menu))
+            (setq saved-yank-menu (copy-sequence yank-menu))
+            (menu-bar-update-yank-menu "(any string)" nil))
+          (while
+              (pcase (setq key (read-key-sequence "\
+Describe the following key, mouse click, or menu item: "))
+                ((and (pred vectorp) (let `(,key0 . ,_) (aref key 0))
+                      (guard (symbolp key0)) (let keyname (symbol-name key0)))
+                 (and (string-match "\\(mouse\\|down\\|click\\|drag\\)"
+                                    keyname)
+                      (not (sit-for (/ double-click-time 1000.0) t))))))
+          (list
+           key
+           ;; If KEY is a down-event, read and include the
+           ;; corresponding up-event.  Note that there are also
+           ;; down-events on scroll bars and mode lines: the actual
+           ;; event then is in the second element of the vector.
+           (and (vectorp key)
+                (let ((last-idx (1- (length key))))
+                  (and (eventp (aref key last-idx))
+                       (memq 'down (event-modifiers (aref key last-idx)))))
+                (or (and (eventp (aref key 0))
+                         (memq 'down (event-modifiers (aref key 0)))
+                         ;; However, for the C-down-mouse-2 popup
+                         ;; menu, there is no subsequent up-event.  In
+                         ;; this case, the up-event is the next
+                         ;; element in the supplied vector.
+                         (= (length key) 1))
+                    (and (> (length key) 1)
+                         (eventp (aref key 1))
+                         (memq 'down (event-modifiers (aref key 1)))))
+                (read-event))))
+      ;; Put yank-menu back as it was, if we changed it.
+      (when saved-yank-menu
+        (setq yank-menu (copy-sequence saved-yank-menu))
+        (fset 'yank-menu (cons 'keymap yank-menu))))))
+
 (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,
@@ -748,83 +767,20 @@ UP-EVENT is the up-event that was discarded by reading 
KEY, or nil.
 If KEY is a menu item or a tool-bar button that is disabled, this command
 temporarily enables it to allow getting help on disabled items and buttons."
   (interactive
-   (let ((enable-disabled-menus-and-buttons t)
-        (cursor-in-echo-area t)
-        saved-yank-menu)
-     (unwind-protect
-        (let (key)
-          ;; If yank-menu is empty, populate it temporarily, so that
-          ;; "Select and Paste" menu can generate a complete event.
-          (when (null (cdr yank-menu))
-            (setq saved-yank-menu (copy-sequence yank-menu))
-            (menu-bar-update-yank-menu "(any string)" nil))
-           (while
-               (progn
-                 (setq key (read-key-sequence "Describe the following key, 
mouse click, or menu item: "))
-                 (and (vectorp key)
-                      (consp (aref key 0))
-                      (symbolp (car (aref key 0)))
-                      (string-match "\\(mouse\\|down\\|click\\|drag\\)"
-                                    (symbol-name (car (aref key 0))))
-                      (not (sit-for (/ double-click-time 1000.0) t)))))
-          (list
-           key
-           (prefix-numeric-value current-prefix-arg)
-           ;; If KEY is a down-event, read and include the
-           ;; corresponding up-event.  Note that there are also
-           ;; down-events on scroll bars and mode lines: the actual
-           ;; event then is in the second element of the vector.
-           (and (vectorp key)
-                (let ((last-idx (1- (length key))))
-                  (and (eventp (aref key last-idx))
-                       (memq 'down (event-modifiers (aref key last-idx)))))
-                (or (and (eventp (aref key 0))
-                         (memq 'down (event-modifiers (aref key 0)))
-                         ;; However, for the C-down-mouse-2 popup
-                         ;; menu, there is no subsequent up-event.  In
-                         ;; this case, the up-event is the next
-                         ;; element in the supplied vector.
-                         (= (length key) 1))
-                    (and (> (length key) 1)
-                         (eventp (aref key 1))
-                         (memq 'down (event-modifiers (aref key 1)))))
-                (read-event))))
-       ;; Put yank-menu back as it was, if we changed it.
-       (when saved-yank-menu
-        (setq yank-menu (copy-sequence saved-yank-menu))
-        (fset 'yank-menu (cons 'keymap yank-menu))))))
-  (if (numberp untranslated)
-      (setq untranslated (this-single-command-raw-keys)))
-  (let* ((event (aref key (if (and (symbolp (aref key 0))
-                                  (> (length key) 1)
-                                  (consp (aref key 1)))
-                             1
-                           0)))
-        (modifiers (event-modifiers event))
-        (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)
-
-    ;; Handle the case where we faked an entry in "Select and Paste" menu.
-    (when (and (eq defn nil)
-              (stringp (aref key (1- (length key))))
-              (eq (key-binding (substring key 0 -1)) 'yank-menu))
-      (setq defn 'menu-bar-select-yank))
-    (if (or (null defn) (integerp defn) (equal defn 'undefined))
-       (message "%s%s is undefined"
-                (help-key-description key untranslated) mouse-msg)
+   (pcase-let ((`(,key ,up-event) (help-read-key-sequence)))
+     `(,key ,(prefix-numeric-value current-prefix-arg) ,up-event)))
+  (pcase-let ((`(,brief-desc ,defn ,event ,mouse-msg)
+               (help--analyze-key key untranslated))
+              (defn-up nil) (defn-up-tricky nil)
+              (key-locus-up nil) (key-locus-up-tricky nil)
+              (mouse-1-remapped nil) (mouse-1-tricky nil)
+              (ev-type nil))
+    (if (or (null defn)
+            (integerp defn)
+            (equal defn 'undefined))
+        (message "%s" brief-desc)
       (help-setup-xref (list #'describe-function defn)
                       (called-interactively-p 'interactive))
-      ;; Don't bother user with strings from (e.g.) the select-paste menu.
-      (when (stringp (aref key (1- (length key))))
-       (aset key (1- (length key)) "(any string)"))
-      (when (and untranslated
-                (stringp (aref untranslated (1- (length untranslated)))))
-       (aset untranslated (1- (length untranslated))
-             "(any string)"))
       ;; Need to do this before erasing *Help* buffer in case event
       ;; is a mouse click in an existing *Help* buffer.
       (when up-event
@@ -849,13 +805,12 @@ temporarily enables it to allow getting help on disabled 
items and buttons."
            (aset sequence 0 'mouse-1)
            (setq defn-up-tricky (key-binding sequence nil nil (event-start 
up-event)))
             (setq key-locus-up-tricky (help--binding-locus sequence 
(event-start up-event))))))
-      (setq key-locus (help--binding-locus key (event-start event)))
       (with-help-window (help-buffer)
-       (princ (help-key-description key untranslated))
-       (princ (format "%s runs the command %S%s, which is "
-                      mouse-msg defn (if key-locus
-                                          (format " (found in %s)" key-locus)
-                                        "")))
+        (princ brief-desc)
+        (let ((key-locus (help--binding-locus key (event-start event))))
+          (when key-locus
+            (princ (format " (found in %s)" key-locus))))
+        (princ ", which is ")
        (describe-function-1 defn)
        (when up-event
          (unless (or (null defn-up)