# HG changeset patch
# User Stefan Monnier <monnier@iro.umontreal.ca>
# Date 1269305989 14400
# Node ID 7cf379c501e1d090fb74f5e3742face0eac31a27
# Parent  c3852852bbc0589e664393f5d808d132dc6410aa
Add a new completion style `substring'.
* minibuffer.el (completion-basic--pattern): New function.
(completion-basic-try-completion, completion-basic-all-completions): Use it.
(completion-substring--all-completions)
(completion-substring-try-completion)
(completion-substring-all-completions): New functions.
(completion-styles-alist): New style `substring'.

diff -r c3852852bbc0 -r 7cf379c501e1 etc/NEWS
--- a/etc/NEWS	Mon Mar 22 12:51:59 2010 -0700
+++ b/etc/NEWS	Mon Mar 22 20:59:49 2010 -0400
@@ -94,6 +94,8 @@
 
 * Lisp changes in Emacs 24.1
 
+** New completion style `substring'.
+
 ** Image API
 
 *** When the image type is one of listed in `image-animated-types'
diff -r c3852852bbc0 -r 7cf379c501e1 lisp/ChangeLog
--- a/lisp/ChangeLog	Mon Mar 22 12:51:59 2010 -0700
+++ b/lisp/ChangeLog	Mon Mar 22 20:59:49 2010 -0400
@@ -1,3 +1,14 @@
+2010-03-23  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+	Add a new completion style `substring'.
+	* minibuffer.el (completion-basic--pattern): New function.
+	(completion-basic-try-completion, completion-basic-all-completions):
+	Use it.
+	(completion-substring--all-completions)
+	(completion-substring-try-completion)
+	(completion-substring-all-completions): New functions.
+	(completion-styles-alist): New style `substring'.
+
 2010-03-22  Stefan Monnier  <monnier@iro.umontreal.ca>
 
 	Get rid of .elc files after removal of the corresponding .el.
diff -r c3852852bbc0 -r 7cf379c501e1 lisp/minibuffer.el
--- a/lisp/minibuffer.el	Mon Mar 22 12:51:59 2010 -0700
+++ b/lisp/minibuffer.el	Mon Mar 22 20:59:49 2010 -0400
@@ -393,6 +393,9 @@
      "Completion of multiple words, each one taken as a prefix.
 E.g. M-x l-c-h can complete to list-command-history
 and C-x C-f /u/m/s to /usr/monnier/src.")
+    (substring
+     completion-substring-try-completion completion-substring-all-completions
+     "Completion of the string taken as a substring.")
     (initials
      completion-initials-try-completion completion-initials-all-completions
      "Completion of acronyms and initialisms.
@@ -1658,6 +1661,12 @@
     ;; Nothing to merge.
     suffix))
 
+(defun completion-basic--pattern (beforepoint afterpoint bounds)
+  (delete
+   "" (list (substring beforepoint (car bounds))
+            'point
+            (substring afterpoint 0 (cdr bounds)))))
+
 (defun completion-basic-try-completion (string table pred point)
   (let* ((beforepoint (substring string 0 point))
          (afterpoint (substring string point))
@@ -1674,10 +1683,8 @@
              (length completion))))
       (let* ((suffix (substring afterpoint (cdr bounds)))
              (prefix (substring beforepoint 0 (car bounds)))
-             (pattern (delete
-                       "" (list (substring beforepoint (car bounds))
-                                'point
-                                (substring afterpoint 0 (cdr bounds)))))
+             (pattern (completion-basic--pattern
+                       beforepoint afterpoint bounds))
              (all (completion-pcm--all-completions prefix pattern table pred)))
         (if minibuffer-completing-file-name
             (setq all (completion-pcm--filename-try-filter all)))
@@ -1687,12 +1694,8 @@
   (let* ((beforepoint (substring string 0 point))
          (afterpoint (substring string point))
          (bounds (completion-boundaries beforepoint table pred afterpoint))
-         (suffix (substring afterpoint (cdr bounds)))
          (prefix (substring beforepoint 0 (car bounds)))
-         (pattern (delete
-                   "" (list (substring beforepoint (car bounds))
-                            'point
-                            (substring afterpoint 0 (cdr bounds)))))
+         (pattern (completion-basic--pattern beforepoint afterpoint bounds))
          (all (completion-pcm--all-completions prefix pattern table pred)))
     (completion-hilit-commonality all point (car bounds))))
 
@@ -2069,7 +2072,38 @@
            'completion-pcm--filename-try-filter))
     (completion-pcm--merge-try pattern all prefix suffix)))
 
-;;; Initials completion
+;;; Substring completion
+;; Mostly derived from the code of `basic' completion.
+
+(defun completion-substring--all-completions (string table pred point)
+  (let* ((beforepoint (substring string 0 point))
+         (afterpoint (substring string point))
+         (bounds (completion-boundaries beforepoint table pred afterpoint))
+         (suffix (substring afterpoint (cdr bounds)))
+         (prefix (substring beforepoint 0 (car bounds)))
+         (basic-pattern (completion-basic--pattern
+                         beforepoint afterpoint bounds))
+         (pattern (if (not (stringp (car basic-pattern)))
+                      basic-pattern
+                    (cons 'any basic-pattern)))
+         (all (completion-pcm--all-completions prefix pattern table pred)))
+    (list all pattern prefix suffix (car bounds))))
+
+(defun completion-substring-try-completion (string table pred point)
+  (destructuring-bind (all pattern prefix suffix carbounds)
+      (completion-substring--all-completions string table pred point)
+    (if minibuffer-completing-file-name
+        (setq all (completion-pcm--filename-try-filter all)))
+    (completion-pcm--merge-try pattern all prefix suffix)))
+
+(defun completion-substring-all-completions (string table pred point)
+  (destructuring-bind (all pattern prefix suffix carbounds)
+      (completion-substring--all-completions string table pred point)
+    (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.
 
 (defun completion-initials-expand (str table pred)