procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Translate describe_map to Lisp

Browse source 
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.
This commit is contained in:
Stefan Kangas 2020-08-19 12:49:39 +02:00 • committed by Stefan Kangas
parent afd31f9e62
commit 647b1c5142
3 changed files with 339 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

164
lisp/help.el
View file

@ -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) "<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 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))

99
src/keymap.c
View file

@ -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);

137
test/lisp/help-tests.el
View file

@ -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
--- -------
x foo-original
( .. ) 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
(this binding is currently shadowed)
x foo-original
(this binding is currently shadowed)
<F1> 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
<menu-bar> Prefix Command
<menu-bar> <foo> 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