From 1432aa922cf416997c7922cc6b6ce4419a82db24 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Fri, 1 Nov 2024 14:12:45 +0100 Subject: [PATCH] Further simplify tmm.el --- lisp/isearch.el | 16 +- lisp/progmodes/cperl-mode.el | 7 +- lisp/tab-line.el | 5 +- lisp/textmodes/artist.el | 17 +- lisp/tmm.el | 390 +---------------------------------- 5 files changed, 8 insertions(+), 427 deletions(-) diff --git a/lisp/isearch.el b/lisp/isearch.el index feee63f4598..1410019030e 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -519,22 +519,8 @@ This is like `describe-bindings', but displays only Isearch keys." ;; Define isearch-mode keymap. -(defun isearch-tmm-menubar () - "Run `tmm-menubar' while `isearch-mode' is enabled." - (interactive) - (require 'tmm) - (run-hooks 'menu-bar-update-hook) - (let ((command nil)) - (let ((menu-bar (menu-bar-keymap))) - (with-isearch-suspended - (setq command (let ((isearch-mode t)) ; Show bindings from - ; `isearch-mode-map' in - ; tmm's prompt. - (tmm-prompt menu-bar nil nil t))))) - (call-interactively command))) - (defvar isearch-menu-bar-commands - '(isearch-tmm-menubar tmm-menubar menu-bar-open mouse-minor-mode-menu) + '(tmm-menubar menu-bar-open mouse-minor-mode-menu) "List of commands that can open a menu during Isearch.") ;; Note: Before adding more key bindings to this map, please keep in diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index d4c51d44d64..ccd750620a7 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -7707,7 +7707,6 @@ One may build such TAGS files from CPerl mode menu. If UPDATE is non-nil, update the tags table." (interactive) (require 'etags) - (require 'imenu) (if (or update (null (nth 2 cperl-hierarchy))) (let ((remover (lambda (elt) ; (name (file1...) (file2..)) (or (nthcdr 2 elt) @@ -7736,11 +7735,7 @@ If UPDATE is non-nil, update the tags table." (or (nth 2 cperl-hierarchy) (error "No items found")) (setq update - ;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) - (if (display-popup-menus-p) - (x-popup-menu t (nth 2 cperl-hierarchy)) - (require 'tmm) - (tmm-prompt (nth 2 cperl-hierarchy)))) + (x-popup-menu t (nth 2 cperl-hierarchy))) (if (and update (listp update)) (progn (while (cdr update) (setq update (cdr update))) (setq update (car update)))) ; Get the last from the list diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 92b52b6936c..f0a3fb9d890 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -888,9 +888,8 @@ corresponding to the new buffer shown in the window." (if (and (listp event) (display-popup-menus-p) (not tty-menu-open-use-tmm)) - (mouse-buffer-menu event) ; like (buffer-menu-open) - ;; tty menu doesn't support mouse clicks, so use tmm - (tmm-prompt (mouse-buffer-menu-keymap))))))) + (mouse-buffer-menu event) ; like (buffer-menu-open) + (help-complete-keys [] (list (mouse-buffer-menu-keymap)))))))) (defun tab-line-select-tab (&optional event) "Switch to the buffer specified by the tab on which you click. diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index c736f694083..d1f116ad38f 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -4828,22 +4828,7 @@ If optional argument STATE is positive, turn borders on." (interactive (progn (select-window (posn-window (event-start last-input-event))) - (list last-input-event - (if (display-popup-menus-p) - (x-popup-menu t artist-popup-menu-table) - 'no-popup-menus)))) - - (if (eq op 'no-popup-menus) - ;; No popup menus. Call `tmm-prompt' instead, but with the - ;; up-mouse-button, if any, temporarily disabled, otherwise - ;; it'll interfere. - (let* ((key (artist-compute-up-event-key ev)) - (orig-button-up-binding (lookup-key (current-global-map) key))) - (unwind-protect - (define-key (current-global-map) key 'artist-do-nothing) - (setq op (tmm-prompt artist-popup-menu-table)) - (if orig-button-up-binding - (define-key (current-global-map) key orig-button-up-binding))))) + (list last-input-event (x-popup-menu t artist-popup-menu-table)))) (let ((draw-fn (artist-go-get-draw-fn-from-symbol (car op))) (set-fn (artist-fc-get-fn-from-symbol (car op)))) diff --git a/lisp/tmm.el b/lisp/tmm.el index 9f696c881e1..02237340af7 100644 --- a/lisp/tmm.el +++ b/lisp/tmm.el @@ -27,408 +27,24 @@ ;;; Code: -(require 'electric) -(require 'text-property-search) - (defgroup tmm nil "Text mode access to menu-bar." :prefix "tmm-" :group 'menu) -;;; The following will be localized, added only to pacify the compiler. -(defvar tmm-short-cuts) -(defvar tmm-c-prompt nil) -(defvar tmm-km-list) -(defvar tmm-next-shortcut-digit) -(defvar tmm-table-undef) - ;;;###autoload (define-key global-map "\M-`" 'tmm-menubar) ;;;###autoload -(defun tmm-menubar (&optional x-position) +(defun tmm-menubar (&optional _ignore) "Text-mode emulation of looking and choosing from a menubar. -See the documentation for `tmm-prompt'. -X-POSITION, if non-nil, specifies a horizontal position within the menu bar; -we make that menu bar item (the one at that position) the default choice. Note that \\[menu-bar-open] by default drops down TTY menus; if you want it to invoke `tmm-menubar' instead, customize the variable `tty-menu-open-use-tmm' to a non-nil value." (interactive) (run-hooks 'menu-bar-update-hook) - (if isearch-mode - (isearch-tmm-menubar) - (let ((menu-bar (menu-bar-keymap)) - (menu-bar-item-cons (and x-position - (menu-bar-item-at-x x-position)))) - (tmm-prompt menu-bar - nil - (and menu-bar-item-cons (car menu-bar-item-cons)))))) - -;;;###autoload -(defun tmm-menubar-mouse (event) - "Text-mode emulation of looking and choosing from a menubar. -This command is used when you click the mouse in the menubar -on a console which has no window system but does have a mouse. -See the documentation for `tmm-prompt'." - (interactive "e") - (tmm-menubar (car (posn-x-y (event-start event))))) - -(defcustom tmm-mid-prompt "==>" - "String to insert between shortcut and menu item. -It should not consist only of spaces. If nil, don't use shortcuts." - :type '(choice (const :tag "No shortcuts" nil) - string)) - -(defvar tmm-mb-map nil - "A place to store minibuffer map.") - -(defcustom tmm-shortcut-style '(downcase upcase) - "What letters to use as menu shortcuts. -Must be either one of the symbols `downcase' or `upcase', -or else a list of the two in the order you prefer." - :type '(choice (const downcase) - (const upcase) - (repeat (choice (const downcase) (const upcase))))) - -(defcustom tmm-shortcut-words 2 - "How many successive words to try for shortcuts, nil means all. -If you use only one of `downcase' or `upcase' for `tmm-shortcut-style', -specify nil for this variable." - :type '(choice integer (const nil))) - -(defface tmm-inactive - '((t :inherit shadow)) - "Face used for inactive menu items.") - -(defun tmm--completion-table (items) - (completion-table-with-metadata items '((sort-function . identity)))) - -(defvar tmm--history nil) - -;;;###autoload -(defun tmm-prompt (menu &optional in-popup default-item no-execute) - "Text-mode emulation of calling the bindings in keymap. -Creates a text-mode menu of possible choices. You can access the elements -in the menu in two ways: - *) via history mechanism from minibuffer; - *) Or via completion-buffer that is automatically shown. -The last alternative is currently a hack, you cannot use mouse reliably. - -MENU is like the MENU argument to `x-popup-menu': either a -keymap or an alist of alists. -DEFAULT-ITEM, if non-nil, specifies an initial default choice. -Its value should be an event that has a binding in MENU. -NO-EXECUTE, if non-nil, means to return the command the user selects -instead of executing it." - ;; If the optional argument IN-POPUP is t, - ;; then MENU is an alist of elements of the form (STRING . VALUE). - ;; That is used for recursive calls only. - (let ((gl-str "Menu bar") ;; The menu bar itself is not a menu keymap - ; so it doesn't have a name. - tmm-km-list out history-len tmm-table-undef tmm-c-prompt - tmm-short-cuts - chosen-string choice - (not-menu (not (keymapp menu)))) - (run-hooks 'activate-menubar-hook) - ;; Compute tmm-km-list from MENU. - ;; tmm-km-list is an alist of (STRING . MEANING). - ;; It has no other elements. - ;; The order of elements in tmm-km-list is the order of the menu bar. - (if (not not-menu) - (map-keymap (lambda (k v) (tmm-get-keymap (cons k v))) menu) - (dolist (elt menu) - (cond - ((stringp elt) (setq gl-str elt)) - ((listp elt) (tmm-get-keymap elt not-menu)) - ((vectorp elt) - (dotimes (i (length elt)) - (tmm-get-keymap (cons i (aref elt i)) not-menu)))))) - ;; Choose an element of tmm-km-list; put it in choice. - (if (and not-menu (= 1 (length tmm-km-list))) - ;; If this is the top-level of an x-popup-menu menu, - ;; and there is just one pane, choose that one silently. - ;; This way we only ask the user one question, - ;; for which element of that pane. - (setq choice (cdr (car tmm-km-list))) - (unless tmm-km-list - (error "Empty menu reached")) - (and tmm-km-list - (let ((index-of-default 0)) - (setq tmm-km-list - (if tmm-mid-prompt - (tmm-add-shortcuts tmm-km-list) - ;; tmm-add-shortcuts reverses tmm-km-list internally. - (reverse tmm-km-list))) - ;; Find the default item's index within the menu bar. - ;; We use this to decide the initial minibuffer contents - ;; and initial history position. - (if default-item - (let ((tail menu) visible) - (while (and tail - (not (eq (car-safe (car tail)) default-item))) - ;; Be careful to count only the elements of MENU - ;; that actually constitute menu bar items. - (if (and (consp (car tail)) - (or (stringp (car-safe (cdr (car tail)))) - (and - (eq (car-safe (cdr (car tail))) 'menu-item) - (progn - (setq visible - (plist-get - (nthcdr 4 (car tail)) :visible)) - (or (not visible) (eval visible)))))) - (setq index-of-default (1+ index-of-default))) - (setq tail (cdr tail))))) - (let ((prompt - (concat "^" - (if (stringp tmm-mid-prompt) - (concat "." - (regexp-quote tmm-mid-prompt)))))) - (setq tmm--history - (reverse (delq nil - (mapcar - (lambda (elt) - (if (string-match prompt (car elt)) - (car elt))) - tmm-km-list))))) - (setq history-len (length tmm--history)) - (setq tmm-c-prompt (nth (- history-len 1 index-of-default) - tmm--history)) - (setq out - (if default-item - (car (nth index-of-default tmm-km-list)) - (minibuffer-with-setup-hook - (lambda () - (tmm-define-keys) - (minibuffer-completion-help)) - ;; tmm-km-list is reversed, because history - ;; needs it in LIFO order. But default list - ;; needs it in non-reverse order, so that the - ;; menu items are displayed by M-n as default - ;; values in the order they are shown on - ;; the menu bar. So pass the DEFAULT arg the - ;; reversed copy of the list. - (completing-read - (format-prompt gl-str nil) - (tmm--completion-table tmm-km-list) nil t nil - 'tmm--history (reverse tmm--history))))))) - (setq choice (cdr (assoc out tmm-km-list))) - (and (null choice) - (string-prefix-p tmm-c-prompt out) - (setq out (substring out (length tmm-c-prompt)) - choice (cdr (assoc out tmm-km-list)))) - (and (null choice) out - (setq out (try-completion out tmm-km-list) - choice (cdr (assoc out tmm-km-list))))) - ;; CHOICE is now (STRING . MEANING). Separate the two parts. - (setq chosen-string (car choice)) - (setq choice (cdr choice)) - (cond (in-popup - ;; We just did the inner level of a -popup menu. - choice) - ;; We just did the outer level. Do the inner level now. - (not-menu (tmm-prompt choice t nil no-execute)) - ;; We just handled a menu keymap and found another keymap. - ((keymapp choice) - (if (symbolp choice) - (setq choice (indirect-function choice))) - (condition-case nil - (require 'mouse) - (error nil)) - (tmm-prompt choice nil nil no-execute)) - ;; We just handled a menu keymap and found a command. - (choice - (if chosen-string - (if no-execute choice - (setq last-command-event chosen-string) - (call-interactively choice)) - choice))))) - -(defun tmm-add-shortcuts (list) - "Add shortcuts to cars of elements of the list. -Takes a list of lists with a string as car, returns list with -shortcuts added to these cars. -Stores a list of all the shortcuts in the free variable `tmm-short-cuts'." - (let ((tmm-next-shortcut-digit ?0)) - (mapcar #'tmm-add-one-shortcut (reverse list)))) - -(defsubst tmm-add-one-shortcut (elt) - ;; uses the free vars tmm-next-shortcut-digit and tmm-short-cuts - (cond - ((eq (cddr elt) 'ignore) - (cons (concat " " (make-string (length tmm-mid-prompt) ?\-) - (car elt)) - (cdr elt))) - (t - (let* ((str (car elt)) - (paren (string-search "(" str)) - (pos 0) (word 0) char) - (catch 'done ; ??? is this slow? - (while (and (or (not tmm-shortcut-words) ; no limit on words - (< word tmm-shortcut-words)) ; try n words - (setq pos (string-match "\\w+" str pos)) ; get next word - (not (and paren (> pos paren)))) ; don't go past "(binding.." - (if (or (= pos 0) - (/= (aref str (1- pos)) ?.)) ; avoid file extensions - (dolist (shortcut-style ; try upcase and downcase variants - (if (listp tmm-shortcut-style) ; convert to list - tmm-shortcut-style - (list tmm-shortcut-style))) - (setq char (funcall shortcut-style (aref str pos))) - (if (not (memq char tmm-short-cuts)) (throw 'done char)))) - (setq word (1+ word)) - (setq pos (match-end 0))) - (while (<= tmm-next-shortcut-digit ?9) ; no letter shortcut, pick a digit - (setq char tmm-next-shortcut-digit) - (setq tmm-next-shortcut-digit (1+ tmm-next-shortcut-digit)) - (if (not (memq char tmm-short-cuts)) (throw 'done char))) - (setq char nil)) - (if char (setq tmm-short-cuts (cons char tmm-short-cuts))) - (cons (concat (if char (concat (char-to-string char) tmm-mid-prompt) - ;; keep them lined up in columns - (make-string (1+ (length tmm-mid-prompt)) ?\s)) - str) - (cdr elt)))))) - -(defun tmm-define-keys () - (let ((map (make-sparse-keymap))) - (suppress-keymap map t) - (dolist (c tmm-short-cuts) - (if (listp tmm-shortcut-style) - (define-key map (char-to-string c) 'tmm-shortcut) - ;; only one kind of letters are shortcuts, so map both upcase and - ;; downcase input to the same - (define-key map (char-to-string (downcase c)) 'tmm-shortcut) - (define-key map (char-to-string (upcase c)) 'tmm-shortcut))) - (use-local-map (append map (current-local-map))))) - -(defun tmm-completion-delete-prompt () - (with-current-buffer standard-output - (goto-char (point-min)) - (let* (;; First candidate: first string with mouse-face - (menu-start-1 (or (and (get-text-property (point) 'mouse-face) (point)) - (next-single-char-property-change (point) 'mouse-face))) - ;; Second candidate: an inactive menu item with tmm-inactive face - (tps-result (save-excursion - (text-property-search-forward 'face 'tmm-inactive t))) - (menu-start-2 (and tps-result (prop-match-beginning tps-result)))) - (or (and (null menu-start-1) (null menu-start-2)) - (delete-region (point) - ;; Use the smallest position of the two candidates. - (or (and menu-start-1 menu-start-2 - (min menu-start-1 menu-start-2)) - ;; Otherwise use the one that is non-nil. - menu-start-1 - menu-start-2)))))) - -(defun tmm-remove-inactive-mouse-face () - "Remove the mouse-face property from inactive menu items." - (let ((inhibit-read-only t) - (inactive-string - (concat " " (make-string (length tmm-mid-prompt) ?\-))) - next) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (setq next (next-single-char-property-change (point) 'mouse-face)) - (when (looking-at inactive-string) - (remove-text-properties (point) next '(mouse-face nil)) - (add-text-properties (point) next '(face tmm-inactive))) - (goto-char next))) - (set-buffer-modified-p nil))) - -(defun tmm-shortcut () - "Choose the shortcut that the user typed." - (interactive) - (let ((c last-command-event) s) - (when (functionp tmm-shortcut-style) - (setq c (funcall tmm-shortcut-style c))) - (when (memq c tmm-short-cuts) - (delete-region (minibuffer-prompt-end) (point-max)) - (dolist (elt tmm-km-list) - (if (string= - (substring (car elt) 0 - (min (1+ (length tmm-mid-prompt)) - (length (car elt)))) - (concat (char-to-string c) tmm-mid-prompt)) - (setq s (car elt)))) - (insert s) - (exit-minibuffer)))) - -(defun tmm-get-keymap (elt &optional in-x-menu) - "Prepend (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'. -The values are deduced from the argument ELT, that should be an -element of keymap, an `x-popup-menu' argument, or an element of -`x-popup-menu' argument (when IN-X-MENU is not-nil). -This function adds the element only if it is not already present. -It uses the free variable `tmm-table-undef' to keep undefined keys." - (let (km str plist filter visible enable (event (car elt))) - (setq elt (cdr elt)) - (if (eq elt 'undefined) - (setq tmm-table-undef (cons (cons event nil) tmm-table-undef)) - (unless (assoc event tmm-table-undef) - (cond ((or (functionp elt) (keymapp elt)) - (setq km elt)) - - ((or (keymapp (cdr-safe elt)) (functionp (cdr-safe elt))) - (setq km (cdr elt)) - (and (stringp (car elt)) (setq str (car elt)))) - - ((or (keymapp (cdr-safe (cdr-safe elt))) - (functionp (cdr-safe (cdr-safe elt)))) - (setq km (cddr elt)) - (and (stringp (car elt)) (setq str (car elt)))) - - ((eq (car-safe elt) 'menu-item) - ;; (menu-item TITLE COMMAND KEY ...) - (setq plist (cdr-safe (cdr-safe (cdr-safe elt)))) - (when (consp (car-safe plist)) - (setq plist (cdr-safe plist))) - (setq km (nth 2 elt)) - (setq str (eval (nth 1 elt))) - (setq filter (plist-get plist :filter)) - (if filter - (setq km (funcall filter km))) - (setq visible (plist-get plist :visible)) - (if visible - (setq km (and (eval visible) km))) - (setq enable (plist-get plist :enable)) - (if enable - (setq km (if (eval enable) km 'ignore)))) - - ((or (keymapp (cdr-safe (cdr-safe (cdr-safe elt)))) - (functionp (cdr-safe (cdr-safe (cdr-safe elt))))) - ; New style of easy-menu - (setq km (cdr (cddr elt))) - (and (stringp (car elt)) (setq str (car elt)))) - - ((stringp event) ; x-popup or x-popup element - (setq str event) - (setq event nil) - (setq km (if (or in-x-menu (stringp (car-safe elt))) - elt (cons 'keymap elt))))) - (unless (or (eq km 'ignore) (null str)) - (let ((binding (where-is-internal km nil t))) - (when binding - (setq binding (key-description binding)) - ;; Try to align the keybindings. - (let ((colwidth (min 30 (- (/ (window-width) 2) 10)))) - (setq str - (concat str - (make-string (max 2 (- colwidth - (string-width str) - (string-width binding))) - ?\s) - binding))))))) - (and km (stringp km) (setq str km)) - ;; Verify that the command is enabled; - ;; if not, don't mention it. - (when (and km (symbolp km) (get km 'menu-enable)) - (setq km (if (eval (get km 'menu-enable)) km 'ignore))) - (and km str - (or (assoc str tmm-km-list) - (push (cons str (cons event km)) tmm-km-list)))))) + (let ((help-complete-keys-method 'nest)) + (help-complete-keys [menu-bar]))) (provide 'tmm) -- 2.39.5