Allow the use of completion-tables.

(pcomplete-std-complete): New command.
(pcomplete-dirs-or-entries): Use a single call to pcomplete-entries.
(pcomplete--here): Use a function for `form' rather than an expression,
so it can be byte-compiled.
(pcomplete-here, pcomplete-here*): Adjust accordingly.
Add edebug declaration.
(pcomplete-show-completions): Remove unused var `curbuf'.
(pcomplete-do-complete, pcomplete-stub):
Don't assume `completions' is a list of	strings any more.

2 files changed, 185 insertions, 136 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 85449aea396..845fdf11be2 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,16 @@
+2009-10-22  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * pcomplete.el: Allow the use of completion-tables.
+        (pcomplete-std-complete): New command.
+        (pcomplete-dirs-or-entries): Use a single call to pcomplete-entries.
+        (pcomplete--here): Use a function for `form' rather than an expression,
+        so it can be byte-compiled.
+        (pcomplete-here, pcomplete-here*): Adjust accordingly.
+        Add edebug declaration.
+        (pcomplete-show-completions): Remove unused var `curbuf'.
+        (pcomplete-do-complete, pcomplete-stub):
+        Don't assume `completions' is a list of strings any more.
+
 2009-10-22  Juanma Barranquero  <lekktu@gmail.com>
 
         * find-dired.el (find-name-arg): Fix typo in docstring.
diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el
index c24f3cedae5..ae2ef4b49ed 100644
--- a/lisp/pcomplete.el
+++ b/lisp/pcomplete.el
@@ -60,8 +60,9 @@
 ;;   it means no completions were available.
 ;;
 ;; @ In order to provide completions, they must throw the tag
-;;   `pcomplete-completions'.  The value must be the list of possible
-;;   completions for the final argument.
+;;   `pcomplete-completions'.  The value must be a completion table
+;;   (i.e. a table that can be passed to try-completion and friends)
+;;   for the final argument.
 ;;
 ;; @ To simplify completion function logic, the tag `pcompleted' may
 ;;   be thrown with a value of nil in order to abort the function.  It
@@ -118,7 +119,7 @@
 
 ;;; Code:
 
-(provide 'pcomplete)
+(eval-when-compile (require 'cl))
 
 (defgroup pcomplete nil
   "Programmable completion."
@@ -373,7 +374,7 @@ completion functions list (it should occur fairly early in the list)."
           (setq pcomplete-current-completions
                 (cdr pcomplete-current-completions)))
         (pcomplete-insert-entry pcomplete-last-completion-stub
-                                (car pcomplete-current-completions)
+                                (car pcomplete-current-completions)
                                 nil pcomplete-last-completion-raw))
     (setq pcomplete-current-completions nil
           pcomplete-last-completion-raw nil)
@@ -393,6 +394,41 @@ completion functions list (it should occur fairly early in the list)."
                                            '(sole shortest))
                                      pcomplete-last-completion-raw))))))
 
+(defun pcomplete-std-complete ()
+  "Provide standard completion using pcomplete's completion tables.
+Same as `pcomplete' but using the standard completion UI."
+  (interactive)
+  ;; FIXME: it fails to unquote/requote the arguments.
+  ;; FIXME: it doesn't implement paring.
+  ;; FIXME: when we bring up *Completions* we never bring it back down.
+  (catch 'pcompleted
+    (let* ((pcomplete-stub)
+           pcomplete-seen pcomplete-norm-func
+           pcomplete-args pcomplete-last pcomplete-index
+           (pcomplete-autolist pcomplete-autolist)
+           (pcomplete-suffix-list pcomplete-suffix-list)
+           ;; Apparently the vars above are global vars modified by
+           ;; side-effects, whereas pcomplete-completions is the core
+           ;; function that finds the chunk of text to complete
+           ;; (returned indirectly in pcomplete-stub) and the set of
+           ;; possible completions.
+           (completions (pcomplete-completions))
+           ;; The pcomplete code seems to presume that pcomplete-stub
+           ;; is always the text before point.
+           (ol (make-overlay (- (point) (length pcomplete-stub))
+                             (point) nil nil t))
+           (minibuffer-completion-table
+            ;; Add a space at the end of completion.  Use a terminator-regexp
+            ;; that never matches since the terminator cannot appear
+            ;; within the completion field anyway.
+            (apply-partially 'completion-table-with-terminator
+                             '(" " . "\\`a\\`") completions))
+           (minibuffer-completion-predicate nil))
+      (overlay-put ol 'field 'pcomplete)
+      (unwind-protect
+          (call-interactively 'minibuffer-complete)
+        (delete-overlay ol)))))
+
 ;;;###autoload
 (defun pcomplete-reverse ()
   "If cycling completion is in use, cycle backwards."
@@ -424,12 +460,12 @@ This will modify the current buffer."
         (pcomplete-expand-only-p t))
     (pcomplete)
     (when (and pcomplete-current-completions
-               (> (length pcomplete-current-completions) 0))
+               (> (length pcomplete-current-completions) 0)) ;??
       (delete-backward-char pcomplete-last-completion-length)
       (while pcomplete-current-completions
         (unless (pcomplete-insert-entry
                  "" (car pcomplete-current-completions) t
-                 pcomplete-last-completion-raw)
+                 pcomplete-last-completion-raw)
           (insert-and-inherit pcomplete-termination-string))
         (setq pcomplete-current-completions
               (cdr pcomplete-current-completions))))))
@@ -599,7 +635,7 @@ this is `comint-dynamic-complete-functions'."
 
 ;;;###autoload
 (defun pcomplete-shell-setup ()
-  "Setup shell-mode to use pcomplete."
+  "Setup `shell-mode' to use pcomplete."
   (pcomplete-comint-setup 'shell-dynamic-complete-functions))
 
 (declare-function comint-bol "comint" (&optional arg))
@@ -699,13 +735,15 @@ Magic characters are those in `pcomplete-arg-quote-list'."
 
 (defsubst pcomplete-dirs-or-entries (&optional regexp predicate)
   "Return either directories, or qualified entries."
-  (append (let ((pcomplete-stub pcomplete-stub))
-            (pcomplete-entries
-             regexp (or predicate
-                        (function
-                         (lambda (path)
-                           (not (file-directory-p path)))))))
-          (pcomplete-entries nil 'file-directory-p)))
+  ;; FIXME: pcomplete-entries doesn't return a list any more.
+  (pcomplete-entries
+   nil
+   (lexical-let ((re regexp)
+                 (pred predicate))
+     (lambda (f)
+       (or (file-directory-p f)
+           (and (if (not re) t (string-match re f))
+                (if (not pred) t (funcall pred f))))))))
 
 (defun pcomplete-entries (&optional regexp predicate)
   "Complete against a list of directory candidates.
@@ -873,7 +911,7 @@ See the documentation for `pcomplete-here'."
             (setq pcomplete-seen nil)
           (unless (eq paring t)
             (let ((arg (pcomplete-arg)))
-              (unless (not (stringp arg))
+              (when (stringp arg)
                 (setq pcomplete-seen
                       (cons (if paring
                                 (funcall paring arg)
@@ -891,12 +929,17 @@ See the documentation for `pcomplete-here'."
       (setq pcomplete-norm-func (or paring 'file-truename)))
     (unless form-only
       (run-hooks 'pcomplete-try-first-hook))
-    (throw 'pcomplete-completions (eval form))))
+    (throw 'pcomplete-completions
+           (if (functionp form)
+               (funcall form)
+             ;; Old calling convention, might still be used by files
+             ;; byte-compiled with the older code.
+             (eval form)))))
 
 (defmacro pcomplete-here (&optional form stub paring form-only)
   "Complete against the current argument, if at the end.
-If completion is to be done here, evaluate FORM to generate the list
-of strings which will be used for completion purposes.  If STUB is a
+If completion is to be done here, evaluate FORM to generate the completion
+table which will be used for completion purposes.  If STUB is a
 string, use it as the completion stub instead of the default (which is
 the entire text of the current argument).
 
@@ -904,7 +947,7 @@ For an example of when you might want to use STUB: if the current
 argument text is 'long-path-name/', you don't want the completions
 list display to be cluttered by 'long-path-name/' appearing at the
 beginning of every alternative.  Not only does this make things less
-intelligle, but it is also inefficient.  Yet, if the completion list
+intelligible, but it is also inefficient.  Yet, if the completion list
 does not begin with this string for every entry, the current argument
 won't complete correctly.
 
@@ -923,11 +966,14 @@ cleared.
 If FORM-ONLY is non-nil, only the result of FORM will be used to
 generate the completions list.  This means that the hook
 `pcomplete-try-first-hook' will not be run."
-  `(pcomplete--here (quote ,form) ,stub ,paring ,form-only))
+  (declare (debug t))
+  `(pcomplete--here (lambda () ,form) ,stub ,paring ,form-only))
+
 
 (defmacro pcomplete-here* (&optional form stub form-only)
   "An alternate form which does not participate in argument paring."
-  `(pcomplete-here ,form ,stub t ,form-only))
+  (declare (debug t))
+  `(pcomplete-here (lambda () ,form) ,stub t ,form-only))
 
 ;; display support
 
@@ -958,44 +1004,43 @@ generate the completions list.  This means that the hook
 (defun pcomplete-show-completions (completions)
   "List in help buffer sorted COMPLETIONS.
 Typing SPC flushes the help buffer."
-  (let* ((curbuf (current-buffer)))
-    (when pcomplete-window-restore-timer
-      (cancel-timer pcomplete-window-restore-timer)
-      (setq pcomplete-window-restore-timer nil))
-    (unless pcomplete-last-window-config
-      (setq pcomplete-last-window-config (current-window-configuration)))
-    (with-output-to-temp-buffer "*Completions*"
-      (display-completion-list completions))
-    (message "Hit space to flush")
-    (let (event)
-      (prog1
-          (catch 'done
-            (while (with-current-buffer (get-buffer "*Completions*")
-                     (setq event (pcomplete-read-event)))
-              (cond
-               ((pcomplete-event-matches-key-specifier-p event ?\s)
-                (set-window-configuration pcomplete-last-window-config)
-                (setq pcomplete-last-window-config nil)
-                (throw 'done nil))
-               ((or (pcomplete-event-matches-key-specifier-p event 'tab)
-                    ;; Needed on a terminal
-                    (pcomplete-event-matches-key-specifier-p event 9))
-                (let ((win (or (get-buffer-window "*Completions*" 0)
-                               (display-buffer "*Completions*"
-                                               'not-this-window))))
-                  (with-selected-window win
-                    (if (pos-visible-in-window-p (point-max))
-                        (goto-char (point-min))
-                      (scroll-up))))
-                (message ""))
-               (t
-                (setq unread-command-events (list event))
-                (throw 'done nil)))))
-        (if (and pcomplete-last-window-config
-                 pcomplete-restore-window-delay)
-            (setq pcomplete-window-restore-timer
-                  (run-with-timer pcomplete-restore-window-delay nil
-                                  'pcomplete-restore-windows)))))))
+  (when pcomplete-window-restore-timer
+    (cancel-timer pcomplete-window-restore-timer)
+    (setq pcomplete-window-restore-timer nil))
+  (unless pcomplete-last-window-config
+    (setq pcomplete-last-window-config (current-window-configuration)))
+  (with-output-to-temp-buffer "*Completions*"
+    (display-completion-list completions))
+  (message "Hit space to flush")
+  (let (event)
+    (prog1
+        (catch 'done
+          (while (with-current-buffer (get-buffer "*Completions*")
+                   (setq event (pcomplete-read-event)))
+            (cond
+             ((pcomplete-event-matches-key-specifier-p event ?\s)
+              (set-window-configuration pcomplete-last-window-config)
+              (setq pcomplete-last-window-config nil)
+              (throw 'done nil))
+             ((or (pcomplete-event-matches-key-specifier-p event 'tab)
+                  ;; Needed on a terminal
+                  (pcomplete-event-matches-key-specifier-p event 9))
+              (let ((win (or (get-buffer-window "*Completions*" 0)
+                             (display-buffer "*Completions*"
+                                             'not-this-window))))
+                (with-selected-window win
+                  (if (pos-visible-in-window-p (point-max))
+                      (goto-char (point-min))
+                    (scroll-up))))
+              (message ""))
+             (t
+              (setq unread-command-events (list event))
+              (throw 'done nil)))))
+      (if (and pcomplete-last-window-config
+               pcomplete-restore-window-delay)
+          (setq pcomplete-window-restore-timer
+                (run-with-timer pcomplete-restore-window-delay nil
+                                'pcomplete-restore-windows))))))
 
 ;; insert completion at point
 
@@ -1043,40 +1088,25 @@ extra checking, and munging of the COMPLETIONS list."
            (message "No completions of %s" stub)
          (message "No completions")))
     ;; pare it down, if applicable
-    (if (and pcomplete-use-paring pcomplete-seen)
-        (let* ((arg (pcomplete-arg))
-               (prefix
-                (file-name-as-directory
-                 (funcall pcomplete-norm-func
-                          (substring arg 0 (- (length arg)
-                                              (length pcomplete-stub)))))))
-          (setq pcomplete-seen
-                (mapcar 'directory-file-name pcomplete-seen))
-          (let ((p pcomplete-seen))
-            (while p
-              (add-to-list 'pcomplete-seen
-                           (funcall pcomplete-norm-func (car p)))
-              (setq p (cdr p))))
-          (setq completions
-                (mapcar
-                 (function
-                  (lambda (elem)
-                    (file-relative-name elem prefix)))
-                 (pcomplete-pare-list
-                  (mapcar
-                   (function
-                    (lambda (elem)
-                      (expand-file-name elem prefix)))
-                   completions)
-                  pcomplete-seen
-                  (function
-                   (lambda (elem)
-                     (member (directory-file-name
-                              (funcall pcomplete-norm-func elem))
-                             pcomplete-seen))))))))
+    (when (and pcomplete-use-paring pcomplete-seen)
+      (setq pcomplete-seen
+            (mapcar 'directory-file-name pcomplete-seen))
+      (dolist (p pcomplete-seen)
+        (add-to-list 'pcomplete-seen
+                     (funcall pcomplete-norm-func p)))
+      (setq completions
+            (apply-partially 'completion-table-with-predicate
+                             completions
+                             (lambda (f)
+                               (not (member
+                                     (funcall pcomplete-norm-func
+                                              (directory-file-name f))
+                                     pcomplete-seen)))
+                             'strict)))
     ;; OK, we've got a list of completions.
     (if pcomplete-show-list
-        (pcomplete-show-completions completions)
+        ;; FIXME: pay attention to boundaries.
+        (pcomplete-show-completions (all-completions stub completions))
       (pcomplete-stub stub completions))))
 
 (defun pcomplete-stub (stub candidates &optional cycle-p)
@@ -1093,43 +1123,47 @@ Returns `listed' if a completion listing was shown.
 
 See also `pcomplete-filename'."
   (let* ((completion-ignore-case pcomplete-ignore-case)
-         (candidates (mapcar 'list candidates))
-         (completions (all-completions stub candidates)))
-    (let (result entry)
-      (cond
-       ((null completions)
-        (if (and stub (> (length stub) 0))
-            (message "No completions of %s" stub)
-          (message "No completions")))
-       ((= 1 (length completions))
-        (setq entry (car completions))
-        (if (string-equal entry stub)
-            (message "Sole completion"))
-        (setq result 'sole))
-       ((and pcomplete-cycle-completions
-             (or cycle-p
-                 (not pcomplete-cycle-cutoff-length)
-                 (<= (length completions)
-                     pcomplete-cycle-cutoff-length)))
-        (setq entry (car completions)
-              pcomplete-current-completions completions))
-       (t ; There's no unique completion; use longest substring
-        (setq entry (try-completion stub candidates))
-        (cond ((and pcomplete-recexact
-                    (string-equal stub entry)
-                    (member entry completions))
-               ;; It's not unique, but user wants shortest match.
-               (message "Completed shortest")
-               (setq result 'shortest))
-              ((or pcomplete-autolist
-                   (string-equal stub entry))
-               ;; It's not unique, list possible completions.
-               (pcomplete-show-completions completions)
-               (setq result 'listed))
-              (t
-               (message "Partially completed")
-               (setq result 'partial)))))
-      (cons result entry))))
+         (completions (all-completions stub candidates))
+         (entry (try-completion stub candidates))
+         result)
+    (cond
+     ((null entry)
+      (if (and stub (> (length stub) 0))
+          (message "No completions of %s" stub)
+        (message "No completions")))
+     ((eq entry t)
+      (setq entry stub)
+      (message "Sole completion")
+      (setq result 'sole))
+     ((= 1 (length completions))
+      (setq result 'sole))
+     ((and pcomplete-cycle-completions
+           (or cycle-p
+               (not pcomplete-cycle-cutoff-length)
+               (<= (length completions)
+                   pcomplete-cycle-cutoff-length)))
+      (let ((bound (car (completion-boundaries stub candidates nil ""))))
+        (unless (zerop bound)
+          (setq completions (mapcar (lambda (c) (concat (substring stub 0 bound) c))
+                                    completions)))
+        (setq entry (car completions)
+              pcomplete-current-completions completions)))
+     ((and pcomplete-recexact
+           (string-equal stub entry)
+           (member entry completions))
+      ;; It's not unique, but user wants shortest match.
+      (message "Completed shortest")
+      (setq result 'shortest))
+     ((or pcomplete-autolist
+          (string-equal stub entry))
+      ;; It's not unique, list possible completions.
+      ;; FIXME: pay attention to boundaries.
+      (pcomplete-show-completions completions)
+      (setq result 'listed))
+     (t
+      (message "Partially completed")
+      (setq result 'partial)))
+    (cons result entry)))
 
 ;; context sensitive help
 
@@ -1194,14 +1228,16 @@ Returns the resultant list."
 ;; create a set of aliases which allow completion functions to be not
 ;; quite so verbose
 
-;; jww (1999-10-20): are these a good idea?
-; (defalias 'pc-here 'pcomplete-here)
-; (defalias 'pc-test 'pcomplete-test)
-; (defalias 'pc-opt 'pcomplete-opt)
-; (defalias 'pc-match 'pcomplete-match)
-; (defalias 'pc-match-string 'pcomplete-match-string)
-; (defalias 'pc-match-beginning 'pcomplete-match-beginning)
-; (defalias 'pc-match-end 'pcomplete-match-end)
+;;; jww (1999-10-20): are these a good idea?
+;; (defalias 'pc-here 'pcomplete-here)
+;; (defalias 'pc-test 'pcomplete-test)
+;; (defalias 'pc-opt 'pcomplete-opt)
+;; (defalias 'pc-match 'pcomplete-match)
+;; (defalias 'pc-match-string 'pcomplete-match-string)
+;; (defalias 'pc-match-beginning 'pcomplete-match-beginning)
+;; (defalias 'pc-match-end 'pcomplete-match-end)
+
+(provide 'pcomplete)
 
 ;; arch-tag: ae32ef2d-dbed-4244-8b0f-cf5a2a3b07a4
 ;;; pcomplete.el ends here