[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/substitute-command-keys afd31f9 2/8: Translate describe_map_tree
From: |
Stefan Kangas |
Subject: |
scratch/substitute-command-keys afd31f9 2/8: Translate describe_map_tree to Lisp |
Date: |
Sun, 18 Oct 2020 11:54:24 -0400 (EDT) |
branch: scratch/substitute-command-keys
commit afd31f9e62e551a3f286d1d581a56ef1de33ee94
Author: Stefan Kangas <stefan@marxist.se>
Commit: Stefan Kangas <stefan@marxist.se>
Translate describe_map_tree to Lisp
This is the second step in converting substitute-command-keys to Lisp.
* lisp/help.el (describe-map-tree): New Lisp version of
describe_map_tree.
(substitute-command-keys): Update to use above function.
* src/keymap.c (Fdescribe_map): New defun to expose describe_map to
Lisp.
* src/keymap.c (syms_of_keymap): New variable 'help--keymaps-seen'; a
temporary kludge planned for removal. New defsubr for Fdescribe_map.
---
lisp/help.el | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
src/keymap.c | 30 ++++++++++++++++++--
2 files changed, 116 insertions(+), 4 deletions(-)
diff --git a/lisp/help.el b/lisp/help.el
index 8d0d9c4..2996581 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1013,7 +1013,8 @@ Otherwise, return a new string (without any text
properties)."
(insert string)
(goto-char (point-min))
(while (< (point) (point-max))
- (let ((orig-point (point))
+ (let ((standard-output (current-buffer))
+ (orig-point (point))
end-point active-maps
close generate-summary)
(cond
@@ -1101,7 +1102,7 @@ Otherwise, return a new string (without any text
properties)."
;; If this one's not active, get nil.
(let ((earlier-maps (cdr (memq this-keymap (reverse
active-maps)))))
(describe-map-tree this-keymap t (nreverse earlier-maps)
- nil nil t nil nil))))))))
+ nil nil t nil nil t))))))))
;; 2. Handle quotes.
((and (eq (get-quoting-style) 'curve)
(or (and (= (following-char) ?\`)
@@ -1117,6 +1118,91 @@ Otherwise, return a new string (without any text
properties)."
(t (forward-char 1)))))
(buffer-string)))))
+(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.
+This is followed by the key bindings of all maps reachable
+through STARTMAP.
+
+If PARTIAL is non-nil, omit certain uninteresting commands
+\(such as `undefined').
+
+If SHADOW is non-nil, it is a list of maps; don't mention keys
+which would be shadowed by any of them.
+
+If PREFIX is non-nil, mention only keys that start with PREFIX.
+
+If TITLE is non-nil, is a string to insert at the beginning.
+TITLE should not end with a colon or a newline; we supply that.
+
+If NOMENU is non-nil, then omit menu-bar commands.
+
+If TRANSL is non-nil, the definitions are actually key
+translations so print strings and vectors differently.
+
+If ALWAYS_TITLE is non-nil, print the title even if there are no
+maps to look through.
+
+If MENTION_SHADOW is non-nil, then when something is shadowed by
+SHADOW, don't omit it; instead, mention it but say it is
+shadowed.
+
+Any inserted text ends in two newlines (used by
+`help-make-xrefs')."
+ (let* ((amaps (accessible-keymaps startmap prefix))
+ (orig-maps (if no-menu
+ (progn
+ ;; Delete from MAPS each element that is for
+ ;; the menu bar.
+ (let* ((tail amaps)
+ result)
+ (while tail
+ (let ((elem (car tail)))
+ (when (not (and (>= (length (car elem)) 1)
+ (eq (elt (car elem) 0)
'menu-bar)))
+ (setq result (append result (list elem)))))
+ (setq tail (cdr tail)))
+ result))
+ amaps))
+ (maps orig-maps)
+ (print-title (or maps always-title)))
+ ;; Print title.
+ (when print-title
+ (princ (concat (if title
+ (concat title
+ (if prefix
+ (concat " Starting With "
+ (key-description prefix)))
+ ":\n"))
+ "key binding\n"
+ "--- -------\n")))
+ ;; Describe key bindings.
+ (setq help--keymaps-seen nil)
+ (while (consp maps)
+ (let* ((elt (car maps))
+ (elt-prefix (car elt))
+ (sub-shadows (lookup-key shadow elt-prefix t)))
+ (when (if (natnump sub-shadows)
+ (prog1 t (setq sub-shadows nil))
+ ;; Describe this map iff elt_prefix is bound to a
+ ;; keymap, since otherwise it completely shadows this
+ ;; map.
+ (or (keymapp sub-shadows)
+ (null sub-shadows)
+ (consp sub-shadows)
+ (not (keymapp (car sub-shadows)))))
+ ;; Maps we have already listed in this loop shadow this map.
+ (let ((tail orig-maps))
+ (while (not (equal tail maps))
+ (when (equal (car (car tail)) elt-prefix)
+ (setq sub-shadows (cons (cdr (car tail)) sub-shadows)))
+ (setq tail (cdr tail))))
+ (describe-map (cdr elt) elt-prefix transl partial
+ sub-shadows no-menu mention-shadow)))
+ (setq maps (cdr maps)))
+ (when print-title
+ (princ "\n"))))
+
(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 05b0814..704b89e 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -2915,7 +2915,7 @@ You type Translation\n\
Any inserted text ends in two newlines (used by `help-make-xrefs'). */
-DEFUN ("describe-map-tree", Fdescribe_map_tree, Sdescribe_map_tree, 1, 8, 0,
+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,
@@ -3131,6 +3131,27 @@ 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, &Vhelp__keymaps_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. */
@@ -3685,6 +3706,10 @@ exists, bindings using keys without modifiers (or only
with meta) will
be preferred. */);
Vwhere_is_preferred_modifier = Qnil;
where_is_preferred_modifier = 0;
+ DEFVAR_LISP ("help--keymaps-seen", Vhelp__keymaps_seen,
+ doc: /* List of seen keymaps.
+This is used for internal purposes only. */);
+ Vhelp__keymaps_seen = Qnil;
DEFSYM (Qmenu_bar, "menu-bar");
DEFSYM (Qmode_line, "mode-line");
@@ -3739,7 +3764,8 @@ be preferred. */);
defsubr (&Scurrent_active_maps);
defsubr (&Saccessible_keymaps);
defsubr (&Skey_description);
- defsubr (&Sdescribe_map_tree);
+ defsubr (&Sdescribe_map_tree_old);
+ defsubr (&Sdescribe_map);
defsubr (&Sdescribe_vector);
defsubr (&Ssingle_key_description);
defsubr (&Stext_char_description);
- branch scratch/substitute-command-keys created (now 420023a), Stefan Kangas, 2020/10/18
- scratch/substitute-command-keys dcf9cd4 1/8: Add new Lisp implementation of substitute-command-keys, Stefan Kangas, 2020/10/18
- scratch/substitute-command-keys afd31f9 2/8: Translate describe_map_tree to Lisp,
Stefan Kangas <=
- scratch/substitute-command-keys afde53c 5/8: Improve substitute-command-keys performance, Stefan Kangas, 2020/10/18
- scratch/substitute-command-keys 5ad2bb0 4/8: Translate describe_vector to Lisp, Stefan Kangas, 2020/10/18
- scratch/substitute-command-keys 8a14413 6/8: Prefer Lisp version of describe-map-tree, Stefan Kangas, 2020/10/18
- scratch/substitute-command-keys ef5a604 7/8: Remove C version of substitute-command-keys, Stefan Kangas, 2020/10/18
- scratch/substitute-command-keys 420023a 8/8: Prefer Lisp version of describer in help--describe-vector, Stefan Kangas, 2020/10/18
- scratch/substitute-command-keys 647b1c5 3/8: Translate describe_map to Lisp, Stefan Kangas, 2020/10/18