Add new 'flx' completion stylescratch/new-flx-completion-style

* lisp/minibuffer.el (completion-styles-alist): Add flx.
(completion-substring--all-completions): Accept
TRANSFORM-PATTERN-FN.
(completion-flx-all-completions, completion-flx-try-completion)
(completion-flx--make-flx-pattern): New functions.

1 files changed, 70 insertions, 1 deletions

diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index b757eb8a5a6..22e7cd82271 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -788,6 +788,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*\".")
+    (flx
+     completion-flx-try-completion completion-flx-all-completions
+     "Completion of an in-order subset of characters.
+When completing \"foo\" the glob \"*f*o*o*\" is used, so that
+i.e. foo can complete to frodo.")
     (initials
      completion-initials-try-completion completion-initials-all-completions
      "Completion of acronyms and initialisms.
@@ -3345,7 +3350,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))
@@ -3356,6 +3366,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))))
 
@@ -3375,6 +3388,62 @@ the same set of elements."
       (nconc (completion-pcm--hilit-commonality pattern all)
              (length prefix)))))
 
+;; "flx" completion, also known as flex/fuzzy/glob completion
+;; Complete "foo" to "frodo"
+
+(defun completion-flx--make-flx-pattern (pattern)
+  "Convert PCM-style PATTERN into PCM-style flx pattern.
+
+This turns
+    (prefix \"foo\" point)
+into
+    (prefix \"f\" star \"o\" star \"o\" star point)
+which is at the core of flx logic.  The extra
+'star' is optimized away later on."
+  (mapcan (lambda (elem)
+            (if (stringp elem)
+                (mapcan (lambda (char)
+                          (list (string char) 'star))
+                        elem)
+              (list elem)))
+          pattern))
+
+(defun completion-flx-try-completion (string table pred point)
+  "Try to flx-complete STRING in TABLE given PRED and POINT."
+  (pcase-let ((`(,all ,_pattern ,_prefix ,_suffix ,_carbounds)
+               (completion-substring--all-completions
+                string table pred point
+                #'completion-flx--make-flx-pattern)))
+    (if minibuffer-completing-file-name
+        (setq all (completion-pcm--filename-try-filter all)))
+    (cond ((not (consp all))
+           all)
+          (t
+           (cond ((not (consp (cdr all))) ; single completion
+                  (if (equal string (car all))
+                      t
+                    (cons (car all) (length (car all)))))
+                 (t
+                  ;; If more than one, try some basic substring
+                  ;; merging.  This is acceptable in flx, i.e. it
+                  ;; shouldn't incorrectly remove any possible
+                  ;; candidates.  If that fails, leave user input
+                  ;; untouched
+                  (let ((probe (try-completion string all)))
+                    (if (stringp probe)
+                        (cons probe (length probe))
+                      (cons string point)))))))))
+
+(defun completion-flx-all-completions (string table pred point)
+  "Get flx-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-flx--make-flx-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.