From: storm@cua.dk (Kim F. Storm)
Cc: cyd@stupidchicken.com, emacs-devel@gnu.org
Subject: Re: Tweak to key-description for menu bindings
Date: Mon, 28 Feb 2005 23:47:53 +0100 [thread overview]
Message-ID: <m3ll982teu.fsf@kfs-l.imdomain.dk> (raw)
In-Reply-To: <E1D5spe-0005Mb-3M@fencepost.gnu.org> (Richard Stallman's message of "Mon, 28 Feb 2005 16:53:38 -0500")
Richard Stallman <rms@gnu.org> writes:
> Old:
> <menu-bar> <options> <mule> <set-various-coding-system> <universal-coding-system-argument>
> New:
> Options=>Mule (Multilingual Environment)=>Set Coding Systems=>For Next Command
> It seems like marginally an improvement, but since this isn't fixing a bug,
> I'd rather not install this change now.
I'll respect that, although I think this is more than a marginal improvement.
For the non-technical user, the old format is practically nonsense.
In any case, if someone would like to try it out, here is the complete patch,
including a patch to apropos that avoids the underline face on the menu binding.
Index: lisp/apropos.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/apropos.el,v
retrieving revision 1.101
diff -c -r1.101 apropos.el
*** lisp/apropos.el 11 Feb 2005 16:08:49 -0000 1.101
--- lisp/apropos.el 28 Feb 2005 22:41:40 -0000
***************
*** 84,89 ****
--- 84,94 ----
:group 'apropos
:type 'face)
+ (defcustom apropos-menu-binding-face nil
+ "*Face for lists of menu binding in Apropos output, or nil for none."
+ :group 'apropos
+ :type 'face)
+
(defcustom apropos-label-face 'italic
"*Face for label (`Command', `Variable' ...) in Apropos output.
A value of nil means don't use any special font for them, and also
***************
*** 795,801 ****
(with-output-to-temp-buffer "*Apropos*"
(let ((p apropos-accumulator)
(old-buffer (current-buffer))
! symbol item)
(set-buffer standard-output)
(apropos-mode)
(if (display-mouse-p)
--- 800,806 ----
(with-output-to-temp-buffer "*Apropos*"
(let ((p apropos-accumulator)
(old-buffer (current-buffer))
! symbol item menu-items)
(set-buffer standard-output)
(apropos-mode)
(if (display-mouse-p)
***************
*** 839,848 ****
(i 0)
loser)
(while (< i (length key))
! (if (or (framep (aref key i))
! (bufferp (aref key i)))
(setq loser t))
! (setq i (1+ i)))
(or loser
(setq filtered (cons key filtered))))
(setq keys (cdr keys)))
--- 844,858 ----
(i 0)
loser)
(while (< i (length key))
! (let ((elt (aref key i)))
! (cond
! ((or (framep elt) (bufferp elt))
(setq loser t))
! ((and (= i 0) (eq elt 'menu-bar))
! (if menu-bar-mode
! (setq menu-items (cons key menu-items))
! (setq loser t)))))
! (setq i (if loser (length key) (1+ i))))
(or loser
(setq filtered (cons key filtered))))
(setq keys (cdr keys)))
***************
*** 854,872 ****
(setq key (condition-case ()
(key-description key)
(error)))
! (if apropos-keybinding-face
! (put-text-property 0 (length key)
! 'face apropos-keybinding-face
! key))
key)
item ", "))
! (insert "M-x")
! (put-text-property (- (point) 3) (point)
! 'face apropos-keybinding-face)
! (insert " " (symbol-name symbol) " ")
! (insert "RET")
! (put-text-property (- (point) 3) (point)
! 'face apropos-keybinding-face)))
(terpri)
(apropos-print-doc 2
(if (commandp symbol)
--- 864,883 ----
(setq key (condition-case ()
(key-description key)
(error)))
! (let ((face (if (memq key menu-items)
! apropos-menu-binding-face
! apropos-keybinding-face)))
! (if face
! (put-text-property 0 (length key)
! 'face face key)))
key)
item ", "))
! (insert "M-x ... RET")
! (when apropos-keybinding-face
! (put-text-property (- (point) 11) (- (point) 8)
! 'face apropos-keybinding-face)
! (put-text-property (- (point) 3) (point)
! 'face apropos-keybinding-face))))
(terpri)
(apropos-print-doc 2
(if (commandp symbol)
Index: lisp/help-fns.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/help-fns.el,v
retrieving revision 1.64
diff -c -r1.64 help-fns.el
*** lisp/help-fns.el 3 Feb 2005 19:41:14 -0000 1.64
--- lisp/help-fns.el 28 Feb 2005 22:42:22 -0000
***************
*** 289,296 ****
(defun help-highlight-arguments (usage doc &rest args)
(when usage
(with-temp-buffer
! (insert usage)
! (goto-char (point-min))
(let ((case-fold-search nil)
(next (not (or args (looking-at "\\["))))
(opt nil))
--- 289,296 ----
(defun help-highlight-arguments (usage doc &rest args)
(when usage
(with-temp-buffer
! (insert "Lisp: " usage)
! (goto-char (+ (point-min) 6))
(let ((case-fold-search nil)
(next (not (or args (looking-at "\\["))))
(opt nil))
***************
*** 314,320 ****
(cons usage doc))
;;;###autoload
! (defun describe-function-1 (function)
(let* ((def (if (symbolp function)
(symbol-function function)
function))
--- 314,320 ----
(cons usage doc))
;;;###autoload
! (defun describe-function-1 (function &optional orig-key)
(let* ((def (if (symbolp function)
(symbol-function function)
function))
***************
*** 400,406 ****
(let* ((remapped (command-remapping function))
(keys (where-is-internal
(or remapped function) overriding-local-map nil nil))
! non-modified-keys)
;; Which non-control non-meta keys run this command?
(dolist (key keys)
(if (member (event-modifiers (aref key 0)) '(nil (shift)))
--- 400,424 ----
(let* ((remapped (command-remapping function))
(keys (where-is-internal
(or remapped function) overriding-local-map nil nil))
! non-modified-keys
! menu-binding
! orig-deleted)
! (when orig-key
! (cond
! ((vectorp orig-key)
! (if ;; [menu-bar ...] or [(menu-bar) ...]
! (or (eq (aref orig-key 0) 'menu-bar)
! (and (consp (aref orig-key 0))
! (eq (car (aref orig-key 0)) 'menu-bar)
! ;; where-is-internal returns [menu-bar ...]
! (aset orig-key 0 'menu-bar)))
! (setq menu-binding t)))
! ((stringp orig-key)
! (setq orig-key (string-to-vector orig-key))))
! (setq orig-deleted (length keys))
! (setq keys (delete orig-key keys))
! (if (= orig-deleted (length keys))
! (setq orig-deleted nil)))
;; Which non-control non-meta keys run this command?
(dolist (key keys)
(if (member (event-modifiers (aref key 0)) '(nil (shift)))
***************
*** 411,417 ****
(princ "'"))
(when keys
! (princ (if remapped " which is bound to " "It is bound to "))
;; FIXME: This list can be very long (f.ex. for self-insert-command).
;; If there are many, remove them from KEYS.
(if (< (length non-modified-keys) 10)
--- 429,438 ----
(princ "'"))
(when keys
! (princ (if remapped " which is" "It is"))
! (if (and orig-deleted (< (length non-modified-keys) 10))
! (princ " also"))
! (princ " bound to ")
;; FIXME: This list can be very long (f.ex. for self-insert-command).
;; If there are many, remove them from KEYS.
(if (< (length non-modified-keys) 10)
***************
*** 425,430 ****
--- 446,456 ----
(princ "many ordinary text characters"))))
(when (or remapped keys non-modified-keys)
(princ ".")
+ (terpri))
+ (terpri)
+ (when menu-binding
+ (princ "Menu binding: ")
+ (princ (key-description orig-key t))
(terpri))))
(let* ((arglist (help-function-arglist def))
(doc (documentation function))
Index: lisp/help.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/help.el,v
retrieving revision 1.275
diff -c -r1.275 help.el
*** lisp/help.el 10 Feb 2005 06:46:42 -0000 1.275
--- lisp/help.el 28 Feb 2005 22:43:01 -0000
***************
*** 619,625 ****
(princ " runs the command ")
(prin1 defn)
(princ "\n which is ")
! (describe-function-1 defn)
(when up-event
(let ((ev (aref up-event 0))
(descr (key-description up-event))
--- 619,625 ----
(princ " runs the command ")
(prin1 defn)
(princ "\n which is ")
! (describe-function-1 defn key)
(when up-event
(let ((ev (aref up-event 0))
(descr (key-description up-event))
Index: src/keymap.c
===================================================================
RCS file: /cvsroot/emacs/emacs/src/keymap.c,v
retrieving revision 1.302
diff -c -r1.302 keymap.c
*** src/keymap.c 15 Feb 2005 06:39:18 -0000 1.302
--- src/keymap.c 28 Feb 2005 22:43:29 -0000
***************
*** 440,446 ****
/* SUBMAP is a cons that we found as a key binding.
Discard the other things found in a menu key binding. */
! submap = get_keymap (get_keyelt (submap, 0), 0, 0);
/* If it isn't a keymap now, there's no work to do. */
if (!CONSP (submap))
--- 440,446 ----
/* SUBMAP is a cons that we found as a key binding.
Discard the other things found in a menu key binding. */
! submap = get_keymap (get_keyelt (submap, 0, 0), 0, 0);
/* If it isn't a keymap now, there's no work to do. */
if (!CONSP (submap))
***************
*** 634,645 ****
/* If we found a binding, clean it up and return it. */
if (!EQ (val, Qunbound))
{
if (EQ (val, Qt))
/* A Qt binding is just like an explicit nil binding
(i.e. it shadows any parent binding but not bindings in
keymaps of lower precedence). */
val = Qnil;
! val = get_keyelt (val, autoload);
if (KEYMAPP (val))
fix_submap_inheritance (map, idx, val);
RETURN_UNGCPRO (val);
--- 634,648 ----
/* If we found a binding, clean it up and return it. */
if (!EQ (val, Qunbound))
{
+ Lisp_Object menu_string = Qnil;
if (EQ (val, Qt))
/* A Qt binding is just like an explicit nil binding
(i.e. it shadows any parent binding but not bindings in
keymaps of lower precedence). */
val = Qnil;
! val = get_keyelt (val, autoload, &menu_string);
! if (SYMBOLP (idx) && !NILP (menu_string))
! Fput (idx, Qmenu_item, menu_string);
if (KEYMAPP (val))
fix_submap_inheritance (map, idx, val);
RETURN_UNGCPRO (val);
***************
*** 647,653 ****
QUIT;
}
UNGCPRO;
! return get_keyelt (t_binding, autoload);
}
}
--- 650,656 ----
QUIT;
}
UNGCPRO;
! return get_keyelt (t_binding, autoload, 0);
}
}
***************
*** 749,755 ****
Fsignal (Qinvalid_function, Fcons (function, Qnil));
if (! NILP (sort_first))
return call3 (intern ("map-keymap-internal"), function, keymap, Qt);
!
map_keymap (keymap, map_keymap_call, function, NULL, 1);
return Qnil;
}
--- 752,758 ----
Fsignal (Qinvalid_function, Fcons (function, Qnil));
if (! NILP (sort_first))
return call3 (intern ("map-keymap-internal"), function, keymap, Qt);
!
map_keymap (keymap, map_keymap_call, function, NULL, 1);
return Qnil;
}
***************
*** 767,775 ****
that are referred to with indirection. */
Lisp_Object
! get_keyelt (object, autoload)
Lisp_Object object;
int autoload;
{
while (1)
{
--- 770,779 ----
that are referred to with indirection. */
Lisp_Object
! get_keyelt (object, autoload, menu_string)
Lisp_Object object;
int autoload;
+ Lisp_Object *menu_string;
{
while (1)
{
***************
*** 791,796 ****
--- 795,803 ----
{
Lisp_Object tem;
+ if (menu_string)
+ *menu_string = XCAR (XCDR (object));
+
object = XCDR (XCDR (object));
tem = object;
if (CONSP (object))
***************
*** 819,824 ****
--- 826,834 ----
will be used by HierarKey menus. */
else if (STRINGP (XCAR (object)))
{
+ if (menu_string)
+ *menu_string = XCAR (object);
+
object = XCDR (object);
/* Also remove a menu help string, if any,
following the menu item name. */
***************
*** 1222,1245 ****
register int idx;
register Lisp_Object cmd;
register Lisp_Object c;
! int length;
int t_ok = !NILP (accept_default);
struct gcpro gcpro1, gcpro2;
GCPRO2 (keymap, key);
keymap = get_keymap (keymap, 1, 1);
if (!VECTORP (key) && !STRINGP (key))
key = wrong_type_argument (Qarrayp, key);
length = XFASTINT (Flength (key));
! if (length == 0)
RETURN_UNGCPRO (keymap);
! idx = 0;
while (1)
{
c = Faref (key, make_number (idx++));
if (CONSP (c) && lucid_event_type_list_p (c))
c = Fevent_convert_list (c);
--- 1232,1267 ----
register int idx;
register Lisp_Object cmd;
register Lisp_Object c;
! Lisp_Object key2 = Qnil;
! int length, length2 = 0, consumed = 0;
int t_ok = !NILP (accept_default);
struct gcpro gcpro1, gcpro2;
GCPRO2 (keymap, key);
keymap = get_keymap (keymap, 1, 1);
+ /* Hack for passing Fkey_description prefix and keys in one arg. */
+ if (CONSP (key))
+ {
+ key2 = XCDR (key);
+ key = XCAR (key);
+ if (!VECTORP (key2) && !STRINGP (key2))
+ key2 = wrong_type_argument (Qarrayp, key2);
+ length2 = XFASTINT (Flength (key2));
+ }
+
if (!VECTORP (key) && !STRINGP (key))
key = wrong_type_argument (Qarrayp, key);
length = XFASTINT (Flength (key));
! if (length + length2 == 0)
RETURN_UNGCPRO (keymap);
! idx = consumed = 0;
while (1)
{
c = Faref (key, make_number (idx++));
+ consumed++;
if (CONSP (c) && lucid_event_type_list_p (c))
c = Fevent_convert_list (c);
***************
*** 1254,1265 ****
error ("Key sequence contains invalid event");
cmd = access_keymap (keymap, c, t_ok, 0, 1);
! if (idx == length)
! RETURN_UNGCPRO (cmd);
keymap = get_keymap (cmd, 0, 1);
if (!CONSP (keymap))
! RETURN_UNGCPRO (make_number (idx));
QUIT;
}
--- 1276,1293 ----
error ("Key sequence contains invalid event");
cmd = access_keymap (keymap, c, t_ok, 0, 1);
! if (idx == length) {
! if (NILP (key2))
! RETURN_UNGCPRO (cmd);
! key = key2;
! key2 = Qnil;
! length = length2;
! idx = 0;
! }
keymap = get_keymap (cmd, 0, 1);
if (!CONSP (keymap))
! RETURN_UNGCPRO (make_number (consumed));
QUIT;
}
***************
*** 1781,1787 ****
{
Lisp_Object tem;
! cmd = get_keymap (get_keyelt (cmd, 0), 0, 0);
if (NILP (cmd))
return;
--- 1809,1815 ----
{
Lisp_Object tem;
! cmd = get_keymap (get_keyelt (cmd, 0, 0), 0, 0);
if (NILP (cmd))
return;
***************
*** 1985,1990 ****
--- 2013,2022 ----
Lisp_Object sep = build_string (" ");
Lisp_Object key;
int add_meta = 0;
+ int menu_binding = !EQ (prefix, Qt) ? 0 : -1;
+
+ if (menu_binding < 0)
+ prefix = Qnil;
if (!NILP (prefix))
size += XINT (Flength (prefix));
***************
*** 2065,2070 ****
--- 2097,2135 ----
add_meta = 1;
continue;
}
+ if (menu_binding > 0)
+ {
+ Lisp_Object head = EVENT_HEAD (key);
+ Lisp_Object menu_string;
+
+ if (SYMBOLP (head)
+ && (menu_string = Fget (key, Qmenu_item),
+ STRINGP (menu_string)))
+ {
+ args[len++] = menu_string;
+ args[len++] = sep;
+ continue;
+ }
+ }
+ else if (menu_binding == 0)
+ {
+ if (EQ (key, Qmenu_bar)
+ || (CONSP (key) && EQ (XCAR (key), Qmenu_bar)))
+ {
+ /* Let Fkey_binding fill menu-item strings. */
+
+ /* Fkey_binding may GC, Fkey_description may not! */
+ int count = inhibit_garbage_collection ();
+ (void) Fkey_binding (!NILP (keys) ? Fcons (list, keys) : list,
+ Qnil, Qt);
+ unbind_to (count, Qnil);
+ sep = build_string ("=>");
+ menu_binding = 1;
+ continue;
+ }
+ menu_binding = -1;
+ }
+
args[len++] = Fsingle_key_description (key, Qnil);
args[len++] = sep;
}
***************
*** 2418,2423 ****
--- 2483,2489 ----
sequences = Qnil;
for (; !NILP (maps); maps = Fcdr (maps))
+
{
/* Key sequence to reach map, and the map that it reaches */
register Lisp_Object this, map, tem;
***************
*** 2740,2749 ****
int nomenus, last_is_meta;
{
Lisp_Object sequence;
/* Search through indirections unless that's not wanted. */
if (NILP (noindirect))
! binding = get_keyelt (binding, 0);
/* End this iteration if this element does not match
the target. */
--- 2806,2816 ----
int nomenus, last_is_meta;
{
Lisp_Object sequence;
+ Lisp_Object menu_string = Qnil;
/* Search through indirections unless that's not wanted. */
if (NILP (noindirect))
! binding = get_keyelt (binding, 0, &menu_string);
/* End this iteration if this element does not match
the target. */
***************
*** 2761,2767 ****
Faset (sequence, last, make_number (XINT (key) | meta_modifier));
}
else
! sequence = append_key (this, key);
if (!NILP (where_is_cache))
{
--- 2828,2841 ----
Faset (sequence, last, make_number (XINT (key) | meta_modifier));
}
else
! {
! if (SYMBOLP (key) && !NILP (menu_string))
! Fput (key, Qmenu_item, menu_string);
! else if (CONSP (definition) &&
! CONSP (XCDR (definition)) && STRINGP (XCAR (XCDR (definition))))
! Fput (key, Qmenu_item, XCAR (XCDR (definition)));
! sequence = append_key (this, key);
! }
if (!NILP (where_is_cache))
{
***************
*** 3195,3201 ****
if (nomenu && EQ (event, Qmenu_bar))
continue;
! definition = get_keyelt (XCDR (XCAR (tail)), 0);
/* Don't show undefined commands or suppressed commands. */
if (NILP (definition)) continue;
--- 3269,3275 ----
if (nomenu && EQ (event, Qmenu_bar))
continue;
! definition = get_keyelt (XCDR (XCAR (tail)), 0, 0);
/* Don't show undefined commands or suppressed commands. */
if (NILP (definition)) continue;
***************
*** 3434,3443 ****
continue;
definition
! = get_keyelt (XCHAR_TABLE (vector)->contents[i], 0);
}
else
! definition = get_keyelt (AREF (vector, i), 0);
if (NILP (definition)) continue;
--- 3508,3517 ----
continue;
definition
! = get_keyelt (XCHAR_TABLE (vector)->contents[i], 0, 0);
}
else
! definition = get_keyelt (AREF (vector, i), 0, 0);
if (NILP (definition)) continue;
***************
*** 3582,3595 ****
limit = CHAR_TABLE_SINGLE_BYTE_SLOTS;
while (i + 1 < limit
! && (tem2 = get_keyelt (XCHAR_TABLE (vector)->contents[i + 1], 0),
!NILP (tem2))
&& !NILP (Fequal (tem2, definition)))
i++;
}
else
while (i + 1 < to
! && (tem2 = get_keyelt (AREF (vector, i + 1), 0),
!NILP (tem2))
&& !NILP (Fequal (tem2, definition)))
i++;
--- 3656,3669 ----
limit = CHAR_TABLE_SINGLE_BYTE_SLOTS;
while (i + 1 < limit
! && (tem2 = get_keyelt (XCHAR_TABLE (vector)->contents[i + 1], 0, 0),
!NILP (tem2))
&& !NILP (Fequal (tem2, definition)))
i++;
}
else
while (i + 1 < to
! && (tem2 = get_keyelt (AREF (vector, i + 1), 0, 0),
!NILP (tem2))
&& !NILP (Fequal (tem2, definition)))
i++;
Index: src/keymap.h
===================================================================
RCS file: /cvsroot/emacs/emacs/src/keymap.h,v
retrieving revision 1.11
diff -c -r1.11 keymap.h
*** src/keymap.h 21 Feb 2005 13:39:53 -0000 1.11
--- src/keymap.h 28 Feb 2005 22:43:50 -0000
***************
*** 35,41 ****
EXFUN (Fwhere_is_internal, 5);
EXFUN (Fcurrent_active_maps, 1);
extern Lisp_Object access_keymap P_ ((Lisp_Object, Lisp_Object, int, int, int));
! extern Lisp_Object get_keyelt P_ ((Lisp_Object, int));
extern Lisp_Object get_keymap P_ ((Lisp_Object, int, int));
extern void describe_map_tree P_ ((Lisp_Object, int, Lisp_Object, Lisp_Object,
char *, int, int, int, int));
--- 35,41 ----
EXFUN (Fwhere_is_internal, 5);
EXFUN (Fcurrent_active_maps, 1);
extern Lisp_Object access_keymap P_ ((Lisp_Object, Lisp_Object, int, int, int));
! extern Lisp_Object get_keyelt P_ ((Lisp_Object, int, Lisp_Object *));
extern Lisp_Object get_keymap P_ ((Lisp_Object, int, int));
extern void describe_map_tree P_ ((Lisp_Object, int, Lisp_Object, Lisp_Object,
char *, int, int, int, int));
--
Kim F. Storm <storm@cua.dk> http://www.cua.dk
next prev parent reply other threads:[~2005-02-28 22:47 UTC|newest]
Thread overview: 17+ messages / expand[flat|nested] mbox.gz Atom feed top
2005-02-21 14:35 tweak to apropos-command display Chong Yidong
2005-02-21 15:04 ` Kim F. Storm
2005-02-21 16:26 ` Chong Yidong
2005-02-21 15:14 ` Stefan
2005-02-21 16:36 ` Chong Yidong
2005-02-22 18:11 ` Richard Stallman
2005-02-22 20:36 ` Kevin Rodgers
2005-02-22 21:46 ` Kim F. Storm
2005-02-22 22:01 ` David Kastrup
2005-02-22 22:28 ` Kim F. Storm
2005-02-28 12:14 ` Tweak to key-description for menu bindings (was Re: tweak to apropos-command display) Kim F. Storm
2005-02-28 12:55 ` Tweak to key-description for menu bindings David Kastrup
2005-03-01 23:36 ` Kim F. Storm
2005-02-28 21:53 ` Tweak to key-description for menu bindings (was Re: tweak to apropos-command display) Richard Stallman
2005-02-28 22:47 ` Kim F. Storm [this message]
2005-02-22 22:13 ` tweak to apropos-command display Stefan Monnier
2005-02-22 22:31 ` Kim F. Storm
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=m3ll982teu.fsf@kfs-l.imdomain.dk \
--to=storm@cua.dk \
--cc=cyd@stupidchicken.com \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).