changeset 94062:9fefa536be58

* minibuffer.el (completion-all-completion-with-base-size): New var. (completion--some): New function. (completion-table-with-context, completion--file-name-table): Return the base-size if requested. (completion-table-in-turn): Generalize to multiple arguments. (complete-in-turn): Compatibility alias. (completion-styles-alist): New var. (completion-styles): New customization. (minibuffer-try-completion, minibuffer-all-completions): New functions. (minibuffer--do-completion, minibuffer-complete-and-exit) (minibuffer-try-word-completion): Use them. (display-completion-list, minibuffer-completion-help): Use them. Handle all-completions's new base-size info to set completion-base-size. * info.el (Info-read-node-name-1): Use completion-table-with-context, completion-table-with-terminator and complete-with-action. Remove the now obsolete completion-base-size-function property. * simple.el (completion-list-mode-map): Move init into declaration. (completion-list-mode): Use define-derived-mode. (completion-setup-function): Use any completion-base-size that may have been set before. Remove handling of completion-base-size-function. * loadup.el: Move abbrev.el up earlier.

--- a/etc/NEWS	Sun Apr 13 18:07:54 2008 +0000
+++ b/etc/NEWS	Sun Apr 13 22:12:02 2008 +0000
@@ -732,6 +732,13 @@
 
 * Lisp Changes in Emacs 23.1
 
+** `all-completions' may now return the base size in the last cdr.
+Since this means the returned list is not properly nil-terminated, this
+is an incompatible change and is thus enabled by the new variable
+completion-all-completions-with-base-size.
+
+** New function `apply-partially' for curried application.
+
 ** `fill-forward-paragraph-function' specifies which function the filling
 code should use to find paragraph boundaries.
 

--- a/lisp/ChangeLog	Sun Apr 13 18:07:54 2008 +0000
+++ b/lisp/ChangeLog	Sun Apr 13 22:12:02 2008 +0000
@@ -1,10 +1,35 @@
[phone]  Stefan Monnier  <[e-mail]>
+
+	* minibuffer.el (completion-all-completion-with-base-size): New var.
+	(completion--some): New function.
+	(completion-table-with-context, completion--file-name-table):
+	Return the base-size if requested.
+	(completion-table-in-turn): Generalize to multiple arguments.
+	(complete-in-turn): Compatibility alias.
+	(completion-styles-alist): New var.
+	(completion-styles): New customization.
+	(minibuffer-try-completion, minibuffer-all-completions):
+	New functions.
+	(minibuffer--do-completion, minibuffer-complete-and-exit)
+	(minibuffer-try-word-completion): Use them.
+	(display-completion-list, minibuffer-completion-help): Use them.
+	Handle all-completions's new base-size info to set completion-base-size.
+	* info.el (Info-read-node-name-1): Use completion-table-with-context,
+	completion-table-with-terminator and complete-with-action.
+	Remove the now obsolete completion-base-size-function property.
+	* simple.el (completion-list-mode-map): Move init into declaration.
+	(completion-list-mode): Use define-derived-mode.
+	(completion-setup-function): Use any completion-base-size that may
+	have been set before.  Remove handling of completion-base-size-function.
+	* loadup.el: Move abbrev.el up earlier.
+
 2008-04-13  Alexandre Julliard  <[e-mail]>
 
 	* vc-git.el (vc-git-after-dir-status-stage)
 	(vc-git-dir-status-goto-stage): New functions.
 	(vc-git-after-dir-status-stage1)
 	(vc-git-after-dir-status-stage1-empty-db)
-	(vc-git-after-dir-status-stage2): Removed, functionality moved
+	(vc-git-after-dir-status-stage2): Remove, functionality moved
 	into the new generic stage functions.
 	(vc-git-dir-status-files): New function.
 

--- a/lisp/info.el	Sun Apr 13 18:07:54 2008 +0000
+++ b/lisp/info.el	Sun Apr 13 22:12:02 2008 +0000
@@ -1513,20 +1513,15 @@
   (cond
    ;; First complete embedded file names.
    ((string-match "\\`([^)]*\\'" string)
-    (let ((file (substring string 1)))
-      (cond
-       ((eq code nil)
-	(let ((comp (try-completion file 'Info-read-node-name-2
-				    (cons Info-directory-list
-					  (mapcar 'car Info-suffix-list)))))
-	  (cond
-	   ((eq comp t) (concat string ")"))
-	   (comp (concat "(" comp)))))
-       ((eq code t)
-	(all-completions file 'Info-read-node-name-2
-			 (cons Info-directory-list
-			       (mapcar 'car Info-suffix-list))))
-       (t nil))))
+    (completion-table-with-context
+     "("
+     (apply-partially 'completion-table-with-terminator
+                      ")" 'Info-read-node-name-2)
+     (substring string 1)
+     (cons Info-directory-list
+           (mapcar 'car Info-suffix-list))
+     code))
+
    ;; If a file name was given, then any node is fair game.
    ((string-match "\\`(" string)
     (cond
@@ -1534,21 +1529,11 @@
      ((eq code t) nil)
      (t t)))
    ;; Otherwise use Info-read-node-completion-table.
-   ((eq code nil)
-    (try-completion string Info-read-node-completion-table predicate))
-   ((eq code t)
-    (all-completions string Info-read-node-completion-table predicate))
-   (t
-    (test-completion string Info-read-node-completion-table predicate))))
+   (t (complete-with-action
+       code Info-read-node-completion-table string predicate))))
 
 ;; Arrange to highlight the proper letters in the completion list buffer.
-(put 'Info-read-node-name-1 'completion-base-size-function
-     (lambda ()
-       (if (string-match "\\`([^)]*\\'"
-			 (or completion-common-substring
-			     (minibuffer-completion-contents)))
-	   1
-	 0)))
+
 
 (defun Info-read-node-name (prompt)
   (let* ((completion-ignore-case t)

--- a/lisp/loadup.el	Sun Apr 13 18:07:54 2008 +0000
+++ b/lisp/loadup.el	Sun Apr 13 22:12:02 2008 +0000
@@ -89,6 +89,7 @@
   (file-error (load "ldefs-boot.el")))
 
 (message "%s" (garbage-collect))
+(load "abbrev")         ;lisp-mode.el and simple.el use define-abbrev-table.
 (load "simple")
 
 (load "help")
@@ -160,7 +161,6 @@
 (load "textmodes/page")
 (load "register")
 (load "textmodes/paragraphs")
-(load "abbrev")                      ;lisp-mode.el uses define-abbrev-table.
 (load "emacs-lisp/lisp-mode")
 (load "textmodes/text-mode")
 (load "textmodes/fill")

--- a/lisp/minibuffer.el	Sun Apr 13 18:07:54 2008 +0000
+++ b/lisp/minibuffer.el	Sun Apr 13 22:12:02 2008 +0000
@@ -24,6 +24,9 @@
 ;; Names starting with "minibuffer--" are for functions and variables that
 ;; are meant to be for internal use only.
 
+;; TODO:
+;; - make the `hide-spaces' arg of all-completions obsolete.
+
 ;; BUGS:
 ;; - envvar completion for file names breaks completion-base-size.
 
@@ -31,9 +34,27 @@
 
 (eval-when-compile (require 'cl))
 
+(defvar completion-all-completions-with-base-size nil
+  "If non-nil, `all-completions' may return the base-size in the last cdr.
+The base-size is the length of the prefix that is elided from each
+element in the returned list of completions.  See `completion-base-size'.")
+
 ;;; Completion table manipulation
 
+(defun completion--some (fun xs)
+  "Apply FUN to each element of XS in turn.
+Return the first non-nil returned value.
+Like CL's `some'."
+  (let (res)
+    (while (and (not res) xs)
+      (setq res (funcall fun (pop xs))))
+    res))
+
 (defun apply-partially (fun &rest args)
+  "Do a \"curried\" partial application of FUN to ARGS.
+ARGS is a list of the first N arguments to pass to FUN.
+The result is a new function that takes the remaining arguments,
+and calls FUN."
   (lexical-let ((fun fun) (args1 args))
     (lambda (&rest args2) (apply fun (append args1 args2)))))
 
@@ -90,14 +111,23 @@
 
 (defun completion-table-with-context (prefix table string pred action)
   ;; TODO: add `suffix', and think about how we should support `pred'.
-  ;; Notice that `pred' is not a predicate when called from read-file-name.
+  ;; Notice that `pred' is not a predicate when called from read-file-name
+  ;; or Info-read-node-name-2.
   ;; (if pred (setq pred (lexical-let ((pred pred))
   ;;                       ;; FIXME: this doesn't work if `table' is an obarray.
   ;;                       (lambda (s) (funcall pred (concat prefix s))))))
-  (let ((comp (complete-with-action action table string nil))) ;; pred
-    (if (stringp comp)
-        (concat prefix comp)
-      comp)))
+  (let ((comp (complete-with-action action table string pred)))
+    (cond
+     ;; In case of try-completion, add the prefix.
+     ((stringp comp) (concat prefix comp))
+     ;; In case of non-empty all-completions,
+     ;; add the prefix size to the base-size.
+     ((consp comp)
+      (let ((last (last comp)))
+        (when completion-all-completions-with-base-size
+          (setcdr last (+ (or (cdr last) 0) (length prefix))))
+        comp))
+     (t comp))))
 
 (defun completion-table-with-terminator (terminator table string pred action)
   (let ((comp (complete-with-action action table string pred)))
@@ -110,13 +140,17 @@
             comp))
       comp)))
 
-(defun completion-table-in-turn (a b)
-  "Create a completion table that first tries completion in A and then in B.
-A and B should not be costly (or side-effecting) expressions."
-  (lexical-let ((a a) (b b))
+(defun completion-table-in-turn (&rest tables)
+  "Create a completion table that tries each table in TABLES in turn."
+  (lexical-let ((tables tables))
     (lambda (string pred action)
-      (or (complete-with-action action a string pred)
-          (complete-with-action action b string pred)))))
+      (completion--some (lambda (table)
+                          (complete-with-action action table string pred))
+                        tables))))
+
+(defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
+(define-obsolete-function-alias
+  'complete-in-turn 'completion-table-in-turn "23.1")
 
 ;;; Minibuffer completion
 
@@ -162,6 +196,41 @@
   :type '(choice (const nil) (const t) (const lazy))
   :group 'minibuffer)
 
+(defvar completion-styles-alist
+  '((basic try-completion all-completions)
+    ;; (partial-completion
+    ;;  completion-pcm--try-completion completion-pcm--all-completions)
+    )
+  "List of available completion styles.
+Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS)
+where NAME is the name that should be used in `completion-styles'
+TRY-COMPLETION is the function that does the completion, and
+ALL-COMPLETIONS is the function that lists the completions.")
+
+(defcustom completion-styles '(basic)
+  "List of completion styles to use."
+  :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x)))
+                                   completion-styles-alist)))
+  :group 'minibuffer
+  :version "23.1")
+
+(defun minibuffer-try-completion (string table pred)
+  (if (and (symbolp table) (get table 'no-completion-styles))
+      (try-completion string table pred)
+    (completion--some (lambda (style)
+                        (funcall (intern (concat style "try-completion"))
+                                 string table pred))
+                      completion-styles)))
+
+(defun minibuffer-all-completions (string table pred &optional hide-spaces)
+  (let ((completion-all-completions-with-base-size t))
+    (if (and (symbolp table) (get table 'no-completion-styles))
+        (all-completions string table pred hide-spaces)
+      (completion--some (lambda (style)
+                          (funcall (intern (concat style "all-completions"))
+                                   string table pred hide-spaces))
+                        completion-styles))))
+
 (defun minibuffer--bitset (modified completions exact)
   (logior (if modified    4 0)
           (if completions 2 0)
@@ -184,7 +253,8 @@
  111  7 completed to an exact completion"
   (let* ((beg (field-beginning))
          (string (buffer-substring beg (point)))
-         (completion (funcall (or try-completion-function 'try-completion)
+         (completion (funcall (or try-completion-function
+                                  'minibuffer-try-completion)
                               string
                               minibuffer-completion-table
                               minibuffer-completion-predicate)))
@@ -290,9 +360,10 @@
     (when completion-ignore-case
       ;; Fixup case of the field, if necessary.
       (let* ((string (field-string))
-	     (compl (try-completion string
-				    minibuffer-completion-table
-				    minibuffer-completion-predicate)))
+	     (compl (minibuffer-try-completion
+                     string
+                     minibuffer-completion-table
+                     minibuffer-completion-predicate)))
 	(when (and (stringp compl)
                    ;; If it weren't for this piece of paranoia, I'd replace
                    ;; the whole thing with a call to complete-do-completion.
@@ -325,7 +396,7 @@
       (t nil)))))
 
 (defun minibuffer-try-word-completion (string table predicate)
-  (let ((completion (try-completion string table predicate)))
+  (let ((completion (minibuffer-try-completion string table predicate)))
     (if (not (stringp completion))
         completion
 
@@ -369,8 +440,8 @@
         (let ((exts '(" " "-"))
               tem)
           (while (and exts (not (stringp tem)))
-            (setq tem (try-completion (concat string (pop exts))
-                                      table predicate)))
+            (setq tem (minibuffer-try-completion (concat string (pop exts))
+                                                 table predicate)))
           (if (stringp tem) (setq completion tem))))
 
       ;; Otherwise cut after the first word.
@@ -492,7 +563,12 @@
 	  (insert "There are no possible completions of what you have typed.")
 
 	(insert "Possible completions are:\n")
+        (let ((last (last completions)))
+          ;; Get the base-size from the tail of the list.
+          (set (make-local-variable 'completion-base-size) (or (cdr last) 0))
+          (setcdr last nil)) ;Make completions a properly nil-terminated list.
 	(minibuffer--insert-strings completions))))
+
   (let ((completion-common-substring common-substring))
     (run-hooks 'completion-setup-hook))
   nil)
@@ -502,16 +578,23 @@
   (interactive)
   (message "Making completion list...")
   (let* ((string (field-string))
-         (completions (all-completions
+         (completions (minibuffer-all-completions
                        string
                        minibuffer-completion-table
                        minibuffer-completion-predicate
                        t)))
     (message nil)
     (if (and completions
-             (or (cdr completions) (not (equal (car completions) string))))
+             (or (consp (cdr completions))
+                 (not (equal (car completions) string))))
         (with-output-to-temp-buffer "*Completions*"
-          (display-completion-list (sort completions 'string-lessp)))
+          (let* ((last (last completions))
+                 (base-size (cdr last)))
+            ;; Remove the base-size tail because `sort' requires a properly
+            ;; nil-terminated list.
+            (when last (setcdr last nil))
+            (display-completion-list (nconc (sort completions 'string-lessp)
+                                            base-size))))
 
       ;; If there are no completions, or if the current input is already the
       ;; only possible completion, then hide (previous&stale) completions.
@@ -597,9 +680,13 @@
               str))))
 
        ((eq action t)
-        (let ((all (file-name-all-completions name realdir)))
-          (if (memq read-file-name-predicate '(nil file-exists-p))
-              all
+        (let ((all (file-name-all-completions name realdir))
+              ;; Actually, this is not always right in the presence of
+              ;; envvars, but there's not much we can do, I think.
+              (base-size (length (file-name-directory string))))
+
+          ;; Check the predicate, if necessary.
+          (unless (memq read-file-name-predicate '(nil file-exists-p))
             (let ((comp ())
                   (pred
                    (if (eq read-file-name-predicate 'file-directory-p)
@@ -613,7 +700,10 @@
               (let ((default-directory realdir))
                 (dolist (tem all)
                   (if (funcall pred tem) (push tem comp))))
-              (nreverse comp)))))
+              (setq all (nreverse comp))))
+
+          ;; Add base-size, but only if the list is non-empty.
+          (if (consp all) (nconc all base-size))))
 
        (t
         ;; Only other case actually used is ACTION = lambda.

--- a/lisp/simple.el	Sun Apr 13 18:07:54 2008 +0000
+++ b/lisp/simple.el	Sun Apr 13 22:12:02 2008 +0000
@@ -5234,18 +5234,17 @@
 
 ;; Define the major mode for lists of completions.
 
-(defvar completion-list-mode-map nil
+(defvar completion-list-mode-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map [mouse-2] 'mouse-choose-completion)
+    (define-key map [follow-link] 'mouse-face)
+    (define-key map [down-mouse-2] nil)
+    (define-key map "\C-m" 'choose-completion)
+    (define-key map "\e\e\e" 'delete-completion-window)
+    (define-key map [left] 'previous-completion)
+    (define-key map [right] 'next-completion)
+    map)
   "Local map for completion list buffers.")
-(or completion-list-mode-map
-    (let ((map (make-sparse-keymap)))
-      (define-key map [mouse-2] 'mouse-choose-completion)
-      (define-key map [follow-link] 'mouse-face)
-      (define-key map [down-mouse-2] nil)
-      (define-key map "\C-m" 'choose-completion)
-      (define-key map "\e\e\e" 'delete-completion-window)
-      (define-key map [left] 'previous-completion)
-      (define-key map [right] 'next-completion)
-      (setq completion-list-mode-map map)))
 
 ;; Completion mode is suitable only for specially formatted data.
 (put 'completion-list-mode 'mode-class 'special)
@@ -5425,7 +5424,7 @@
 		     (raise-frame (window-frame mini))))
 	       (exit-minibuffer)))))))
 
-(defun completion-list-mode ()
+(define-derived-mode completion-list-mode nil "Completion List"
   "Major mode for buffers showing lists of possible completions.
 Type \\<completion-list-mode-map>\\[choose-completion] in the completion list\
  to select the completion near point.
@@ -5433,15 +5432,7 @@
  with the mouse.
 
 \\{completion-list-mode-map}"
-
-  (interactive)
-  (kill-all-local-variables)
-  (use-local-map completion-list-mode-map)
-  (setq mode-name "Completion List")
-  (setq major-mode 'completion-list-mode)
-  (make-local-variable 'completion-base-size)
-  (setq completion-base-size nil)
-  (run-mode-hooks 'completion-list-mode-hook))
+  (set (make-local-variable 'completion-base-size) nil))
 
 (defun completion-list-mode-finish ()
   "Finish setup of the completions buffer.
@@ -5502,27 +5493,25 @@
 	  (setq default-directory
                 (file-name-directory (expand-file-name mbuf-contents)))))
     (with-current-buffer standard-output
-      (completion-list-mode)
+      (let ((base-size completion-base-size)) ;Read before killing localvars.
+        (completion-list-mode)
+        (set (make-local-variable 'completion-base-size) base-size))
       (set (make-local-variable 'completion-reference-buffer) mainbuf)
-      (setq completion-base-size
-	    (cond
-	     ((and (symbolp minibuffer-completion-table)
-		   (get minibuffer-completion-table 'completion-base-size-function))
-	      ;; To compute base size, a function can use the global value of
-	      ;; completion-common-substring or minibuffer-completion-contents.
-	      (with-current-buffer mainbuf
-		(funcall (get minibuffer-completion-table
-			      'completion-base-size-function))))
-	     (minibuffer-completing-file-name
-	      ;; For file name completion, use the number of chars before
-	      ;; the start of the file name component at point.
-	      (with-current-buffer mainbuf
-		(save-excursion
-		  (skip-chars-backward completion-root-regexp)
-		  (- (point) (minibuffer-prompt-end)))))
-	     (minibuffer-completing-symbol nil)
-	     ;; Otherwise, in minibuffer, the base size is 0.
-	     ((minibufferp mainbuf) 0)))
+      (unless completion-base-size
+        ;; This may be needed for old completion packages which don't use
+        ;; completion-all-completions-with-base-size yet.
+        (setq completion-base-size
+              (cond
+               (minibuffer-completing-file-name
+                ;; For file name completion, use the number of chars before
+                ;; the start of the file name component at point.
+                (with-current-buffer mainbuf
+                  (save-excursion
+                    (skip-chars-backward completion-root-regexp)
+                    (- (point) (minibuffer-prompt-end)))))
+               (minibuffer-completing-symbol nil)
+               ;; Otherwise, in minibuffer, the base size is 0.
+               ((minibufferp mainbuf) 0))))
       (setq common-string-length
 	    (cond
 	     (completion-common-substring