From 93ba3b5455f7c92bb9d57053bac48a58d7e2e21e Mon Sep 17 00:00:00 2001
From: Eshel Yaron <me@eshelyaron.com>
Date: Thu, 18 Jul 2024 19:36:34 +0200
Subject: [PATCH] Add 'regexp' completion style

---
 lisp/minibuffer.el | 66 +++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 65 insertions(+), 1 deletion(-)

diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index d6e2e8accfa..e18aac8b30e 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -1124,7 +1124,10 @@ and C-x C-f ~/sew to ~/src/emacs/work.")
      completion-shorthand-try-completion completion-shorthand-all-completions
      "Completion of symbol shorthands setup in `read-symbol-shorthands'.
 E.g. can complete \"x-foo\" to \"xavier-foo\" if the shorthand
-((\"x-\" . \"xavier-\")) is set up in the buffer of origin."))
+((\"x-\" . \"xavier-\")) is set up in the buffer of origin.")
+    (regexp
+     completion-regexp-try-completion completion-regexp-all-completions
+     "Regular expression matching."))
   "List of available completion styles.
 Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS DOC):
 where NAME is the name that should be used in `completion-styles',
@@ -2589,6 +2592,14 @@ See also the face `completions-common-part'.")
   "Face for the parts of completions which matched the pattern.
 See also the face `completions-first-difference'.")
 
+(defface completions-regexp-match-1
+  '((t :foreground "red"))
+  "Face for first submatch of matching completions.")
+
+(defface completions-regexp-match-2
+  '((t :foreground "dark green"))
+  "Face for second submatch of matching completions.")
+
 (defun completion-hilit-commonality (completions prefix-len &optional base-size)
   "Apply font-lock highlighting to a list of completions, COMPLETIONS.
 PREFIX-LEN is an integer.  BASE-SIZE is an integer or nil (meaning zero).
@@ -4731,6 +4742,59 @@ Return the new suffix."
       (nconc (completion-pcm--hilit-commonality pattern all)
              (car bounds)))))
 
+(defun completion-regexp-try-completion (regexp table pred point)
+  "Try completing REGEXP with respect to TABLE and PRED with point at POINT."
+  (pcase (let ((completion-lazy-hilit t))
+           (completion-regexp-all-completions regexp table pred))
+    ('nil nil)
+    (`(,sole) (or (string= sole regexp) (cons sole (length sole))))
+    (_ (cons regexp point))))
+
+(defun completion-regexp-all-completions (regexp table pred &optional _point)
+  "Return all candidates in TABLE that match REGEXP and satisfy PRED."
+  (let* ((c-f-s case-fold-search)
+         (hilit-fn
+          (lambda (str)
+            (let ((case-fold-search c-f-s)) (string-match regexp str))
+            (add-face-text-property (match-beginning 0) (match-end 0)
+                                    'completions-common-part nil str)
+            (let ((i 0)
+                  (face nil))
+              (while (and
+                      (match-beginning (cl-incf i))
+                      (facep
+                       (setq face (intern-soft
+                                   (format "completions-regexp-match-%d" i)))))
+                (add-face-text-property (match-beginning i) (match-end i)
+                                        face nil str)))
+            str))
+         (comps
+          (let ((case-fold-search completion-ignore-case))
+            (condition-case nil
+                (all-completions
+                 "" table
+                 (if pred
+                     (lambda (cand &rest more)
+                       (and (apply pred cand more)
+                            (string-match-p
+                             regexp
+                             (cond
+                              ((stringp cand)              cand)
+                              ((symbolp cand) (symbol-name cand))
+                              (t              (car         cand))))))
+                   (lambda (cand &optional _)
+                     (string-match-p
+                      regexp
+                      (cond
+                       ((stringp cand)              cand)
+                       ((symbolp cand) (symbol-name cand))
+                       (t              (car         cand)))))))
+              (invalid-regexp nil)))))
+    (if completion-lazy-hilit
+        (prog1 comps (setq completion-lazy-hilit-fn hilit-fn))
+      (setq completion-lazy-hilit-fn nil)
+      (mapcar (compose hilit-fn #'copy-sequence) comps))))
+
 ;;; Partial-completion-mode style completion.
 
 (defvar completion-pcm--delim-wild-regex nil
-- 
2.39.5