Re: Tweak to key-description for menu bindings

[Kim F. Storm]

Richard Stallman <address@hidden> 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 <address@hidden> http://www.cua.dk