From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: storm@cua.dk (Kim F. Storm) Newsgroups: gmane.emacs.devel Subject: Re: Tweak to key-description for menu bindings Date: Mon, 28 Feb 2005 23:47:53 +0100 Message-ID: References: <1814.220.255.78.196.1108996512.squirrel@220.255.78.196> NNTP-Posting-Host: main.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii X-Trace: sea.gmane.org 1109632720 18232 80.91.229.2 (28 Feb 2005 23:18:40 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Mon, 28 Feb 2005 23:18:40 +0000 (UTC) Cc: cyd@stupidchicken.com, emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Tue Mar 01 00:18:40 2005 Original-Received: from lists.gnu.org ([199.232.76.165]) by ciao.gmane.org with esmtp (Exim 4.43) id 1D5u8V-0003dW-IU for ged-emacs-devel@m.gmane.org; Tue, 01 Mar 2005 00:17:12 +0100 Original-Received: from localhost ([127.0.0.1] helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1D5uQv-0000dt-Sm for ged-emacs-devel@m.gmane.org; Mon, 28 Feb 2005 18:36:14 -0500 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1D5uNY-0006bw-Em for emacs-devel@gnu.org; Mon, 28 Feb 2005 18:32:44 -0500 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1D5uNW-0006bB-VJ for emacs-devel@gnu.org; Mon, 28 Feb 2005 18:32:44 -0500 Original-Received: from [199.232.76.173] (helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1D5uEc-0003CO-Qg for emacs-devel@gnu.org; Mon, 28 Feb 2005 18:23:30 -0500 Original-Received: from [195.41.46.237] (helo=pfepc.post.tele.dk) by monty-python.gnu.org with esmtp (Exim 4.34) id 1D5tgA-0002RA-TA; Mon, 28 Feb 2005 17:47:55 -0500 Original-Received: from kfs-l.imdomain.dk.cua.dk (0x503e2644.bynxx3.adsl-dhcp.tele.dk [80.62.38.68]) by pfepc.post.tele.dk (Postfix) with SMTP id 28130262861; Mon, 28 Feb 2005 23:47:48 +0100 (CET) Original-To: rms@gnu.org In-Reply-To: (Richard Stallman's message of "Mon, 28 Feb 2005 16:53:38 -0500") User-Agent: Gnus/5.11 (Gnus v5.11) Emacs/22.0.50 (gnu/linux) X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org X-MailScanner-To: ged-emacs-devel@m.gmane.org Xref: main.gmane.org gmane.emacs.devel:33956 X-Report-Spam: http://spam.gmane.org/gmane.emacs.devel:33956 Richard Stallman writes: > Old: > > 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 http://www.cua.dk