From: Stefan Monnier Date: Tue, 10 Jun 2008 22:01:59 +0000 (+0000) Subject: (completion--merge-suffix): New function. X-Git-Tag: emacs-pretest-23.0.90~4899 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=eee6de732346d59d60a2e297851e86c05acf30d6;p=emacs.git (completion--merge-suffix): New function. (completion-basic-try-completion): Use it. (completion-pcm--find-all-completions): Add argument `filter'. (completion-pcm--filename-try-filter, completion-pcm--merge-try): New funs. (completion-pcm-try-completion): Use them. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 9df575e34bf..20782cbd7aa 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,12 @@ 2008-06-10 Stefan Monnier + * minibuffer.el (completion--merge-suffix): New function. + (completion-basic-try-completion): Use it. + (completion-pcm--find-all-completions): Add argument `filter'. + (completion-pcm--filename-try-filter, completion-pcm--merge-try): + New functions. + (completion-pcm-try-completion): Use them. + * xt-mouse.el (turn-on-xterm-mouse-tracking, turn-off-xterm-mouse-tracking): Use terminal-list. diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 2be39d23dde..706de22e772 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -36,10 +36,9 @@ ;;; Bugs: -;; - completion-ignored-extensions is ignored by partial-completion because -;; pcm merges the `all' output to synthesize a `try' output and -;; read-file-name-internal's `all' output doesn't obey -;; completion-ignored-extensions. +;; - completion-all-sorted-completions list all the completions, whereas +;; it should only lists the ones that `try-completion' would consider. +;; E.g. it should honor completion-ignored-extensions. ;; - choose-completion can't automatically figure out the boundaries ;; corresponding to the displayed completions. `base-size' gives the left ;; boundary, but not the righthand one. So we need to add @@ -47,10 +46,12 @@ ;;; Todo: +;; - make lisp-complete-symbol and sym-comp use it. ;; - add support for ** to pcm. ;; - Make read-file-name-predicate obsolete. ;; - Add vc-file-name-completion-table to read-file-name-internal. ;; - A feature like completing-help.el. +;; - make lisp/complete.el obsolete. ;; - Make the `hide-spaces' arg of all-completions obsolete? ;;; Code: @@ -282,8 +283,12 @@ If ARGS are provided, then pass MESSAGE through `format'." (concat " [" message "]"))) (when args (setq message (apply 'format message args))) (let ((ol (make-overlay (point-max) (point-max) nil t t)) - ;; A quit during sit-for should be (re-)read as - ;; abort-recursive-edit + ;; A quit during sit-for normally only interrupts the sit-for, + ;; but since minibuffer-message is used at the end of a command, + ;; at a time when the command has virtually finished already, a C-g + ;; should really cause an abort-recursive-edit instead (i.e. as if + ;; the C-g had been typed at top-level). Binding inhibit-quit here + ;; is an attempt to get that behavior. (inhibit-quit t)) (unwind-protect (progn @@ -570,6 +575,10 @@ input if confirmed." (when (and (stringp compl) ;; If it weren't for this piece of paranoia, I'd replace ;; the whole thing with a call to do-completion. + ;; This is important, e.g. when the current minibuffer's + ;; content is a directory which only contains a single + ;; file, so `try-completion' actually completes to + ;; that file. (= (length string) (length compl))) (goto-char end) (insert compl) @@ -1220,7 +1229,7 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list." (not (equal (if (consp name) (car name) name) except))) nil))) -;;; Old-style completion, used in Emacs-21. +;;; Old-style completion, used in Emacs-21 and Emacs-22. (defun completion-emacs21-try-completion (string table pred point) (let ((completion (try-completion string table pred))) @@ -1230,11 +1239,9 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list." (defun completion-emacs21-all-completions (string table pred point) (completion-hilit-commonality - (all-completions string table pred t) + (all-completions string table pred) (length string))) -;;; Basic completion, used in Emacs-22. - (defun completion-emacs22-try-completion (string table pred point) (let ((suffix (substring string point)) (completion (try-completion (substring string 0 point) table pred))) @@ -1257,26 +1264,36 @@ Like `internal-complete-buffer', but removes BUFFER from the completion list." (defun completion-emacs22-all-completions (string table pred point) (completion-hilit-commonality - (all-completions (substring string 0 point) table pred t) + (all-completions (substring string 0 point) table pred) point)) +;;; Basic completion. + +(defun completion--merge-suffix (completion point suffix) + "Merge end of COMPLETION with beginning of SUFFIX. +Simple generalization of the \"merge trailing /\" done in Emacs-22. +Return the new suffix." + (if (and (not (zerop (length suffix))) + (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix) + ;; Make sure we don't compress things to less + ;; than we started with. + point) + ;; Just make sure we didn't match some other \n. + (eq (match-end 1) (length completion))) + (substring suffix (- (match-end 1) (match-beginning 1))) + ;; Nothing to merge. + suffix)) + (defun completion-basic-try-completion (string table pred point) - (let ((suffix (substring string point)) - (completion (try-completion (substring string 0 point) table pred))) + (let* ((beforepoint (substring string 0 point)) + (afterpoint (substring string point)) + (completion (try-completion beforepoint table pred))) (if (not (stringp completion)) completion - ;; Merge end of completion with beginning of suffix. - ;; Simple generalization of the "merge trailing /" done in Emacs-22. - (when (and (not (zerop (length suffix))) - (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix) - ;; Make sure we don't compress things to less - ;; than we started with. - point) - ;; Just make sure we didn't match some other \n. - (eq (match-end 1) (length completion))) - (setq suffix (substring suffix (- (match-end 1) (match-beginning 1))))) - - (cons (concat completion suffix) (length completion))))) + (cons + (concat completion + (completion--merge-suffix completion point afterpoint)) + (length completion))))) (defalias 'completion-basic-all-completions 'completion-emacs22-all-completions) @@ -1417,7 +1434,13 @@ PATTERN is as returned by `completion-pcm--string->pattern'." completions) base-size)))) -(defun completion-pcm--find-all-completions (string table pred point) +(defun completion-pcm--find-all-completions (string table pred point + &optional filter) + "Find all completions for STRING at POINT in TABLE, satisfying PRED. +POINT is a position inside STRING. +FILTER is a function applied to the return value, that can be used, e.g. to +filter out additional entries (because TABLE migth not obey PRED)." + (unless filter (setq filter 'identity)) (let* ((beforepoint (substring string 0 point)) (afterpoint (substring string point)) (bounds (completion-boundaries beforepoint table pred afterpoint)) @@ -1428,7 +1451,9 @@ PATTERN is as returned by `completion-pcm--string->pattern'." (let* ((relpoint (- point (car bounds))) (pattern (completion-pcm--string->pattern string relpoint)) (all (condition-case err - (completion-pcm--all-completions prefix pattern table pred) + (funcall filter + (completion-pcm--all-completions + prefix pattern table pred)) (error (unless firsterror (setq firsterror err)) nil)))) (when (and (null all) (> (car bounds) 0) @@ -1438,7 +1463,7 @@ PATTERN is as returned by `completion-pcm--string->pattern'." (let ((substring (substring prefix 0 -1))) (destructuring-bind (subpat suball subprefix subsuffix) (completion-pcm--find-all-completions - substring table pred (length substring)) + substring table pred (length substring) filter) (let ((sep (aref prefix (1- (length prefix)))) ;; Text that goes between the new submatches and the ;; completion substring. @@ -1478,9 +1503,10 @@ PATTERN is as returned by `completion-pcm--string->pattern'." (dolist (submatch suball) (setq all (nconc (mapcar (lambda (s) (concat submatch between s)) - (completion-pcm--all-completions - (concat subprefix submatch between) - pattern table pred)) + (funcall filter + (completion-pcm--all-completions + (concat subprefix submatch between) + pattern table pred))) all))) ;; FIXME: This can come in handy for try-completion, ;; but isn't right for all-completions, since it lists @@ -1564,10 +1590,36 @@ PATTERN is as returned by `completion-pcm--string->pattern'." pattern "")) -(defun completion-pcm-try-completion (string table pred point) - (destructuring-bind (pattern all prefix suffix) - (completion-pcm--find-all-completions string table pred point) +;; We want to provide the functionality of `try', but we use `all' +;; and then merge it. In most cases, this works perfectly, but +;; if the completion table doesn't consider the same completions in +;; `try' as in `all', then we have a problem. The most common such +;; case is for filename completion where completion-ignored-extensions +;; is only obeyed by the `try' code. We paper over the difference +;; here. Note that it is not quite right either: if the completion +;; table uses completion-table-in-turn, this filtering may take place +;; too late to correctly fallback from the first to the +;; second alternative. +(defun completion-pcm--filename-try-filter (all) + "Filter to adjust `all' file completion to the behavior of `try'." (when all + (let ((try ()) + (re (concat "\\(?:\\`\\.\\.?/\\|" + (regexp-opt completion-ignored-extensions) + "\\)\\'"))) + (dolist (f all) + (unless (string-match re f) (push f try))) + (or try all)))) + + +(defun completion-pcm--merge-try (pattern all prefix suffix) + (cond + ((not (consp all)) all) + ((and (not (consp (cdr all))) ;Only one completion. + ;; Ignore completion-ignore-case here. + (equal (completion-pcm--pattern->string pattern) (car all))) + t) + (t (let* ((mergedpat (completion-pcm--merge-completions all pattern)) ;; `mergedpat' is in reverse order. Place new point (by ;; order of preference) either at the old point, or at @@ -1579,11 +1631,18 @@ PATTERN is as returned by `completion-pcm--string->pattern'." (newpos (length (completion-pcm--pattern->string pointpat))) ;; Do it afterwards because it changes `pointpat' by sideeffect. (merged (completion-pcm--pattern->string (nreverse mergedpat)))) - (if (and (> (length merged) 0) (> (length suffix) 0) - (eq (aref merged (1- (length merged))) (aref suffix 0))) - (setq suffix (substring suffix 1))) + + (setq suffix (completion--merge-suffix merged newpos suffix)) (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) +(defun completion-pcm-try-completion (string table pred point) + (destructuring-bind (pattern all prefix suffix) + (completion-pcm--find-all-completions + string table pred point + (if minibuffer-completing-file-name + 'completion-pcm--filename-try-filter)) + (completion-pcm--merge-try pattern all prefix suffix))) + (provide 'minibuffer)