[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/substitute-command-keys d230367: Translate describe_map_tree to
From: |
Stefan Kangas |
Subject: |
scratch/substitute-command-keys d230367: Translate describe_map_tree to Lisp |
Date: |
Mon, 18 May 2020 01:38:57 -0400 (EDT) |
branch: scratch/substitute-command-keys
commit d230367f1997a37efb48db0f9088e26422edd427
Author: Stefan Kangas <address@hidden>
Commit: Stefan Kangas <address@hidden>
Translate describe_map_tree to Lisp
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 'internal--seen'; a
temporary kludge planned for removal. New defsubr for Fdescribe_map.
* test/lisp/help-tests.el: Minor cleanups.
---
lisp/help.el | 90 +++++++++++++++++++++++++++++++++++++++++++++++--
src/keymap.c | 30 +++++++++++++++--
test/lisp/help-tests.el | 5 ++-
3 files changed, 120 insertions(+), 5 deletions(-)
diff --git a/lisp/help.el b/lisp/help.el
index f0511db..b7f3987 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -1014,7 +1014,8 @@ Otherwise, return a new string."
(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
@@ -1100,7 +1101,7 @@ Otherwise, return a new string."
;; 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) ?\`)
@@ -1118,6 +1119,91 @@ Otherwise, return a new string."
;; (if (string= string (buffer-string)) string (buffer-string))
(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 internal--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 5f94d9d..7895ba0 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, &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. */
@@ -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 ("internal--seen", Vinternal_seen,
+ doc: /* List of seen keymaps.
+This is used for internal purposes only. */);
+ Vinternal_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);
diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el
index c102b8c..2b08658 100644
--- a/test/lisp/help-tests.el
+++ b/test/lisp/help-tests.el
@@ -195,12 +195,15 @@ M-s next-matching-history-element
(let ((map (make-keymap)))
(define-key map "x" 'foo-original)
map))
+
(define-derived-mode help-tests-major-mode nil
"Major mode for testing shadowing.")
+
(defvar help-tests-minor-mode-map
(let ((map (make-keymap)))
(define-key map "x" 'foo-shadow)
map))
+
(define-minor-mode help-tests-minor-mode
"Minor mode for testing shadowing.")
@@ -256,7 +259,7 @@ key binding
(with-temp-buffer
(c-mode)
(outline-minor-mode)
- (test-re "\\{cc-mode-map}" ".*"))))
+ (test-re "\\{c-mode-map}" ".*"))))
(provide 'help-tests)
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- scratch/substitute-command-keys d230367: Translate describe_map_tree to Lisp,
Stefan Kangas <=