3 files changed, 157 insertions, 12 deletions

diff --git a/etc/NEWS b/etc/NEWS
index 969b1cdcf5f..76078ec14fe 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -67,6 +67,9 @@ from load-path.  -Q now implies this.
 
 * Changes in Emacs 24.1
 
+** Completion in a non-minibuffer now tries to detect the end of completion
+and pops down the *Completions* buffer accordingly.
+
 ** emacsclient changes
 
 *** New emacsclient argument --parent-id ID can be used to open a
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 3c9e81f0b8a..03d1d6f5b19 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,17 @@
+2011-03-30  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * minibuffer.el (completion-table-dynamic): Optimize `boundaries'.
+        (completion-in-region-mode): New minor mode.
+        (completion-in-region): Use it.
+        (completion-in-region--data, completion-in-region-mode-map): New vars.
+        (completion-in-region--postch): New function.
+        (completion--capf-misbehave-funs, completion--capf-safe-funs):
+        New vars.
+        (completion--capf-wrapper): New function.
+        (completion-at-point): Use it to track well-behavedness of
+        hook functions.
+        (completion-help-at-point): New command.
+
 2011-03-30  Jason Merrill  <jason@redhat.com>  (tiny change)
 
         * vc/add-log.el (add-change-log-entry): Don't use whitespace
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index f1bc9f2d6d5..4aa34698809 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -173,10 +173,14 @@ that can be used as the COLLECTION argument to `try-completion' and
 `all-completions'.  See Info node `(elisp)Programmed Completion'."
   (lexical-let ((fun fun))
     (lambda (string pred action)
-      (with-current-buffer (let ((win (minibuffer-selected-window)))
-                             (if (window-live-p win) (window-buffer win)
-                               (current-buffer)))
-        (complete-with-action action (funcall fun string) string pred)))))
+      (if (eq (car-safe action) 'boundaries)
+          ;; `fun' is not supposed to return another function but a plain old
+          ;; completion table, whose boundaries are always trivial.
+          nil
+        (with-current-buffer (let ((win (minibuffer-selected-window)))
+                               (if (window-live-p win) (window-buffer win)
+                                 (current-buffer)))
+          (complete-with-action action (funcall fun string) string pred))))))
 
 (defmacro lazy-completion-table (var fun)
   "Initialize variable VAR as a lazy completion table.
@@ -240,6 +244,10 @@ in which case TERMINATOR-REGEXP is a regular expression whose submatch
 number 1 should match TERMINATOR.  This is used when there is a need to
 distinguish occurrences of the TERMINATOR strings which are really terminators
 from others (e.g. escaped)."
+  ;; FIXME: This implementation is not right since it only adds the terminator
+  ;; in try-completion, so any completion-style that builds the completion via
+  ;; all-completions won't get the terminator, and selecting an entry in
+  ;; *Completions* won't get the terminator added either.
   (cond
    ((eq (car-safe action) 'boundaries)
     (let* ((suffix (cdr action))
@@ -716,6 +724,8 @@ scroll the window of possible completions."
                                     (< (or s1 (length c1))
                                        (or s2 (length c2))))))))
           ;; Prefer recently used completions.
+          ;; FIXME: Additional sorting ideas:
+          ;; - for M-x, prefer commands that have no key binding.
           (let ((hist (symbol-value minibuffer-history-variable)))
             (setq all (sort all (lambda (c1 c2)
                                   (> (length (member c1 hist))
@@ -1008,8 +1018,8 @@ It also eliminates runs of equal strings."
                   ;; a space displayed.
                   (set-text-properties (- (point) 1) (point)
                                        ;; We can't just set tab-width, because
-                                       ;; completion-setup-function will kill all
-                                       ;; local variables :-(
+                                       ;; completion-setup-function will kill
+                                       ;; all local variables :-(
                                        `(display (space :align-to ,column)))
                   nil))))
             (if (not (consp str))
@@ -1237,6 +1247,8 @@ the ones passed to `completion-in-region'.  The functions on this hook
 are expected to perform completion on START..END using COLLECTION
 and PREDICATE, either by calling NEXT-FUN or by doing it themselves.")
 
+(defvar completion-in-region--data nil)
+
 (defun completion-in-region (start end collection &optional predicate)
   "Complete the text between START and END using COLLECTION.
 Return nil if there is no valid completion, else t.
@@ -1251,15 +1263,78 @@ Point needs to be somewhere between START and END."
           (minibuffer-completion-predicate predicate)
           (ol (make-overlay start end nil nil t)))
       (overlay-put ol 'field 'completion)
+      (completion-in-region-mode 1)
+      (setq completion-in-region--data
+            (list (current-buffer) start end collection))
       (unwind-protect
           (call-interactively 'minibuffer-complete)
         (delete-overlay ol)))))
 
+(defvar completion-in-region-mode-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map "?" 'completion-help-at-point)
+    (define-key map "\t" 'completion-at-point)
+    map)
+  "Keymap activated during `completion-in-region'.")
+
+;; It is difficult to know when to exit completion-in-region-mode (i.e. hide
+;; the *Completions*).
+;; - lisp-mode: never.
+;; - comint: only do it if you hit SPC at the right time.
+;; - pcomplete: pop it down on SPC or after some time-delay.
+;; - semantic: use a post-command-hook check similar to this one.
+(defun completion-in-region--postch ()
+  (message "completion-in-region--postch: cmd=%s" this-command)
+  (or unread-command-events ;Don't pop down the completions in the middle of
+                            ;mouse-drag-region/mouse-set-point.
+      (and completion-in-region--data
+           (and (eq (car completion-in-region--data)
+                    (current-buffer))
+                (>= (point) (nth 1 completion-in-region--data))
+                (<= (point)
+                    (save-excursion
+                      (goto-char (nth 2 completion-in-region--data))
+                      (line-end-position)))
+                (let ((comp-data (run-hook-wrapped
+                                  'completion-at-point-functions
+                                  ;; Only use the known-safe functions.
+                                  #'completion--capf-wrapper 'safe)))
+                  (eq (car comp-data)
+                      ;; We're still in the same completion field.
+                      (nth 1 completion-in-region--data)))))
+      (completion-in-region-mode -1)))
+
+;; (defalias 'completion-in-region--prech 'completion-in-region--postch)
+
+(define-minor-mode completion-in-region-mode
+  "Transient minor mode used during `completion-in-region'."
+  :global t
+  (setq completion-in-region--data nil)
+  ;; (remove-hook 'pre-command-hook #'completion-in-region--prech)
+  (remove-hook 'post-command-hook #'completion-in-region--postch)
+  (setq minor-mode-overriding-map-alist
+        (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist)
+              minor-mode-overriding-map-alist))
+  (if (null completion-in-region-mode)
+      (progn
+        (unless (equal "*Completions*" (buffer-name (window-buffer)))
+          (minibuffer-hide-completions))
+        (message "Leaving completion-in-region-mode"))
+    ;; (add-hook 'pre-command-hook #'completion-in-region--prech)
+    (add-hook 'post-command-hook #'completion-in-region--postch)
+    (push `(completion-in-region-mode . ,completion-in-region-mode-map)
+          minor-mode-overriding-map-alist)))
+
+;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it
+;; on minor-mode-overriding-map-alist instead.
+(setq minor-mode-map-alist
+      (delq (assq 'completion-in-region-mode minor-mode-map-alist)
+            minor-mode-map-alist))
+
 (defvar completion-at-point-functions '(tags-completion-at-point-function)
   "Special hook to find the completion table for the thing at point.
 Each function on this hook is called in turns without any argument and should
 return either nil to mean that it is not applicable at point,
-or t to mean that it already performed completion (discouraged),
 or a function of no argument to perform completion (discouraged),
 or a list of the form (START END COLLECTION &rest PROPS) where
  START and END delimit the entity to complete and should include point,
@@ -1269,12 +1344,34 @@ Currently supported properties are:
  `:predicate'           a predicate that completion candidates need to satisfy.
  `:annotation-function' the value to use for `completion-annotate-function'.")
 
+(defvar completion--capf-misbehave-funs nil
+  "List of functions found on `completion-at-point-functions' that misbehave.")
+(defvar completion--capf-safe-funs nil
+  "List of well-behaved functions found on `completion-at-point-functions'.")
+
+(defun completion--capf-wrapper (fun which)
+  (if (case which
+        (all t)
+        (safe (member fun completion--capf-safe-funs))
+        (optimist (not (member fun completion--capf-misbehave-funs))))
+      (let ((res (funcall fun)))
+        (cond
+         ((consp res)
+          (unless (member fun completion--capf-safe-funs)
+            (push fun completion--capf-safe-funs)))
+         ((not (or (listp res) (functionp res)))
+          (unless (member fun completion--capf-misbehave-funs)
+            (message
+             "Completion function %S uses a deprecated calling convention" fun)
+            (push fun completion--capf-misbehave-funs))))
+        res)))
+
 (defun completion-at-point ()
   "Perform completion on the text around point.
 The completion method is determined by `completion-at-point-functions'."
   (interactive)
-  (let ((res (run-hook-with-args-until-success
-              'completion-at-point-functions)))
+  (let ((res (run-hook-wrapped 'completion-at-point-functions
+                               #'completion--capf-wrapper 'all)))
     (cond
      ((functionp res) (funcall res))
      ((consp res)
@@ -1288,6 +1385,37 @@ The completion method is determined by `completion-at-point-functions'."
                               (plist-get plist :predicate))))
      (res))))  ;Maybe completion already happened and the function returned t.
 
+(defun completion-help-at-point ()
+  "Display the completions on the text around point.
+The completion method is determined by `completion-at-point-functions'."
+  (interactive)
+  (let ((res (run-hook-wrapped 'completion-at-point-functions
+                               ;; Ignore misbehaving functions.
+                               #'completion--capf-wrapper 'optimist)))
+    (cond
+     ((functionp res)
+      (message "Don't know how to show completions for %S" res))
+     ((consp res)
+      (let* ((plist (nthcdr 3 res))
+             (minibuffer-completion-table (nth 2 res))
+             (minibuffer-completion-predicate (plist-get plist :predicate))
+             (completion-annotate-function
+              (or (plist-get plist :annotation-function)
+                  completion-annotate-function))
+             (ol (make-overlay (nth 0 res) (nth 1 res) nil nil t)))
+        ;; FIXME: We should somehow (ab)use completion-in-region-function or
+        ;; introduce a corresponding hook (plus another for word-completion,
+        ;; and another for force-completion, maybe?).
+        (overlay-put ol 'field 'completion)
+        (unwind-protect
+            (call-interactively 'minibuffer-completion-help)
+          (delete-overlay ol))))
+     (res
+      ;; The hook function already performed completion :-(
+      ;; Not much we can do at this point.
+      nil)
+     (t (message "Nothing to complete at point")))))
+
 ;;; Key bindings.
 
 (define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map
@@ -1910,9 +2038,9 @@ or a symbol chosen among `any', `star', `point', `prefix'."
         (append (completion-pcm--string->pattern prefix)
                 '(point)
                 (completion-pcm--string->pattern suffix)))
-    (let ((pattern nil)
-          (p 0)
-          (p0 0))
+    (let* ((pattern nil)
+           (p 0)
+           (p0 p))
 
       (while (and (setq p (string-match completion-pcm--delim-wild-regex
                                         string p))