; 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'.

diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el
index b71475e0b374a73b4a00dff6b87835fe87a76565..3580c9dfef976ec323acef35101dee5351c1cc46 100644 (file)
--- 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 e299a166ea7ed17923a4e58e44c27955a9b84a19..01d1d97e43e5b70319afee98ef57b6704263aaed 100644 (file)
--- 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'