summaryrefslogtreecommitdiff
path: root/lisp/minibuffer.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/minibuffer.el')
-rw-r--r--lisp/minibuffer.el351
1 files changed, 242 insertions, 109 deletions
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 67c691ca212..52455ccc40c 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -269,7 +269,7 @@ the form (concat S2 S)."
(+ beg (- (length s1) (length s2))))
. ,(and (eq (car-safe res) 'boundaries) (cddr res)))))
((stringp res)
- (if (string-prefix-p s2 string completion-ignore-case)
+ (if (string-prefix-p s2 res completion-ignore-case)
(concat s1 (substring res (length s2)))))
((eq action t)
(let ((bounds (completion-boundaries str table pred "")))
@@ -682,9 +682,9 @@ for use at QPOS."
;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
(define-obsolete-function-alias
- 'complete-in-turn 'completion-table-in-turn "23.1")
+ 'complete-in-turn #'completion-table-in-turn "23.1")
(define-obsolete-function-alias
- 'dynamic-completion-table 'completion-table-dynamic "23.1")
+ 'dynamic-completion-table #'completion-table-dynamic "23.1")
;;; Minibuffer completion
@@ -693,6 +693,9 @@ for use at QPOS."
:link '(custom-manual "(emacs)Minibuffer")
:group 'environment)
+(defvar minibuffer-message-properties nil
+ "Text properties added to the text shown by `minibuffer-message'.")
+
(defun minibuffer-message (message &rest args)
"Temporarily display MESSAGE at the end of the minibuffer.
The text is displayed for `minibuffer-message-timeout' seconds,
@@ -702,7 +705,7 @@ If ARGS are provided, then pass MESSAGE through `format-message'."
(if (not (minibufferp (current-buffer)))
(progn
(if args
- (apply 'message message args)
+ (apply #'message message args)
(message "%s" message))
(prog1 (sit-for (or minibuffer-message-timeout 1000000))
(message nil)))
@@ -714,6 +717,10 @@ If ARGS are provided, then pass MESSAGE through `format-message'."
(copy-sequence message)
(concat " [" message "]")))
(when args (setq message (apply #'format-message message args)))
+ (unless (or (null minibuffer-message-properties)
+ ;; Don't overwrite the face properties the caller has set
+ (text-properties-at 0 message))
+ (setq message (apply #'propertize message minibuffer-message-properties)))
(let ((ol (make-overlay (point-max) (point-max) nil t t))
;; A quit during sit-for normally only interrupts the sit-for,
;; but since minibuffer-message is used at the end of a command,
@@ -735,7 +742,8 @@ If ARGS are provided, then pass MESSAGE through `format-message'."
(defun minibuffer-completion-contents ()
"Return the user input in a minibuffer before point as a string.
-In Emacs-22, that was what completion commands operated on."
+In Emacs 22, that was what completion commands operated on.
+If the current buffer is not a minibuffer, return everything before point."
(declare (obsolete nil "24.4"))
(buffer-substring (minibuffer-prompt-end) (point)))
@@ -793,6 +801,11 @@ Additionally the user can use the char \"*\" as a glob pattern.")
I.e. when completing \"foo_bar\" (where _ is the position of point),
it will consider all completions candidates matching the glob
pattern \"*foo*bar*\".")
+ (flex
+ completion-flex-try-completion completion-flex-all-completions
+ "Completion of an in-order subset of characters.
+When completing \"foo\" the glob \"*f*o*o*\" is used, so that
+\"foo\" can complete to \"frodo\".")
(initials
completion-initials-try-completion completion-initials-all-completions
"Completion of acronyms and initialisms.
@@ -840,7 +853,9 @@ styles for specific categories, such as files, buffers, etc."
(defvar completion-category-defaults
'((buffer (styles . (basic substring)))
(unicode-name (styles . (basic substring)))
- (project-file (styles . (basic substring)))
+ ;; A new style that combines substring and pcm might be better,
+ ;; e.g. one that does not anchor to bos.
+ (project-file (styles . (substring)))
(info-menu (styles . (basic substring))))
"Default settings for specific completion categories.
Each entry has the shape (CATEGORY . ALIST) where ALIST is
@@ -1008,7 +1023,7 @@ completion candidates than this number."
(defvar-local completion-all-sorted-completions nil)
(defvar-local completion--all-sorted-completions-location nil)
-(defvar completion-cycling nil)
+(defvar completion-cycling nil) ;Function that takes down the cycling map.
(defvar completion-fail-discreetly nil
"If non-nil, stay quiet when there is no match.")
@@ -1040,7 +1055,7 @@ when the buffer's text is already an exact match."
(let* ((string (buffer-substring beg end))
(md (completion--field-metadata beg))
(comp (funcall (or try-completion-function
- 'completion-try-completion)
+ #'completion-try-completion)
string
minibuffer-completion-table
minibuffer-completion-predicate
@@ -1133,7 +1148,7 @@ when the buffer's text is already an exact match."
;; Show the completion table, if requested.
((not exact)
(if (pcase completion-auto-help
- (`lazy (eq this-command last-command))
+ ('lazy (eq this-command last-command))
(_ completion-auto-help))
(minibuffer-completion-help beg end)
(completion--message "Next char not unique")))
@@ -1193,7 +1208,7 @@ scroll the window of possible completions."
(defun completion--cache-all-sorted-completions (beg end comps)
(add-hook 'after-change-functions
- 'completion--flush-all-sorted-completions nil t)
+ #'completion--flush-all-sorted-completions nil t)
(setq completion--all-sorted-completions-location
(cons (copy-marker beg) (copy-marker end)))
(setq completion-all-sorted-completions comps))
@@ -1203,8 +1218,10 @@ scroll the window of possible completions."
(or (> start (cdr completion--all-sorted-completions-location))
(< end (car completion--all-sorted-completions-location))))
(remove-hook 'after-change-functions
- 'completion--flush-all-sorted-completions t)
- (setq completion-cycling nil)
+ #'completion--flush-all-sorted-completions t)
+ ;; Remove the transient map if applicable.
+ (when completion-cycling
+ (funcall (prog1 completion-cycling (setq completion-cycling nil))))
(setq completion-all-sorted-completions nil)))
(defun completion--metadata (string base md-at-point table pred)
@@ -1244,15 +1261,23 @@ scroll the window of possible completions."
(setq all (delete-dups all))
(setq last (last all))
- (setq all (if sort-fun (funcall sort-fun all)
- ;; Prefer shorter completions, by default.
- (sort all (lambda (c1 c2) (< (length c1) (length c2))))))
- ;; Prefer recently used completions.
- (when (minibufferp)
- (let ((hist (symbol-value minibuffer-history-variable)))
- (setq all (sort all (lambda (c1 c2)
- (> (length (member c1 hist))
- (length (member c2 hist))))))))
+ (cond
+ (sort-fun
+ (setq all (funcall sort-fun all)))
+ (t
+ ;; Prefer shorter completions, by default.
+ (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2)))))
+ (if (minibufferp)
+ ;; Prefer recently used completions and put the default, if
+ ;; it exists, on top.
+ (let ((hist (symbol-value minibuffer-history-variable)))
+ (setq all
+ (sort all
+ (lambda (c1 c2)
+ (cond ((equal c1 minibuffer-default) t)
+ ((equal c2 minibuffer-default) nil)
+ (t (> (length (member c1 hist))
+ (length (member c2 hist))))))))))))
;; Cache the result. This is not just for speed, but also so that
;; repeated calls to minibuffer-force-complete can cycle through
;; all possibilities.
@@ -1262,16 +1287,23 @@ scroll the window of possible completions."
(defun minibuffer-force-complete-and-exit ()
"Complete the minibuffer with first of the matches and exit."
(interactive)
- (minibuffer-force-complete)
+ ;; If `completion-cycling' is t, then surely a
+ ;; `minibuffer-force-complete' has already executed. This is not
+ ;; just for speed: the extra rotation caused by the second
+ ;; unnecessary call would mess up the final result value
+ ;; (bug#34116).
+ (unless completion-cycling
+ (minibuffer-force-complete nil nil 'dont-cycle))
(completion--complete-and-exit
(minibuffer-prompt-end) (point-max) #'exit-minibuffer
;; If the previous completion completed to an element which fails
;; test-completion, then we shouldn't exit, but that should be rare.
(lambda () (minibuffer-message "Incomplete"))))
-(defun minibuffer-force-complete (&optional start end)
+(defun minibuffer-force-complete (&optional start end dont-cycle)
"Complete the minibuffer to an exact match.
-Repeated uses step through the possible completions."
+Repeated uses step through the possible completions.
+DONT-CYCLE tells the function not to setup cycling."
(interactive)
(setq minibuffer-scroll-window nil)
;; FIXME: Need to deal with the extra-size issue here as well.
@@ -1284,7 +1316,7 @@ Repeated uses step through the possible completions."
(base (+ start (or (cdr (last all)) 0))))
(cond
((not (consp all))
- (completion--message
+ (completion--message
(if all "No more completions" "No completions")))
((not (consp (cdr all)))
(let ((done (equal (car all) (buffer-substring-no-properties base end))))
@@ -1295,38 +1327,39 @@ Repeated uses step through the possible completions."
(completion--replace base end (car all))
(setq end (+ base (length (car all))))
(completion--done (buffer-substring-no-properties start (point)) 'sole)
- ;; Set cycling after modifying the buffer since the flush hook resets it.
- (setq completion-cycling t)
(setq this-command 'completion-at-point) ;For completion-in-region.
- ;; If completing file names, (car all) may be a directory, so we'd now
- ;; have a new set of possible completions and might want to reset
- ;; completion-all-sorted-completions to nil, but we prefer not to,
- ;; so that repeated calls minibuffer-force-complete still cycle
- ;; through the previous possible completions.
- (let ((last (last all)))
- (setcdr last (cons (car all) (cdr last)))
- (completion--cache-all-sorted-completions start end (cdr all)))
- ;; Make sure repeated uses cycle, even though completion--done might
- ;; have added a space or something that moved us outside of the field.
- ;; (bug#12221).
- (let* ((table minibuffer-completion-table)
- (pred minibuffer-completion-predicate)
- (extra-prop completion-extra-properties)
- (cmd
- (lambda () "Cycle through the possible completions."
- (interactive)
- (let ((completion-extra-properties extra-prop))
- (completion-in-region start (point) table pred)))))
- (set-transient-map
- (let ((map (make-sparse-keymap)))
- (define-key map [remap completion-at-point] cmd)
- (define-key map (vector last-command-event) cmd)
- map)))))))
+ ;; Set cycling after modifying the buffer since the flush hook resets it.
+ (unless dont-cycle
+ ;; If completing file names, (car all) may be a directory, so we'd now
+ ;; have a new set of possible completions and might want to reset
+ ;; completion-all-sorted-completions to nil, but we prefer not to,
+ ;; so that repeated calls minibuffer-force-complete still cycle
+ ;; through the previous possible completions.
+ (let ((last (last all)))
+ (setcdr last (cons (car all) (cdr last)))
+ (completion--cache-all-sorted-completions start end (cdr all)))
+ ;; Make sure repeated uses cycle, even though completion--done might
+ ;; have added a space or something that moved us outside of the field.
+ ;; (bug#12221).
+ (let* ((table minibuffer-completion-table)
+ (pred minibuffer-completion-predicate)
+ (extra-prop completion-extra-properties)
+ (cmd
+ (lambda () "Cycle through the possible completions."
+ (interactive)
+ (let ((completion-extra-properties extra-prop))
+ (completion-in-region start (point) table pred)))))
+ (setq completion-cycling
+ (set-transient-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [remap completion-at-point] cmd)
+ (define-key map (vector last-command-event) cmd)
+ map)))))))))
(defvar minibuffer-confirm-exit-commands
'(completion-at-point minibuffer-complete
minibuffer-complete-word PC-complete PC-complete-word)
- "A list of commands which cause an immediately following
+ "List of commands which cause an immediately following
`minibuffer-complete-and-exit' to ask for extra confirmation.")
(defun minibuffer-complete-and-exit ()
@@ -1539,7 +1572,7 @@ horizontally in alphabetical order, rather than down the screen."
Uses columns to keep the listing readable but compact.
It also eliminates runs of equal strings."
(when (consp strings)
- (let* ((length (apply 'max
+ (let* ((length (apply #'max
(mapcar (lambda (s)
(if (consp s)
(+ (string-width (car s))
@@ -1712,7 +1745,8 @@ It can find the completion buffer in `standard-output'."
(with-temp-buffer
(let ((standard-output (current-buffer))
(completion-setup-hook nil))
- (display-completion-list completions common-substring))
+ (with-suppressed-warnings ((callargs display-completion-list))
+ (display-completion-list completions common-substring)))
(princ (buffer-string)))
(with-current-buffer standard-output
@@ -1830,12 +1864,7 @@ variables.")
;; window, mark it as softly-dedicated, so bury-buffer in
;; minibuffer-hide-completions will know whether to
;; delete the window or not.
- (display-buffer-mark-dedicated 'soft)
- ;; Disable `pop-up-windows' temporarily to allow
- ;; `display-buffer--maybe-pop-up-frame-or-window'
- ;; in the display actions below to pop up a frame
- ;; if `pop-up-frames' is non-nil, but not to pop up a window.
- (pop-up-windows nil))
+ (display-buffer-mark-dedicated 'soft))
(with-displayed-buffer-window
"*Completions*"
;; This is a copy of `display-buffer-fallback-action'
@@ -1843,7 +1872,7 @@ variables.")
;; with `display-buffer-at-bottom'.
`((display-buffer--maybe-same-window
display-buffer-reuse-window
- display-buffer--maybe-pop-up-frame-or-window
+ display-buffer--maybe-pop-up-frame
;; Use `display-buffer-below-selected' for inline completions,
;; but not in the minibuffer (e.g. in `eval-expression')
;; for which `display-buffer-at-bottom' is used.
@@ -2105,9 +2134,9 @@ a completion function or god knows what else.")
;; like comint-completion-at-point or mh-letter-completion-at-point, which
;; could be sometimes safe and sometimes misbehaving (and sometimes neither).
(if (pcase which
- (`all t)
- (`safe (member fun completion--capf-safe-funs))
- (`optimist (not (member fun completion--capf-misbehave-funs))))
+ ('all t)
+ ('safe (member fun completion--capf-safe-funs))
+ ('optimist (not (member fun completion--capf-misbehave-funs))))
(let ((res (funcall fun)))
(cond
((and (consp res) (not (functionp res)))
@@ -2278,7 +2307,7 @@ Useful to give the user default values that won't be substituted."
(if (and (not (file-name-quoted-p filename))
(file-name-absolute-p filename)
(string-match-p (if (memq system-type '(windows-nt ms-dos))
- "[/\\\\]~" "/~")
+ "[/\\]~" "/~")
(file-local-name filename)))
(file-name-quote filename)
(minibuffer--double-dollars filename)))
@@ -2292,7 +2321,7 @@ Useful to give the user default values that won't be substituted."
;; We can't reuse env--substitute-vars-regexp because we need to match only
;; potentially-unfinished envvars at end of string.
(concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
- "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
+ "\\$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
(defun completion--embedded-envvar-table (string _pred action)
"Completion table for envvars embedded in a string.
@@ -2333,7 +2362,7 @@ same as `substitute-in-file-name'."
(match-beginning 0)))))))
(t
(if (eq (aref string (1- beg)) ?{)
- (setq table (apply-partially 'completion-table-with-terminator
+ (setq table (apply-partially #'completion-table-with-terminator
"}" table)))
;; Even if file-name completion is case-insensitive, we want
;; envvar completion to be case-sensitive.
@@ -2467,7 +2496,7 @@ except that it passes the file name through `substitute-in-file-name'.")
#'completion--file-name-table)
"Internal subroutine for `read-file-name'. Do not call this.")
-(defvar read-file-name-function 'read-file-name-default
+(defvar read-file-name-function #'read-file-name-default
"The function called by `read-file-name' to do its work.
It should accept the same arguments as `read-file-name'.")
@@ -2732,17 +2761,9 @@ See `read-file-name' for the meaning of the arguments."
(if (string= val1 (cadr file-name-history))
(pop file-name-history)
(setcar file-name-history val1)))
- (if add-to-history
- ;; Add the value to the history--but not if it matches
- ;; the last value already there.
- (let ((val1 (minibuffer-maybe-quote-filename val)))
- (unless (and (consp file-name-history)
- (equal (car file-name-history) val1))
- (setq file-name-history
- (cons val1
- (if history-delete-duplicates
- (delete val1 file-name-history)
- file-name-history)))))))
+ (when add-to-history
+ (add-to-history 'file-name-history
+ (minibuffer-maybe-quote-filename val))))
val))))
(defun internal-complete-buffer-except (&optional buffer)
@@ -2750,8 +2771,8 @@ See `read-file-name' for the meaning of the arguments."
BUFFER nil or omitted means use the current buffer.
Like `internal-complete-buffer', but removes BUFFER from the completion list."
(let ((except (if (stringp buffer) buffer (buffer-name buffer))))
- (apply-partially 'completion-table-with-predicate
- 'internal-complete-buffer
+ (apply-partially #'completion-table-with-predicate
+ #'internal-complete-buffer
(lambda (name)
(not (equal (if (consp name) (car name) name) except)))
nil)))
@@ -2958,26 +2979,6 @@ or a symbol, see `completion-pcm--merge-completions'."
;; It should be avoided properly, but it's so easy to remove it here.
(delete "" (nreverse pattern)))))
-(defun completion-pcm--optimize-pattern (p)
- ;; Remove empty strings in a separate phase since otherwise a ""
- ;; might prevent some other optimization, as in '(any "" any).
- (setq p (delete "" p))
- (let ((n '()))
- (while p
- (pcase p
- (`(,(and s1 (pred stringp)) ,(and s2 (pred stringp)) . ,rest)
- (setq p (cons (concat s1 s2) rest)))
- (`(,(and p1 (pred symbolp)) ,(and p2 (guard (eq p1 p2))) . ,_)
- (setq p (cdr p)))
- (`(star ,(pred symbolp) . ,rest) (setq p `(star . ,rest)))
- (`(,(pred symbolp) star . ,rest) (setq p `(star . ,rest)))
- (`(point ,(or `any `any-delim) . ,rest) (setq p `(point . ,rest)))
- (`(,(or `any `any-delim) point . ,rest) (setq p `(point . ,rest)))
- (`(any ,(or `any `any-delim) . ,rest) (setq p `(any . ,rest)))
- (`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'.
- (_ (push (pop p) n))))
- (nreverse n)))
-
(defun completion-pcm--pattern->regex (pattern &optional group)
(let ((re
(concat "\\`"
@@ -2999,6 +3000,17 @@ or a symbol, see `completion-pcm--merge-completions'."
(setq re (replace-match "" t t re 1)))
re))
+(defun completion-pcm--pattern-point-idx (pattern)
+ "Return index of subgroup corresponding to `point' element of PATTERN.
+Return nil if there's no such element."
+ (let ((idx nil)
+ (i 0))
+ (dolist (x pattern)
+ (unless (stringp x)
+ (cl-incf i)
+ (if (eq x 'point) (setq idx i))))
+ idx))
+
(defun completion-pcm--all-completions (prefix pattern table pred)
"Find all completions for PATTERN in TABLE obeying PRED.
PATTERN is as returned by `completion-pcm--string->pattern'."
@@ -3028,9 +3040,21 @@ PATTERN is as returned by `completion-pcm--string->pattern'."
(when (string-match-p regex c) (push c poss)))
(nreverse poss))))))
+(defvar flex-score-match-tightness 100
+ "Controls how the `flex' completion style scores its matches.
+
+Value is a positive number. Values smaller than one make the
+scoring formula value matches scattered along the string, while
+values greater than one make the formula value tighter matches.
+I.e \"foo\" matches both strings \"barbazfoo\" and \"fabrobazo\",
+which are of equal length, but only a value greater than one will
+score the former (which has one \"hole\") higher than the
+latter (which has two).")
+
(defun completion-pcm--hilit-commonality (pattern completions)
(when completions
- (let* ((re (completion-pcm--pattern->regex pattern '(point)))
+ (let* ((re (completion-pcm--pattern->regex pattern 'group))
+ (point-idx (completion-pcm--pattern-point-idx pattern))
(case-fold-search completion-ignore-case))
(mapcar
(lambda (str)
@@ -3038,15 +3062,70 @@ PATTERN is as returned by `completion-pcm--string->pattern'."
(setq str (copy-sequence str))
(unless (string-match re str)
(error "Internal error: %s does not match %s" re str))
- (let ((pos (or (match-beginning 1) (match-end 0))))
- (put-text-property 0 pos
+ (let* ((pos (if point-idx (match-beginning point-idx) (match-end 0)))
+ (md (match-data))
+ (start (pop md))
+ (end (pop md))
+ (len (length str))
+ ;; To understand how this works, consider these bad
+ ;; ascii(tm) diagrams showing how the pattern \"foo\"
+ ;; flex-matches \"fabrobazo" and
+ ;; \"barfoobaz\":
+
+ ;; f abr o baz o
+ ;; + --- + --- +
+
+ ;; bar foo baz
+ ;; --- +++ ---
+
+ ;; Where + indicates parts where the pattern matched,
+ ;; - where it didn't match. The score is a number
+ ;; bound by ]0..1]: the higher the better and only a
+ ;; perfect match (pattern equals string) will have
+ ;; score 1. The formula takes the form of a quotient.
+ ;; For the numerator, we use the number of +, i.e. the
+ ;; length of the pattern. For the denominator, it
+ ;; sums (1+ (/ (grouplen - 1)
+ ;; flex-score-match-tightness)) across all groups of
+ ;; -, sums one to that total, and then multiples by
+ ;; the length of the string.
+ (score-numerator 0)
+ (score-denominator 0)
+ (last-b 0)
+ (update-score
+ (lambda (a b)
+ "Update score variables given match range (A B)."
+ (setq
+ score-numerator (+ score-numerator (- b a)))
+ (unless (= a last-b)
+ (setq
+ score-denominator (+ score-denominator
+ 1
+ (/ (- a last-b 1)
+ flex-score-match-tightness
+ 1.0))))
+ (setq
+ last-b b))))
+ (funcall update-score start start)
+ (while md
+ (funcall update-score start (car md))
+ (put-text-property start (pop md)
+ 'font-lock-face 'completions-common-part
+ str)
+ (setq start (pop md)))
+ (funcall update-score len len)
+ (put-text-property start end
'font-lock-face 'completions-common-part
str)
(if (> (length str) pos)
(put-text-property pos (1+ pos)
- 'font-lock-face 'completions-first-difference
- str)))
- str)
+ 'font-lock-face 'completions-first-difference
+ str))
+ (unless (zerop (length str))
+ (put-text-property
+ 0 1 'completion-score
+ (/ score-numerator (* len (1+ score-denominator)) 1.0) str)))
+ str)
completions))))
(defun completion-pcm--find-all-completions (string table pred point
@@ -3327,7 +3406,12 @@ the same set of elements."
;;; Substring completion
;; Mostly derived from the code of `basic' completion.
-(defun completion-substring--all-completions (string table pred point)
+(defun completion-substring--all-completions
+ (string table pred point &optional transform-pattern-fn)
+ "Match the presumed substring STRING to the entries in TABLE.
+Respect PRED and POINT. The pattern used is a PCM-style
+substring pattern, but it be massaged by TRANSFORM-PATTERN-FN, if
+that is non-nil."
(let* ((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(bounds (completion-boundaries beforepoint table pred afterpoint))
@@ -3338,6 +3422,9 @@ the same set of elements."
(pattern (if (not (stringp (car basic-pattern)))
basic-pattern
(cons 'prefix basic-pattern)))
+ (pattern (if transform-pattern-fn
+ (funcall transform-pattern-fn pattern)
+ pattern))
(all (completion-pcm--all-completions prefix pattern table pred)))
(list all pattern prefix suffix (car bounds))))
@@ -3357,6 +3444,52 @@ the same set of elements."
(nconc (completion-pcm--hilit-commonality pattern all)
(length prefix)))))
+;;; "flex" completion, also known as flx/fuzzy/scatter completion
+;; Completes "foo" to "frodo" and "farfromsober"
+
+(defun completion-flex--make-flex-pattern (pattern)
+ "Convert PCM-style PATTERN into PCM-style flex pattern.
+
+This turns
+ (prefix \"foo\" point)
+into
+ (prefix \"f\" any \"o\" any \"o\" any point)
+which is at the core of flex logic. The extra
+'any' is optimized away later on."
+ (mapcan (lambda (elem)
+ (if (stringp elem)
+ (mapcan (lambda (char)
+ (list (string char) 'any))
+ elem)
+ (list elem)))
+ pattern))
+
+(defun completion-flex-try-completion (string table pred point)
+ "Try to flex-complete STRING in TABLE given PRED and POINT."
+ (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds)
+ (completion-substring--all-completions
+ string table pred point
+ #'completion-flex--make-flex-pattern)))
+ (if minibuffer-completing-file-name
+ (setq all (completion-pcm--filename-try-filter all)))
+ ;; Try some "merging", meaning add as much as possible to the
+ ;; user's pattern without losing any possible matches in `all'.
+ ;; i.e this will augment "cfi" to "config" if all candidates
+ ;; contain the substring "config". FIXME: this still won't
+ ;; augment "foo" to "froo" when matching "frodo" and
+ ;; "farfromsober".
+ (completion-pcm--merge-try pattern all prefix suffix)))
+
+(defun completion-flex-all-completions (string table pred point)
+ "Get flex-completions of STRING in TABLE, given PRED and POINT."
+ (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds)
+ (completion-substring--all-completions
+ string table pred point
+ #'completion-flex--make-flex-pattern)))
+ (when all
+ (nconc (completion-pcm--hilit-commonality pattern all)
+ (length prefix)))))
+
;; Initials completion
;; Complete /ums to /usr/monnier/src or lch to list-command-history.
@@ -3399,7 +3532,7 @@ the same set of elements."
(when newstr
(completion-pcm-try-completion newstr table pred (length newstr)))))
-(defvar completing-read-function 'completing-read-default
+(defvar completing-read-function #'completing-read-default
"The function called by `completing-read' to do its work.
It should accept the same arguments as `completing-read'.")