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.
(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.
(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))))))
+
\f
(declare-function x-display-pixel-height "xfns.c" (&optional terminal))
(declare-function x-display-pixel-width "xfns.c" (&optional terminal))
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
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,
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. */
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.
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");
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);
(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
(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)
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
+ (this binding is currently shadowed)
x foo-original
(this binding is currently shadowed)
+<F1> foo-function-key1
"))))
")))))
+(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 ()
(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
projects / emacs.git / commitdiff