[Emacs-diffs] /srv/bzr/emacs/trunk r103960: * lisp/comint.el: Use lexical-binding. Use std completion UI. Require CL.

[Stefan Monnier]

------------------------------------------------------------
revno: 103960
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Wed 2011-04-20 16:05:50 -0300
message:
  * lisp/comint.el: Use lexical-binding.  Use std completion UI.  Require CL.
  (comint-dynamic-complete-functions): Use comint-filename-completion.
  (comint-completion-addsuffix): Tweak custom type.
  (comint-filename-completion, comint--common-suffix)
  (comint--common-quoted-suffix, comint--table-subvert)
  (comint--complete-file-name-data): New functions.
  (comint-dynamic-complete-as-filename, comint-dynamic-complete-filename)
  (comint-dynamic-list-filename-completions): Use them.
  (comint-dynamic-simple-complete): Make obsolete.
  * lisp/minibuffer.el (completion-in-region-mode):
  Keep completion-in-region-mode--predicate global.
  (completion-in-region--postch):
  Assume completion-in-region-mode--predicate is not null.
modified:
  lisp/ChangeLog
  lisp/comint.el
  lisp/minibuffer.el

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2011-04-20 18:08:21 +0000
+++ b/lisp/ChangeLog    2011-04-20 19:05:50 +0000
@@ -1,5 +1,19 @@
 2011-04-20  Stefan Monnier  <address@hidden>
 
+       * comint.el: Use lexical-binding.  Require CL.
+       (comint-dynamic-complete-functions): Use comint-filename-completion.
+       (comint-completion-addsuffix): Tweak custom type.
+       (comint-filename-completion, comint--common-suffix)
+       (comint--common-quoted-suffix, comint--table-subvert)
+       (comint--complete-file-name-data): New functions.
+       (comint-dynamic-complete-as-filename, comint-dynamic-complete-filename)
+       (comint-dynamic-list-filename-completions): Use them.
+       (comint-dynamic-simple-complete): Make obsolete.
+       * minibuffer.el (completion-in-region-mode):
+       Keep completion-in-region-mode--predicate global.
+       (completion-in-region--postch):
+       Assume completion-in-region-mode--predicate is not null.
+
        * progmodes/flymake.el (flymake-start-syntax-check-process):
        Obey `dir'.  Simplify.
 

=== modified file 'lisp/comint.el'
--- a/lisp/comint.el    2011-04-19 13:44:55 +0000
+++ b/lisp/comint.el    2011-04-20 19:05:50 +0000
@@ -1,4 +1,4 @@
-;;; comint.el --- general command interpreter in a window stuff
+;;; comint.el --- general command interpreter in a window stuff -*- 
lexical-binding: t -*-
 
 ;; Copyright (C) 1988, 1990, 1992-2011  Free Software Foundation, Inc.
 
@@ -101,6 +101,7 @@
 
 ;;; Code:
 
+(eval-when-compile (require 'cl))
 (require 'ring)
 
 ;; Buffer Local Variables:
@@ -366,7 +367,7 @@
 `comint-use-prompt-regexp'.")
 
 (defvar comint-dynamic-complete-functions
-  '(comint-replace-by-expanded-history comint-dynamic-complete-filename)
+  '(comint-replace-by-expanded-history comint-filename-completion)
   "List of functions called to perform completion.
 Works like `completion-at-point-functions'.
 See also `comint-dynamic-complete'.
@@ -2831,10 +2832,9 @@
 ;; comint-dynamic-list-filename-completions List completions in help buffer.
 ;; comint-replace-by-expanded-filename Expand and complete filename at point;
 ;;                                     replace with expanded/completed name.
-;; comint-dynamic-simple-complete      Complete stub given candidates.
 
-;; These are not installed in the comint-mode keymap. But they are
-;; available for people who want them. Shell-mode installs them:
+;; These are not installed in the comint-mode keymap.  But they are
+;; available for people who want them.  Shell-mode installs them:
 ;; (define-key shell-mode-map "\t" 'comint-dynamic-complete)
 ;; (define-key shell-mode-map "\M-?"
 ;;             'comint-dynamic-list-filename-completions)))
@@ -2849,14 +2849,16 @@
   :group 'comint-completion)
 
 (defcustom comint-completion-addsuffix t
-  "If non-nil, add a `/' to completed directories, ` ' to file names.
-If a cons pair, it should be of the form (DIRSUFFIX . FILESUFFIX) where
-DIRSUFFIX and FILESUFFIX are strings added on unambiguous or exact completion.
+  "If non-nil, add ` ' to file names.
+It can either be a string FILESUFFIX or a cons (DIRSUFFIX . FILESUFFIX)
+where DIRSUFFIX is ignored and FILESUFFIX is a string added on unambiguous
+or exact completion.
 This mirrors the optional behavior of tcsh."
   :type '(choice (const :tag "None" nil)
-                (const :tag "Add /" t)
-                (cons :tag "Suffix pair"
-                      (string :tag "Directory suffix")
+                (const :tag "Add SPC" t)
+                 (string :tag "File suffix")
+                (cons :tag "Obsolete suffix pair"
+                      (string :tag "Ignored")
                       (string :tag "File suffix")))
   :group 'comint-completion)
 
@@ -3016,73 +3018,125 @@
   (when (comint--match-partial-filename)
     (unless (window-minibuffer-p (selected-window))
       (message "Completing file name..."))
-    (comint-dynamic-complete-as-filename)))
-
-(defun comint-dynamic-complete-as-filename ()
-  "Dynamically complete at point as a filename.
-See `comint-dynamic-complete-filename'.  Returns t if successful."
-  (let* ((completion-ignore-case read-file-name-completion-ignore-case)
-        (completion-ignored-extensions comint-completion-fignore)
-        ;; If we bind this, it breaks remote directory tracking in rlogin.el.
-        ;; I think it was originally bound to solve file completion problems,
-        ;; but subsequent changes may have made this unnecessary.  sm.
-        ;;(file-name-handler-alist nil)
-        (minibuffer-p (window-minibuffer-p (selected-window)))
-        (success t)
-        (dirsuffix (cond ((not comint-completion-addsuffix) "")
-                         ((not (consp comint-completion-addsuffix)) "/")
-                         (t (car comint-completion-addsuffix))))
-        (filesuffix (cond ((not comint-completion-addsuffix) "")
+    (apply #'completion-in-region (comint--complete-file-name-data))))
+
+(defun comint-filename-completion ()
+  "Return completion data for filename at point, if any."
+  (when (comint--match-partial-filename)
+    (comint--complete-file-name-data)))
+
+;; FIXME: comint--common-suffix, comint--common-quoted-suffix, and
+;; comint--table-subvert copied from pcomplete.  And they don't fully solve
+;; the problem, since selecting a file from *Completions* won't quote it.
+
+(defun comint--common-suffix (s1 s2)
+  (assert (not (or (string-match "\n" s1) (string-match "\n" s2))))
+  ;; Since S2 is expected to be the "unquoted/expanded" version of S1,
+  ;; there shouldn't be any case difference, even if the completion is
+  ;; case-insensitive.
+  (let ((case-fold-search nil))
+    (string-match ".*?\\(.*\\)\n.*\\1\\'" (concat s1 "\n" s2))
+    (- (match-end 1) (match-beginning 1))))
+
+(defun comint--common-quoted-suffix (s1 s2)
+  "Find the common suffix between S1 and S2 where S1 is the expanded S2.
+S1 is expected to be the unquoted and expanded version of S1.
+Returns (PS1 . PS2), i.e. the shortest prefixes of S1 and S2, such that
+S1 = (concat PS1 SS1) and S2 = (concat PS2 SS2) and
+SS1 = (unquote SS2)."
+  (let* ((cs (comint--common-suffix s1 s2))
+         (ss1 (substring s1 (- (length s1) cs)))
+         (qss1 (comint-quote-filename ss1))
+         qc)
+    (if (and (not (equal ss1 qss1))
+             (setq qc (comint-quote-filename (substring ss1 0 1)))
+             (eq t (compare-strings s2 (- (length s2) cs (length qc) -1)
+                                    (- (length s2) cs -1)
+                                    qc nil nil)))
+        ;; The difference found is just that one char is quoted in S2
+        ;; but not in S1, keep looking before this difference.
+        (comint--common-quoted-suffix
+         (substring s1 0 (- (length s1) cs))
+         (substring s2 0 (- (length s2) cs (length qc) -1)))
+      (cons (substring s1 0 (- (length s1) cs))
+            (substring s2 0 (- (length s2) cs))))))
+
+(defun comint--table-subvert (table s1 s2 string pred action)
+  "Completion table that replaces the prefix S1 with S2 in STRING.
+When TABLE, S1 and S2 are provided by `apply-partially', the result
+is a completion table which completes strings of the form (concat S1 S)
+in the same way as TABLE completes strings of the form (concat S2 S)."
+  (let* ((str (if (eq t (compare-strings string 0 (length s1) s1 nil nil
+                                         completion-ignore-case))
+                  (concat s2 (comint-unquote-filename
+                              (substring string (length s1))))))
+         (res (if str (complete-with-action action table str pred))))
+    (when res
+      (cond
+       ((and (eq (car-safe action) 'boundaries))
+        (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0)))
+          (list* 'boundaries
+                 (max (length s1)
+                      ;; FIXME: Adjust because of quoting/unquoting.
+                      (+ beg (- (length s1) (length s2))))
+                 (and (eq (car-safe res) 'boundaries) (cddr res)))))
+       ((stringp res)
+        (if (eq t (compare-strings res 0 (length s2) s2 nil nil
+                                   completion-ignore-case))
+            (concat s1 (comint-quote-filename
+                        (substring res (length s2))))))
+       ((eq action t)
+        (let ((bounds (completion-boundaries str table pred "")))
+          (if (>= (car bounds) (length s2))
+              res
+            (let ((re (concat "\\`"
+                              (regexp-quote (substring s2 (car bounds))))))
+              (delq nil
+                    (mapcar (lambda (c)
+                              (if (string-match re c)
+                                  (substring c (match-end 0))))
+                            res))))))
+       ;; E.g. action=nil and it's the only completion.
+       (res)))))
+
+(defun comint--complete-file-name-data ()
+  "Return the completion data for file name at point."
+  (let* ((filesuffix (cond ((not comint-completion-addsuffix) "")
+                          ((stringp comint-completion-addsuffix)
+                            comint-completion-addsuffix)
                           ((not (consp comint-completion-addsuffix)) " ")
                           (t (cdr comint-completion-addsuffix))))
-        (filename (comint-match-partial-filename))
+        (filename (comint--match-partial-filename))
         (filename-beg (if filename (match-beginning 0) (point)))
         (filename-end (if filename (match-end 0) (point)))
-        (filename (or filename ""))
-        (filedir (file-name-directory filename))
-        (filenondir (file-name-nondirectory filename))
-        (directory (if filedir (comint-directory filedir) default-directory))
-        (completion (file-name-completion filenondir directory)))
-    (cond ((null completion)
-          (if minibuffer-p
-              (minibuffer-message "No completions of %s" filename)
-            (message "No completions of %s" filename))
-          (setq success nil))
-         ((eq completion t)            ; Means already completed "file".
-          (insert filesuffix)
-          (unless minibuffer-p
-            (message "Sole completion")))
-         ((string-equal completion "") ; Means completion on "directory/".
-          (comint-dynamic-list-filename-completions))
-         (t                            ; Completion string returned.
-          (let ((file (concat (file-name-as-directory directory) completion)))
-            ;; Insert completion.  Note that the completion string
-            ;; may have a different case than what's in the prompt,
-            ;; if read-file-name-completion-ignore-case is non-nil,
-            (delete-region filename-beg filename-end)
-            (if filedir (insert (comint-quote-filename filedir)))
-            (insert (comint-quote-filename (directory-file-name completion)))
-            (cond ((symbolp (file-name-completion completion directory))
-                   ;; We inserted a unique completion.
-                   (insert (if (file-directory-p file) dirsuffix filesuffix))
-                   (unless minibuffer-p
-                     (message "Completed")))
-                  ((and comint-completion-recexact comint-completion-addsuffix
-                        (string-equal filenondir completion)
-                        (file-exists-p file))
-                   ;; It's not unique, but user wants shortest match.
-                   (insert (if (file-directory-p file) dirsuffix filesuffix))
-                   (unless minibuffer-p
-                     (message "Completed shortest")))
-                  ((or comint-completion-autolist
-                       (string-equal filenondir completion))
-                   ;; It's not unique, list possible completions.
-                   (comint-dynamic-list-filename-completions))
-                  (t
-                   (unless minibuffer-p
-                     (message "Partially completed")))))))
-    success))
+         (unquoted (if filename (comint--unquote&expand-filename filename) ""))
+         (table
+          (let ((prefixes (comint--common-quoted-suffix
+                           unquoted filename)))
+            (apply-partially
+             #'comint--table-subvert
+             #'completion-file-name-table
+             (cdr prefixes) (car prefixes)))))
+    (list
+     filename-beg filename-end
+     (lambda (string pred action)
+       (let ((completion-ignore-case read-file-name-completion-ignore-case)
+             (completion-ignored-extensions comint-completion-fignore))
+         (if (zerop (length filesuffix))
+             (complete-with-action action table string pred)
+           ;; 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.
+           (completion-table-with-terminator
+            (cons filesuffix "\\`a\\`")
+            table string pred action)))))))
 
+(defun comint-dynamic-complete-as-filename ()
+  "Dynamically complete at point as a filename.
+See `comint-dynamic-complete-filename'.  Returns t if successful."
+  (apply #'completion-in-region (comint--complete-file-name-data)))
+(make-obsolete 'comint-dynamic-complete-as-filename
+               'comint-filename-completion "24.1")
 
 (defun comint-replace-by-expanded-filename ()
   "Dynamically expand and complete the filename at point.
@@ -3155,28 +3209,20 @@
                    (unless minibuffer-p
                      (message "Partially completed"))
                    'partial)))))))
+(make-obsolete 'comint-dynamic-simple-complete 'completion-in-region "24.1")
 
 
 (defun comint-dynamic-list-filename-completions ()
   "Display a list of possible completions for the filename at point."
   (interactive)
-  (let* ((completion-ignore-case read-file-name-completion-ignore-case)
-        ;; If we bind this, it breaks remote directory tracking in rlogin.el.
-        ;; I think it was originally bound to solve file completion problems,
-        ;; but subsequent changes may have made this unnecessary.  sm.
-        ;;(file-name-handler-alist nil)
-        (filename (or (comint-match-partial-filename) ""))
-        (filedir (file-name-directory filename))
-        (filenondir (file-name-nondirectory filename))
-        (directory (if filedir (comint-directory filedir) default-directory))
-        (completions (file-name-all-completions filenondir directory)))
-    (if (not completions)
-       (if (window-minibuffer-p (selected-window))
-           (minibuffer-message "No completions of %s" filename)
-         (message "No completions of %s" filename))
-      (comint-dynamic-list-completions
-       (mapcar 'comint-quote-filename completions)
-       (comint-quote-filename filenondir)))))
+  (let* ((data (comint--complete-file-name-data))
+         (minibuffer-completion-table (nth 2 data))
+         (minibuffer-completion-predicate nil)
+         (ol (make-overlay (nth 0 data) (nth 1 data) nil nil t)))
+    (overlay-put ol 'field 'completion)
+    (unwind-protect
+        (call-interactively 'minibuffer-completion-help)
+      (delete-overlay ol))))
 
 
 ;; This is bound locally in a *Completions* buffer to the list of
@@ -3244,7 +3290,6 @@
        (if (eq first ?\s)
            (set-window-configuration comint-dynamic-list-completions-config)
          (setq unread-command-events (listify-key-sequence key)))))))
-
 
 (defun comint-get-next-from-history ()
   "After fetching a line from input history, this fetches the following line.
@@ -3742,9 +3787,8 @@
 ;;
 ;; For modes that use comint-mode, comint-dynamic-complete-functions is the
 ;; hook to add completion functions to.  Functions on this list should return
-;; non-nil if completion occurs (i.e., further completion should not occur).
-;; You could use comint-dynamic-simple-complete to do the bulk of the
-;; completion job.
+;; the completion data according to the documentation of
+;; `completion-at-point-functions'
 
 
 (provide 'comint)

=== modified file 'lisp/minibuffer.el'
--- a/lisp/minibuffer.el        2011-04-14 00:16:11 +0000
+++ b/lisp/minibuffer.el        2011-04-20 19:05:50 +0000
@@ -58,6 +58,8 @@
 
 ;;; Todo:
 
+;; - Make things like icomplete-mode or lightning-completion work with
+;;   completion-in-region-mode.
 ;; - completion-insert-complete-hook (called after inserting a complete
 ;;   completion), typically used for "complete-abbrev" where it would expand
 ;;   the abbrev.  Tho we'd probably want to provide it from the
@@ -1314,8 +1316,7 @@
                     (save-excursion
                       (goto-char (nth 2 completion-in-region--data))
                       (line-end-position)))
-                (when completion-in-region-mode--predicate
-                  (funcall completion-in-region-mode--predicate))))
+               (funcall completion-in-region-mode--predicate)))
       (completion-in-region-mode -1)))
 
 ;; (defalias 'completion-in-region--prech 'completion-in-region--postch)
@@ -1330,12 +1331,12 @@
         (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist)
               minor-mode-overriding-map-alist))
   (if (null completion-in-region-mode)
-      (unless (or (equal "*Completions*" (buffer-name (window-buffer)))
-                  (null completion-in-region-mode--predicate))
+      (unless (equal "*Completions*" (buffer-name (window-buffer)))
        (minibuffer-hide-completions))
     ;; (add-hook 'pre-command-hook #'completion-in-region--prech)
-    (set (make-local-variable 'completion-in-region-mode--predicate)
-         completion-in-region-mode-predicate)
+    (assert completion-in-region-mode-predicate)
+    (setq completion-in-region-mode--predicate
+         completion-in-region-mode-predicate)
     (add-hook 'post-command-hook #'completion-in-region--postch)
     (push `(completion-in-region-mode . ,completion-in-region-mode-map)
           minor-mode-overriding-map-alist)))