From 2a64d732c7736e1b79d07f7bcb363875e097952a Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Mon, 22 Jan 2024 17:39:11 +0100 Subject: [PATCH] ; Allow completion tables to adjust 'minibuffer-completion-base' This adds a new completion metadata function 'adjust-base-function' that completion tables can provide in order to adjust 'minibuffer-completion-base' around calls to completions sorting and annotation functions. In particular, this allows 'c-r-m' to remove inputs that end before the current partial input from 'minibuffer-completion-base', to avoid throwing off functions that treat 'minibuffer-completion-base' as a prefix of the set of completion candidates, e.g. the directory part in file completion. * lisp/minibuffer.el (completion-metadata): New completion metadata entry 'adjust-base-function'. (completion-all-sorted-completions, minibuffer-completion-help): Use it to adjust 'minibuffer-completion-base'. * lisp/emacs-lisp/crm.el (crm--table): Extend metadata with an 'adjust-base-function'. --- lisp/emacs-lisp/crm.el | 11 ++++++++++- lisp/minibuffer.el | 37 ++++++++++++++++++++++++------------- 2 files changed, 34 insertions(+), 14 deletions(-) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index b71475e0b37..3580c9dfef9 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -353,7 +353,16 @@ that fails this command prompts you for the separator to use." (string-match crm-current-separator suffix))))) `(boundaries ,(+ (car bounds) beg) . ,(cdr bounds)))) - ('metadata (completion-metadata (substring s beg) table p)) + ('metadata + ;; Adjust `minibuffer-completion-base' for annotation functions. + (let ((md (completion-metadata (substring s beg) table p))) + (cons 'metadata + (cons (cons 'adjust-base-function + (lambda (base) + (funcall (or (alist-get 'adjust-base-function md) + #'identity) + (substring base beg)))) + (cdr-safe md))))) ('nil (let ((comp (complete-with-action a table (substring s beg) p))) (if (stringp comp) (concat (substring s 0 beg) comp) comp))) ('completion--unquote diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index e299a166ea7..01d1d97e43e 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -141,6 +141,11 @@ This metadata is an alist. Currently understood keys are: - `narrow-completions-function': function for narrowing (restricting) the completions list. This function overrides `minibuffer-narrow-completions-function', which see. +- `adjust-base-function': function used to adjust the completion + base, which is the part of the minibuffer input that is elided + from all completion candidates, such as the directory part + during file name completion. This function should take one + argument, the original completion base, and return a new base. The metadata of a completion table should be constant between two boundaries." (let ((metadata (if (functionp table) (funcall table string pred 'metadata)))) @@ -1873,7 +1878,11 @@ include as `display-sort-function' in completion metadata." (sort-fun (or minibuffer-completions-sort-function (completion-metadata-get all-md 'cycle-sort-function))) - (group-fun (completion-metadata-get all-md 'group-function))) + (group-fun (completion-metadata-get all-md 'group-function)) + (full-base (substring string 0 base-size)) + (minibuffer-completion-base + (funcall (or (alist-get 'adjust-base-function all-md) #'identity) + full-base))) (when last (setcdr last nil) @@ -1899,20 +1908,19 @@ include as `display-sort-function' in completion metadata." ;; exists, on top. (when (minibufferp) (setq all (minibuffer--sort-by-position - (minibuffer--sort-preprocess-history - (substring string 0 base-size)) + (minibuffer--sort-preprocess-history full-base) all))))) ;; Cache input for `minibuffer-restore-completion-input', ;; unless STRING is an exact and sole completion. - (and (minibufferp) - (or (consp (cdr all)) ; not sole - (not (equal (car all) string))) ; not exact - (minibuffer--cache-completion-input - (substring string base-size) - (buffer-substring-no-properties (minibuffer-prompt-end) - (+ (minibuffer-prompt-end) - base-size)))) + (let ((input (substring string base-size))) + (and (minibufferp) + (or (consp (cdr all)) ; not sole + (not (equal input (car all)))) ; not exact + (minibuffer--cache-completion-input + input (buffer-substring (minibuffer-prompt-end) + (+ (minibuffer-prompt-end) + base-size))))) ;; Cache the result. This is not just for speed, but also so that ;; repeated calls to minibuffer-force-complete can cycle through @@ -2924,7 +2932,7 @@ completions list." (completion--fail))) (let* ((prefix (unless (zerop base-size) (substring string 0 base-size))) - (minibuffer-completion-base (substring string 0 base-size)) + (full-base (substring string 0 base-size)) (base-prefix (buffer-substring (minibuffer--completion-prompt-end) (+ start base-size))) (base-suffix @@ -2948,6 +2956,9 @@ completions list." (sort-fun (completion-metadata-get all-md 'display-sort-function)) (group-fun (completion-metadata-get all-md 'group-function)) (completion-category (completion-metadata-get all-md 'category)) + (minibuffer-completion-base + (funcall (or (alist-get 'adjust-base-function all-md) #'identity) + full-base)) (mainbuf (current-buffer)) ;; If the *Completions* buffer is shown in a new ;; window, mark it as softly-dedicated, so bury-buffer in @@ -2955,7 +2966,7 @@ completions list." ;; delete the window or not. (display-buffer-mark-dedicated 'soft)) (minibuffer--cache-completion-input (substring string base-size) - minibuffer-completion-base) + full-base) (with-current-buffer-window "*Completions*" ;; This is a copy of `display-buffer-fallback-action' -- 2.39.5