changeset 105709:e044a3c6a7e6

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.
author Stefan Monnier <monnier@iro.umontreal.ca>
date Thu, 22 Oct 2009 15:17:48 +0000
parents 911f2739a953
children eb03599b0d98
files lisp/ChangeLog lisp/pcomplete.el
diffstat 2 files changed, 185 insertions(+), 136 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Thu Oct 22 09:42:22 2009 +0000
+++ b/lisp/ChangeLog	Thu Oct 22 15:17:48 2009 +0000
@@ -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.
--- a/lisp/pcomplete.el	Thu Oct 22 09:42:22 2009 +0000
+++ b/lisp/pcomplete.el	Thu Oct 22 15:17:48 2009 +0000
@@ -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 @@
 	  (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 @@
 					   '(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 @@
 	(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 @@
 
 ;;;###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 @@
 
 (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 @@
 	    (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 @@
       (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 @@
 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 @@
 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 @@
 (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 @@
 	   (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 @@
 
 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 @@
 ;; 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