[Emacs-diffs] /srv/bzr/emacs/trunk r99720: Add a new completion style `substring'.

[Stefan Monnier]

------------------------------------------------------------
revno: 99720
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Mon 2010-03-22 20:59:49 -0400
message:
  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'.
modified:
  etc/NEWS
  lisp/ChangeLog
  lisp/minibuffer.el

=== modified file 'etc/NEWS'
--- a/etc/NEWS  2010-03-20 01:29:12 +0000
+++ b/etc/NEWS  2010-03-23 00:59:49 +0000
@@ -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'

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2010-03-22 13:33:21 +0000
+++ b/lisp/ChangeLog    2010-03-23 00:59:49 +0000
@@ -1,3 +1,14 @@
+2010-03-23  Stefan Monnier  <address@hidden>
+
+       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  <address@hidden>
 
        Get rid of .elc files after removal of the corresponding .el.

=== modified file 'lisp/minibuffer.el'
--- a/lisp/minibuffer.el        2010-02-27 21:21:43 +0000
+++ b/lisp/minibuffer.el        2010-03-23 00:59:49 +0000
@@ -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)