From 647b1c5142d7a029a3124e0177112f16f84d3794 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Wed, 19 Aug 2020 12:49:39 +0200 Subject: [PATCH] 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. (help--keymaps-seen, help--previous-description-column): New variables. * src/keymap.c (Fkeymap__get_keyelt): New defun to expose get_keyelt 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 and Fdescribe_vector_internal. Remove defsubrs for Fdescribe_map_tree_old and Fdescribe_map. Remove 'help--keymaps-seen'. * 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) (help-tests-describe-map-tree/no-menu-t) (help-tests-describe-map-tree/no-menu-nil) (help-tests-describe-map-tree/mention-shadow-t) (help-tests-describe-map-tree/mention-shadow-nil) (help-tests-describe-map-tree/partial-t) (help-tests-describe-map-tree/partial-nil): New tests. --- lisp/help.el | 164 ++++++++++++++++++++++++++++++++++++++++ src/keymap.c | 99 ++++++++++-------------- test/lisp/help-tests.el | 135 ++++++++++++++++++++++++++++++++- 3 files changed, 338 insertions(+), 60 deletions(-) diff --git a/lisp/help.el b/lisp/help.el index 2996581f943..4541d665193 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1118,6 +1118,7 @@ Otherwise, return a new string (without any text properties)." (t (forward-char 1))))) (buffer-string))))) +(defvar help--keymaps-seen nil) (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. @@ -1203,6 +1204,169 @@ 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))) + (cond ((and (fixnump value) (<= 0 value))) + ((and value remap (symbolp value)) + (or (command-remapping value nil keymap) + value)) + (t value)))) + +(defvar help--previous-description-column 0) +(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) "" coming between "" and "". + (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 keymap MAP. +Assume that this keymap itself is reached by the sequence of +prefix keys PREFIX (a string or vector). + +TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW 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 (help--shadow-lookup shadow (vector event) t nil))) + (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. + ((and mention-shadow (not (eq tem 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 help--keymaps-seen))) + (if (and (consp tem) + (equal (car tem) prefix)) + (setq done t) + (push (cons tail prefix) help--keymaps-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)) + (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 (this binding is currently shadowed)") + (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 704b89eeecc..2076e29b6fb 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 @@ -2915,37 +2932,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 +3117,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, &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. */ @@ -3363,6 +3328,28 @@ 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 (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. @@ -3706,10 +3693,6 @@ 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"); @@ -3764,9 +3747,9 @@ 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 (&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 048b6c325e4..aff5d1853a6 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 + 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 + (this binding is currently shadowed) x foo-original (this binding is currently shadowed) + foo-function-key1 ")))) @@ -247,6 +277,98 @@ key binding "))))) +(ert-deftest help-tests-describe-map-tree/no-menu-t () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (menu-bar keymap + (foo menu-item "Foo" foo + :enable mark-active + :help "Help text")))))) + (describe-map-tree map nil nil nil nil t nil nil nil) + (should (equal (buffer-string) "key binding +--- ------- + +C-a foo + +"))))) + +(ert-deftest help-tests-describe-map-tree/no-menu-nil () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (menu-bar keymap + (foo menu-item "Foo" foo + :enable mark-active + :help "Help text")))))) + (describe-map-tree map nil nil nil nil nil nil nil nil) + (should (equal (buffer-string) "key binding +--- ------- + +C-a foo + Prefix Command + + foo + +"))))) + +(ert-deftest help-tests-describe-map-tree/mention-shadow-t () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (2 . bar)))) + (shadow-maps '((keymap . ((1 . baz)))))) + (describe-map-tree map t shadow-maps nil nil t nil nil t) + (should (equal (buffer-string) "key binding +--- ------- + +C-a foo + (this binding is currently shadowed) +C-b bar + +"))))) + +(ert-deftest help-tests-describe-map-tree/mention-shadow-nil () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (2 . bar)))) + (shadow-maps '((keymap . ((1 . baz)))))) + (describe-map-tree map t shadow-maps nil nil t nil nil nil) + (should (equal (buffer-string) "key binding +--- ------- + +C-b bar + +"))))) + +(ert-deftest help-tests-describe-map-tree/partial-t () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (2 . undefined))))) + (describe-map-tree map t nil nil nil nil nil nil nil) + (should (equal (buffer-string) "key binding +--- ------- + +C-a foo + +"))))) + +(ert-deftest help-tests-describe-map-tree/partial-nil () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (2 . undefined))))) + (describe-map-tree map nil nil nil nil nil nil nil nil) + (should (equal (buffer-string) "key binding +--- ------- + +C-a foo +C-b undefined + +"))))) + ;; TODO: This is a temporary test that should be removed together with ;; substitute-command-keys-old. (ert-deftest help-tests-substitute-command-keys/compare () @@ -261,6 +383,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 -- 2.39.2