scratch/substitute-command-keys 3e07277: Translate describe_map to Lisp

[Stefan Kangas]

branch: scratch/substitute-command-keys
commit 3e07277b780bf1edd8fc6969980496d8ec52f0b7
Author: Stefan Kangas <stefankangas@gmail.com>
Commit: Stefan Kangas <stefankangas@gmail.com>

    Translate describe_map to Lisp
    
    Third step in converting substitute-command-keys to Lisp.
    
    * lisp/help.el (describe-map): New Lisp version of describe_map.
    (help--describe-map-compare, help--describe-translation)
    (help--describe-command, help--shadow-lookup): New helper
    functions for describe-map.
    (internal--seen, help--previous-description-column): New
    variables.
    * src/keymap.c
    (Fkeymap__get_keyelt): New defun to expose get_keyelt to Lisp.
    (Fkeymap__shadow_lookup): New defun to expose shadow_lookup to Lisp.
    (Fdescribe_map_tree_old, Fdescribe_map): Remove defuns.
    (Fdescribe_vector_internal): New defun to expose describe_vector to
    Lisp in a way usable by describe-map.
    (syms_of_keymap): New defsubrs for Fkeymap__get_keyelt,
    Fkeymap__shadow_lookup and Fdescribe_vector_internal.  Remove defsubrs
    for Fdescribe_map_tree_old and Fdescribe_map.
    * test/lisp/help-tests.el
    (help-tests-substitute-command-keys/shadow): Extend test.
    (help-tests-substitute-command-keys/test-mode):
    (help-tests-substitute-command-keys/compare-all): New tests.
---
 lisp/help.el            | 162 ++++++++++++++++++++++++++++++++++++++++++++++++
 src/keymap.c            | 108 ++++++++++++++++----------------
 test/lisp/help-tests.el |  43 ++++++++++++-
 3 files changed, 257 insertions(+), 56 deletions(-)

diff --git a/lisp/help.el b/lisp/help.el
index b7f3987..eb073e7 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1119,6 +1119,7 @@ Otherwise, return a new string."
         ;; (if (string= string (buffer-string)) string (buffer-string))
         (buffer-string)))))
 
+(defvar internal--seen)
 (defun describe-map-tree (startmap partial shadow prefix title no-menu
                                    transl always-title mention-shadow)
   "Insert a description of the key bindings in STARTMAP.
@@ -1204,6 +1205,167 @@ Any inserted text ends in two newlines (used by
     (when print-title
       (princ "\n"))))
 
+(defun help--shadow-lookup (keymap key accept-default remap)
+  "Like `lookup-key', but with command remapping.
+Return nil if the key sequence is too long."
+  ;; Converted from shadow_lookup in keymap.c.
+  (let ((value (lookup-key keymap key accept-default)))
+    (when (and (fixnump value) (> 0 value))
+      (if (and value remap (symbolp value))
+          (or (command-remapping value nil keymap)
+              value)
+        value))))
+
+(defvar help--previous-description-column)
+(defun help--describe-command (definition)
+  ;; Converted from describe_command in keymap.c.
+  ;; If column 16 is no good, go to col 32;
+  ;; but don't push beyond that--go to next line instead.
+  (let* ((column (current-column))
+         (description-column (cond ((> column 30)
+                                    (insert "\n")
+                                    32)
+                                   ((or (> column 14)
+                                        (and (> column 10)
+                                             (= 
help--previous-description-column 32)))
+                                    32)
+                                   (t 16))))
+    (indent-to description-column 1)
+    (setq help--previous-description-column description-column)
+    (cond ((symbolp definition)
+           (insert (symbol-name definition) "\n"))
+          ((or (stringp definition) (vectorp definition))
+           (insert "Keyboard Macro\n"))
+          ((keymapp definition)
+           (insert "Prefix Command\n"))
+          (t (insert "??\n")))))
+
+(defun help--describe-translation (definition)
+  ;; Converted from describe_translation in keymap.c.
+  (indent-to 16 1)
+  (cond ((symbolp definition)
+         (insert (symbol-name definition) "\n"))
+        ((or (stringp definition) (vectorp definition))
+         (insert (key-description definition nil) "\n"))
+        ((keymapp definition)
+         (insert "Prefix Command\n"))
+        (t (insert "??\n"))))
+
+(defun help--describe-map-compare (a b)
+  (let ((a (car a))
+        (b (car b)))
+    (cond ((and (fixnump a) (fixnump b)) (< a b))
+          ;; ((and (not (fixnump a)) (fixnump b)) nil) ; not needed
+          ((and (fixnump a) (not (fixnump b))) t)
+          ((and (symbolp a) (symbolp b))
+           ;; Sort the keystroke names in the "natural" way, with (for
+           ;; instance) "<f2>" coming between "<f1>" and "<f11>".
+           (string-version-lessp (symbol-name a) (symbol-name b)))
+          (t nil))))
+
+(defun describe-map (map prefix transl partial shadow nomenu mention-shadow)
+  "Describe the contents of map MAP.
+Assume that this map itself is reached by the sequence of prefix
+keys PREFIX (a string or vector).
+
+PARTIAL, SHADOW, NOMENU are as in `describe_map_tree'."
+  ;; Converted from describe_map in keymap.c.
+  (let* ((suppress (and partial 'suppress-keymap))
+         (map (keymap-canonicalize map))
+         (tail map)
+         (first t)
+         done vect)
+    (while (and (consp tail) (not done))
+      (cond ((or (vectorp (car tail)) (char-table-p (car tail)))
+             (describe-vector-internal (car tail) prefix transl partial
+                                       shadow map t mention-shadow))
+            ((consp (car tail))
+             (let ((event (caar tail))
+                   definition this-shadowed)
+               ;; Ignore bindings whose "prefix" are not really
+              ;; valid events. (We get these in the frames and
+              ;; buffers menu.)
+               (and (or (symbolp event) (fixnump event))
+                    (not (and nomenu (eq event 'menu-bar)))
+                    ;; Don't show undefined commands or suppressed
+                    ;; commands.
+                    (setq definition (keymap--get-keyelt (cdr (car tail)) nil))
+                    (or (not (symbolp definition))
+                        (null (get definition suppress)))
+                    ;; Don't show a command that isn't really
+                    ;; visible because a local definition of the
+                    ;; same key shadows it.
+                    (or (not shadow)
+                        (let ((tem (keymap--shadow-lookup shadow (vector 
event) t 0)))
+                          (cond ((null tem) t)
+                                ;; If both bindings are keymaps,
+                               ;; this key is a prefix key, so
+                               ;; don't say it is shadowed.
+                                ((and (keymapp definition) (keymapp tem)) t)
+                                ;; Avoid generating duplicate
+                               ;; entries if the shadowed binding
+                               ;; has the same definition.
+                                ((setq this-shadowed t))
+                                (t nil))))
+                    (push (list event definition this-shadowed) vect))))
+            ((eq (car tail) 'keymap)
+             ;; The same keymap might be in the structure twice, if
+            ;; we're using an inherited keymap.  So skip anything
+            ;; we've already encountered.
+             (let ((tem (assq tail internal--seen)))
+               (if (and (consp tem)
+                        (equal (car tem) prefix))
+                   (setq done t)
+                 (push (cons tail prefix) internal--seen)))))
+      (setq tail (cdr tail)))
+    ;; If we found some sparse map events, sort them.
+    (let ((vect (sort vect 'help--describe-map-compare)))
+      ;; Now output them in sorted order.
+      (while vect
+        (let* ((elem (car vect))
+               (start (car elem))
+               (definition (cadr elem))
+               (shadowed (caddr elem))
+               (end start))
+          (when first
+            (setq help--previous-description-column 0)
+            (insert "\n")
+            (setq first nil))
+          ;; Find consecutive chars that are identically defined.
+          (when (fixnump start)
+            (while (and (cdr vect)
+                        (let ((this-event (caar vect))
+                              (this-definition (cadar vect))
+                              (this-shadowed (caddar vect))
+                              (next-event (caar (cdr vect)))
+                              (next-definition (cadar (cdr vect)))
+                              (next-shadowed (caddar (cdr vect))))
+                          (and (eq next-event (1+ this-event))
+                               (not (null (equal next-definition 
this-definition)))
+                               (eq this-shadowed next-shadowed))))
+              (setq vect (cdr vect))
+              (setq end (caar vect))))
+          ;; Now START .. END is the range to describe next.
+          ;; Insert the string to describe the event START.
+          (insert (key-description (vector start) prefix))
+          (when (not (eq start end))
+            (insert " .. " (key-description (vector end) prefix)))
+          ;; Print a description of the definition of this character.
+         ;; Called function will take care of spacing out far enough
+         ;; for alignment purposes.
+          (if transl
+              (help--describe-translation definition)
+            (help--describe-command definition))
+          ;; Print a description of the definition of this character.
+         ;; elt_describer will take care of spacing out far enough for
+         ;; alignment purposes.
+          (when shadowed
+            (goto-char (max (1- (point)) (point-min)))
+            (insert "\n  (that binding is currently shadowed by another mode)")
+            (goto-char (min (1+ (point)) (point-max)))))
+        ;; Next item in list.
+        (setq vect (cdr vect))))))
+
 
 (declare-function x-display-pixel-height "xfns.c" (&optional terminal))
 (declare-function x-display-pixel-width "xfns.c" (&optional terminal))
diff --git a/src/keymap.c b/src/keymap.c
index 7895ba0..a1e57ea 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -679,6 +679,23 @@ usage: (map-keymap FUNCTION KEYMAP)  */)
   return Qnil;
 }
 
+DEFUN ("keymap--get-keyelt", Fkeymap__get_keyelt, Skeymap__get_keyelt, 2, 2, 0,
+       doc: /* Given OBJECT which was found in a slot in a keymap,
+trace indirect definitions to get the actual definition of that slot.
+An indirect definition is a list of the form
+(KEYMAP . INDEX), where KEYMAP is a keymap or a symbol defined as one
+and INDEX is the object to look up in KEYMAP to yield the definition.
+
+Also if OBJECT has a menu string as the first element,
+remove that.  Also remove a menu help string as second element.
+
+If AUTOLOAD, load autoloadable keymaps
+that are referred to with indirection.  */)
+  (Lisp_Object object, Lisp_Object autoload)
+{
+  return get_keyelt (object, NILP(autoload) ? false : true);
+}
+
 /* Given OBJECT which was found in a slot in a keymap,
    trace indirect definitions to get the actual definition of that slot.
    An indirect definition is a list of the form
@@ -2374,6 +2391,15 @@ shadow_lookup (Lisp_Object keymap, Lisp_Object key, 
Lisp_Object accept_default,
     return value;
 }
 
+DEFUN ("keymap--shadow-lookup", Fkeymap__shadow_lookup, 
Skeymap__shadow_lookup, 4, 4, 0,
+       doc: /* Like `lookup-key', but with command remapping.
+Just returns nil if the key sequence is too long.  */)
+  (Lisp_Object keymap, Lisp_Object key, Lisp_Object accept_default,
+   Lisp_Object remap)
+{
+  return shadow_lookup (keymap, key, accept_default, NILP(remap) ? false : 
true);
+}
+
 static Lisp_Object Vmouse_events;
 
 struct where_is_internal_data {
@@ -2915,37 +2941,6 @@ You type        Translation\n\
 
    Any inserted text ends in two newlines (used by `help-make-xrefs').  */
 
-DEFUN ("describe-map-tree-old", Fdescribe_map_tree_old, 
Sdescribe_map_tree_old, 1, 8, 0,
-       doc: /* This is just temporary.  */)
-  (Lisp_Object startmap, Lisp_Object partial, Lisp_Object shadow,
-   Lisp_Object prefix, Lisp_Object title, Lisp_Object nomenu,
-   Lisp_Object transl, Lisp_Object always_title)
-{
-  ptrdiff_t count = SPECPDL_INDEX ();
-  char *title_string;
-
-  if ( !NILP (title) )
-    {
-      CHECK_STRING (title);
-      title_string = SSDATA(title);
-    }
-  else
-    {
-      title_string = NULL;
-    }
-
-  bool b_partial = NILP (partial) ? false : true;
-  bool b_nomenu = NILP (nomenu) ? false : true;
-  bool b_transl = NILP (transl) ? false : true;
-  bool b_always_title = NILP (always_title) ? false : true;
-
-  /* specbind (Qstandard_output, Fcurrent_buffer ()); */
-  describe_map_tree (startmap, b_partial, shadow, prefix, title_string,
-                    b_nomenu, b_transl, b_always_title, true);
-
-  return unbind_to (count, Qnil);
-}
-
 void
 describe_map_tree (Lisp_Object startmap, bool partial, Lisp_Object shadow,
                   Lisp_Object prefix, const char *title, bool nomenu,
@@ -3131,27 +3126,6 @@ describe_map_compare (const void *aa, const void *bb)
   return 0;
 }
 
-DEFUN ("describe-map", Fdescribe_map, Sdescribe_map, 1, 7, 0,
-       doc: /* This is a temporary definition preparing the transition
-of this function to Lisp.  */)
-  (Lisp_Object map, Lisp_Object prefix,
-   Lisp_Object transl, Lisp_Object partial, Lisp_Object shadow,
-   Lisp_Object nomenu, Lisp_Object mention_shadow)
-{
-  ptrdiff_t count = SPECPDL_INDEX ();
-
-  bool b_transl = NILP(transl) ? false : true;
-  bool b_partial = NILP (partial) ? false : true;
-  bool b_nomenu = NILP (nomenu) ? false : true;
-  bool b_mention_shadow = NILP (mention_shadow) ? false : true;
-  describe_map (map, prefix,
-               b_transl ? describe_translation : describe_command,
-               b_partial, shadow, &Vinternal_seen,
-               b_nomenu, b_mention_shadow);
-
-  return unbind_to (count, Qnil);
-}
-
 /* Describe the contents of map MAP, assuming that this map itself is
    reached by the sequence of prefix keys PREFIX (a string or vector).
    PARTIAL, SHADOW, NOMENU are as in `describe_map_tree' above.  */
@@ -3363,6 +3337,31 @@ DESCRIBER is the output function used; nil means use 
`princ'.  */)
   return unbind_to (count, Qnil);
 }
 
+DEFUN ("describe-vector-internal", Fdescribe_vector_internal, 
Sdescribe_vector_internal, 8, 8, 0,
+       doc: /* Insert a description of contents of VECTOR.  */)
+  (Lisp_Object vector, Lisp_Object prefix, Lisp_Object transl,
+   Lisp_Object partial, Lisp_Object shadow, Lisp_Object entire_map,
+   Lisp_Object keymap_p, Lisp_Object mention_shadow)
+{
+  ptrdiff_t count = SPECPDL_INDEX ();
+  specbind (Qstandard_output, Fcurrent_buffer ());
+  CHECK_VECTOR_OR_CHAR_TABLE (vector);
+
+  bool b_transl = NILP (transl) ? false : true;
+  bool b_partial = NILP (partial) ? false : true;
+  bool b_keymap_p = NILP (keymap_p) ? false : true;
+  bool b_mention_shadow = NILP (mention_shadow) ? false : true;
+
+  /* describe_vector (XCAR (tail), */
+  /*            prefix, Qnil, elt_describer, partial, shadow, map, */
+  /*            1, mention_shadow); */
+  describe_vector (vector, prefix, Qnil,
+                  b_transl ? describe_translation : describe_command,
+                  b_partial, shadow, entire_map,
+                  b_keymap_p, b_mention_shadow);
+  return unbind_to (count, Qnil);
+}
+
 /* Insert in the current buffer a description of the contents of VECTOR.
    We call ELT_DESCRIBER to insert the description of one value found
    in VECTOR.
@@ -3764,9 +3763,10 @@ This is used for internal purposes only.  */);
   defsubr (&Scurrent_active_maps);
   defsubr (&Saccessible_keymaps);
   defsubr (&Skey_description);
-  defsubr (&Sdescribe_map_tree_old);
-  defsubr (&Sdescribe_map);
+  defsubr (&Skeymap__get_keyelt);
+  defsubr (&Skeymap__shadow_lookup);
   defsubr (&Sdescribe_vector);
+  defsubr (&Sdescribe_vector_internal);
   defsubr (&Ssingle_key_description);
   defsubr (&Stext_char_description);
   defsubr (&Swhere_is_internal);
diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el
index 2b08658..a5aad15 100644
--- a/test/lisp/help-tests.el
+++ b/test/lisp/help-tests.el
@@ -194,6 +194,17 @@ M-s                next-matching-history-element
 (defvar help-tests-major-mode-map
   (let ((map (make-keymap)))
     (define-key map "x" 'foo-original)
+    (define-key map "1" 'foo-range)
+    (define-key map "2" 'foo-range)
+    (define-key map "3" 'foo-range)
+    (define-key map "4" 'foo-range)
+    (define-key map (kbd "C-e") 'foo-something)
+    (define-key map '[F1] 'foo-function-key1)
+    (define-key map "(" 'short-range)
+    (define-key map ")" 'short-range)
+    (define-key map "a" 'foo-other-range)
+    (define-key map "b" 'foo-other-range)
+    (define-key map "c" 'foo-other-range)
     map))
 
 (define-derived-mode help-tests-major-mode nil
@@ -202,12 +213,13 @@ M-s               next-matching-history-element
 (defvar help-tests-minor-mode-map
   (let ((map (make-keymap)))
     (define-key map "x" 'foo-shadow)
+    (define-key map (kbd "C-e") 'foo-shadow)
     map))
 
 (define-minor-mode help-tests-minor-mode
   "Minor mode for testing shadowing.")
 
-(ert-deftest help-tests-substitute-command-keys/shadow ()
+(ert-deftest help-tests-substitute-command-keys/test-mode ()
   (with-substitute-command-keys-test
    (with-temp-buffer
      (help-tests-major-mode)
@@ -216,17 +228,35 @@ M-s               next-matching-history-element
 key             binding
 ---             -------
 
+( .. )         short-range
+1 .. 4         foo-range
+a .. c         foo-other-range
+
+C-e            foo-something
 x              foo-original
+<F1>           foo-function-key1
+
+"))))
 
-")
+(ert-deftest help-tests-substitute-command-keys/shadow ()
+  (with-substitute-command-keys-test
+   (with-temp-buffer
+     (help-tests-major-mode)
      (help-tests-minor-mode)
      (test "\\{help-tests-major-mode-map}"
            "\
 key             binding
 ---             -------
 
+( .. )         short-range
+1 .. 4         foo-range
+a .. c         foo-other-range
+
+C-e            foo-something
+  (that binding is currently shadowed by another mode)
 x              foo-original
   (that binding is currently shadowed by another mode)
+<F1>           foo-function-key1
 
 "))))
 
@@ -261,6 +291,15 @@ key             binding
      (outline-minor-mode)
      (test-re "\\{c-mode-map}" ".*"))))
 
+(ert-deftest help-tests-substitute-command-keys/compare-all ()
+  (let (keymaps)
+    (mapatoms (lambda (var)
+                (when (keymapp var)
+                  (push var keymaps))))
+    (dolist (keymap keymaps)
+      (with-substitute-command-keys-test
+       (test-re (concat "\\{" (symbol-name keymap) "}") ".*")))))
+
 (provide 'help-tests)
 
 ;;; help-tests.el ends here