;; internal use only.
;; Functional completion tables have an extended calling conventions:
-;; - If completion-all-completions-with-base-size is set, then all-completions
-;; should return the base-size in the last cdr.
;; - The `action' can be (additionally to nil, t, and lambda) of the form
;; (boundaries . SUFFIX) in which case it should return
;; (boundaries START . END). See `completion-boundaries'.
;;; 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
;;; 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:
(eval-when-compile (require 'cl))
-(defvar completion-all-completions-with-base-size nil
- "If non-nil, `all-completions' may return the base-size in the last cdr.
-The base-size is the length of the prefix that is elided from each
-element in the returned list of completions. See `completion-base-size'.")
-
;;; Completion table manipulation
;; New completion-table operation.
The result is of the form (START . END) where START is the position
in STRING of the beginning of the completion field and END is the position
in SUFFIX of the end of the completion field.
-I.e. START is the same as the `completion-base-size'.
E.g. for simple completion tables, the result is always (0 . (length SUFFIX))
and for file names the result is the positions delimited by
the closest directory separators."
(or res
(if firsterror (signal (car firsterror) (cdr firsterror))))))
-(defun apply-partially (fun &rest args)
- "Do a \"curried\" partial application of FUN to ARGS.
-ARGS is a list of the first N arguments to pass to FUN.
-The result is a new function that takes the remaining arguments,
-and calls FUN."
- (lexical-let ((fun fun) (args1 args))
- (lambda (&rest args2) (apply fun (append args1 args2)))))
-
(defun complete-with-action (action table string pred)
"Perform completion ACTION.
STRING is the string to complete.
the value of its argument. If completion is performed in the minibuffer,
FUN will be called in the buffer from which the minibuffer was entered.
-The result of the `dynamic-completion-table' form is a function
+The result of the `completion-table-dynamic' form is a function
that can be used as the COLLECTION argument to `try-completion' and
`all-completions'. See Info node `(elisp)Programmed Completion'."
(lexical-let ((fun fun))
(cond
;; In case of try-completion, add the prefix.
((stringp comp) (concat prefix comp))
- ;; In case of non-empty all-completions,
- ;; add the prefix size to the base-size.
- ((consp comp)
- (let ((last (last comp)))
- (when completion-all-completions-with-base-size
- (setcdr last (+ (or (cdr last) 0) (length prefix))))
- comp))
(t comp)))))
(defun completion-table-with-terminator (terminator table string pred action)
;; consistent so pcm can merge the `all' output to get the `try' output,
;; but that sometimes clashes with the need for `all' output to look
;; good in *Completions*.
- ;; (let* ((all (all-completions string table pred))
- ;; (last (last all))
- ;; (base-size (cdr last)))
- ;; (when all
- ;; (setcdr all nil)
- ;; (nconc (mapcar (lambda (s) (concat s terminator)) all) base-size)))
+ ;; (mapcar (lambda (s) (concat s terminator))
+ ;; (all-completions string table pred))))
(all-completions string table pred))
;; completion-table-with-terminator is always used for
;; "sub-completions" so it's only called if the terminator is missing,
(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
(defun delete-minibuffer-contents ()
"Delete all user input in a minibuffer.
If the current buffer is not a minibuffer, erase its entire contents."
- (delete-field))
+ ;; We used to do `delete-field' here, but when file name shadowing
+ ;; is on, the field doesn't cover the entire minibuffer contents.
+ (delete-region (minibuffer-prompt-end) (point-max)))
(defcustom completion-auto-help t
"Non-nil means automatically provide help for invalid completion input.
POINT is the position of point within STRING.
The return value is a list of completions and may contain the base-size
in the last `cdr'."
- (let ((completion-all-completions-with-base-size t))
- ;; The property `completion-styles' indicates that this functional
- ;; completion-table claims to take care of completion styles itself.
- ;; [I.e. It will most likely call us back at some point. ]
- (if (and (symbolp table) (get table 'completion-styles))
- ;; Extended semantics for functional completion-tables:
- ;; They accept a 4th argument `point' and when called with action=t
- ;; and this 4th argument (a position inside `string'), they may
- ;; return BASE-SIZE in the last `cdr'.
- (funcall table string pred t point)
- (completion--some (lambda (style)
- (funcall (nth 2 (assq style completion-styles-alist))
- string table pred point))
- completion-styles))))
+ ;; The property `completion-styles' indicates that this functional
+ ;; completion-table claims to take care of completion styles itself.
+ ;; [I.e. It will most likely call us back at some point. ]
+ (if (and (symbolp table) (get table 'completion-styles))
+ ;; Extended semantics for functional completion-tables:
+ ;; They accept a 4th argument `point' and when called with action=t
+ ;; and this 4th argument (a position inside `string'), they may
+ ;; return BASE-SIZE in the last `cdr'.
+ (funcall table string pred t point)
+ (completion--some (lambda (style)
+ (funcall (nth 2 (assq style completion-styles-alist))
+ string table pred point))
+ completion-styles)))
(defun minibuffer--bitset (modified completions exact)
(logior (if modified 4 0)
;; through the previous possible completions.
(setq completion-all-sorted-completions (cdr all)))))
+(defvar minibuffer-confirm-exit-commands
+ '(minibuffer-complete minibuffer-complete-word PC-complete PC-complete-word)
+ "A list of commands which cause an immediately following
+`minibuffer-complete-and-exit' to ask for extra confirmation.")
+
(defun minibuffer-complete-and-exit ()
- "If the minibuffer contents is a valid completion then exit.
-Otherwise try to complete it. If completion leads to a valid completion,
-a repetition of this command will exit.
-If `minibuffer-completion-confirm' is equal to `confirm', then do not
-try to complete, but simply ask for confirmation and accept any
-input if confirmed."
+ "Exit if the minibuffer contains a valid completion.
+Otherwise, try to complete the minibuffer contents. If
+completion leads to a valid completion, a repetition of this
+command will exit.
+
+If `minibuffer-completion-confirm' is `confirm', do not try to
+ complete; instead, ask for confirmation and accept any input if
+ confirmed.
+If `minibuffer-completion-confirm' is `confirm-after-completion',
+ do not try to complete; instead, ask for confirmation if the
+ preceding minibuffer command was `minibuffer-complete', and
+ accept the input otherwise."
(interactive)
(let ((beg (field-beginning))
(end (field-end)))
(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)
(delete-region beg end))))
(exit-minibuffer))
- ((eq minibuffer-completion-confirm 'confirm-only)
+ ((eq minibuffer-completion-confirm 'confirm)
;; The user is permitted to exit with an input that's rejected
- ;; by test-completion, but at the condition to confirm her choice.
+ ;; by test-completion, after confirming her choice.
(if (eq last-command this-command)
(exit-minibuffer)
(minibuffer-message "Confirm")
nil))
+ ((eq minibuffer-completion-confirm 'confirm-after-completion)
+ ;; Similar to the above, but only if trying to exit immediately
+ ;; after typing TAB (this catches most minibuffer typos).
+ (if (memq last-command minibuffer-confirm-exit-commands)
+ (progn (minibuffer-message "Confirm")
+ nil)
+ (exit-minibuffer)))
+
(t
;; Call do-completion, but ignore errors.
(case (condition-case nil
(let ((exts '(" " "-"))
(before (substring string 0 point))
(after (substring string point))
- ;; If the user hasn't entered any text yet, then she
- ;; presumably hits SPC to see the *completions*, but
- ;; partial-completion will often find a " " or a "-" to match.
- ;; So disable partial-completion in that situation.
- (completion-styles
- (or (and (equal string "")
- (remove 'partial-completion completion-styles))
- completion-styles))
+ ;; Disable partial-completion for this.
+ (completion-styles
+ (or (remove 'partial-completion completion-styles)
+ completion-styles))
tem)
(while (and exts (not (consp tem)))
(setq tem (completion-try-completion
of the differing parts is, by contrast, slightly highlighted."
:group 'completion)
-(defun completion-hilit-commonality (completions prefix-len)
+(defun completion-hilit-commonality (completions prefix-len base-size)
(when completions
- (let* ((last (last completions))
- (base-size (cdr last))
- (com-str-len (- prefix-len (or base-size 0))))
- ;; Remove base-size during mapcar, and add it back later.
- (setcdr last nil)
+ (let ((com-str-len (- prefix-len (or base-size 0))))
(nconc
(mapcar
(lambda (elem)
properties of `highlight'.
At the end, this runs the normal hook `completion-setup-hook'.
It can find the completion buffer in `standard-output'.
-The obsolete optional second arg COMMON-SUBSTRING is a string.
-It is used to put faces, `completions-first-difference' and
-`completions-common-part' on the completion buffer. The
-`completions-common-part' face is put on the common substring
-specified by COMMON-SUBSTRING."
+
+The obsolete optional arg COMMON-SUBSTRING, if non-nil, should be a string
+specifying a common substring for adding the faces
+`completions-first-difference' and `completions-common-part' to
+the completions buffer."
(if common-substring
(setq completions (completion-hilit-commonality
- completions (length common-substring))))
+ completions (length common-substring)
+ ;; We don't know the base-size.
+ nil)))
(if (not (bufferp standard-output))
;; This *never* (ever) happens, so there's no point trying to be clever.
(with-temp-buffer
(let ((standard-output (current-buffer))
(completion-setup-hook nil))
- (display-completion-list completions))
+ (display-completion-list completions common-substring))
(princ (buffer-string)))
- (with-current-buffer standard-output
- (goto-char (point-max))
- (if (null completions)
- (insert "There are no possible completions of what you have typed.")
-
- (insert "Possible completions are:\n")
- (let ((last (last completions)))
- ;; Get the base-size from the tail of the list.
- (set (make-local-variable 'completion-base-size) (or (cdr last) 0))
- (setcdr last nil)) ;Make completions a properly nil-terminated list.
- (completion--insert-strings completions))))
+ (let ((mainbuf (current-buffer)))
+ (with-current-buffer standard-output
+ (goto-char (point-max))
+ (if (null completions)
+ (insert "There are no possible completions of what you have typed.")
+ (insert "Possible completions are:\n")
+ (let ((last (last completions)))
+ ;; Set base-size from the tail of the list.
+ (set (make-local-variable 'completion-base-size)
+ (or (cdr last)
+ (and (minibufferp mainbuf) 0)))
+ (setcdr last nil)) ; Make completions a properly nil-terminated list.
+ (completion--insert-strings completions)))))
;; The hilit used to be applied via completion-setup-hook, so there
;; may still be some code that uses completion-common-substring.
- (let ((completion-common-substring common-substring))
- (run-hooks 'completion-setup-hook))
+ (with-no-warnings
+ (let ((completion-common-substring common-substring))
+ (run-hooks 'completion-setup-hook)))
nil)
(defun minibuffer-completion-help ()
str))))
((eq action t)
- (let ((all (file-name-all-completions name realdir))
- ;; FIXME: Actually, this is not always right in the presence
- ;; of envvars, but there's not much we can do, I think.
- (base-size (length (file-name-directory string))))
+ (let ((all (file-name-all-completions name realdir)))
;; Check the predicate, if necessary.
(unless (memq read-file-name-predicate '(nil file-exists-p))
(if (funcall pred tem) (push tem comp))))
(setq all (nreverse comp))))
- (if (and completion-all-completions-with-base-size (consp all))
- ;; Add base-size, but only if the list is non-empty.
- (nconc all base-size)
- all)))
+ all))
(t
;; Only other case actually used is ACTION = lambda.
"Current predicate used by `read-file-name-internal'.")
(defcustom read-file-name-completion-ignore-case
- (if (memq system-type '(ms-dos windows-nt darwin macos vax-vms axp-vms))
+ (if (memq system-type '(ms-dos windows-nt darwin cygwin))
t nil)
"Non-nil means when reading a file name completion ignores case."
:group 'minibuffer
(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)))
(defun completion-emacs21-all-completions (string table pred point)
(completion-hilit-commonality
- (all-completions string table pred t)
- (length string)))
-
-;;; Basic completion, used in Emacs-22.
+ (all-completions string table pred)
+ (length string)
+ (car (completion-boundaries string table pred ""))))
(defun completion-emacs22-try-completion (string table pred point)
(let ((suffix (substring string point))
(cons (concat completion suffix) (length completion)))))
(defun completion-emacs22-all-completions (string table pred point)
- (completion-hilit-commonality
- (all-completions (substring string 0 point) table pred t)
- point))
+ (let ((beforepoint (substring string 0 point)))
+ (completion-hilit-commonality
+ (all-completions beforepoint table pred)
+ point
+ (car (completion-boundaries beforepoint table pred "")))))
+
+;;; 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)))
- (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)))))
-
-(defalias 'completion-basic-all-completions 'completion-emacs22-all-completions)
+ (let* ((beforepoint (substring string 0 point))
+ (afterpoint (substring string point))
+ (bounds (completion-boundaries beforepoint table pred afterpoint)))
+ (if (zerop (cdr bounds))
+ ;; `try-completion' may return a subtly different result
+ ;; than `all+merge', so try to use it whenever possible.
+ (let ((completion (try-completion beforepoint table pred)))
+ (if (not (stringp completion))
+ completion
+ (cons
+ (concat completion
+ (completion--merge-suffix completion point afterpoint))
+ (length completion))))
+ (let* ((suffix (substring afterpoint (cdr bounds)))
+ (prefix (substring beforepoint 0 (car bounds)))
+ (pattern (delete
+ "" (list (substring beforepoint (car bounds))
+ 'point
+ (substring afterpoint 0 (cdr bounds)))))
+ (all (completion-pcm--all-completions prefix pattern table pred)))
+ (if minibuffer-completing-file-name
+ (setq all (completion-pcm--filename-try-filter all)))
+ (completion-pcm--merge-try pattern all prefix suffix)))))
+
+(defun completion-basic-all-completions (string table pred point)
+ (let* ((beforepoint (substring string 0 point))
+ (afterpoint (substring string point))
+ (bounds (completion-boundaries beforepoint table pred afterpoint))
+ (suffix (substring afterpoint (cdr bounds)))
+ (prefix (substring beforepoint 0 (car bounds)))
+ (pattern (delete
+ "" (list (substring beforepoint (car bounds))
+ 'point
+ (substring afterpoint 0 (cdr bounds)))))
+ (all (completion-pcm--all-completions prefix pattern table pred)))
+ (completion-hilit-commonality all point (car bounds))))
;;; Partial-completion-mode style completion.
-;; BUGS:
-
-;; - "minibuffer-s- TAB" with minibuffer-selected-window ends up with
-;; "minibuffer--s-" which matches other options.
-
(defvar completion-pcm--delim-wild-regex nil)
(defun completion-pcm--prepare-delim-re (delims)
(defun completion-pcm--all-completions (prefix pattern table pred)
"Find all completions for PATTERN in TABLE obeying PRED.
PATTERN is as returned by `completion-pcm--string->pattern'."
+ ;; (assert (= (car (completion-boundaries prefix table pred ""))
+ ;; (length prefix)))
;; Find an initial list of possible completions.
(if (completion-pcm--pattern-trivial-p pattern)
;; Minibuffer contains no delimiters -- simple case!
- (let* ((all (all-completions (concat prefix (car pattern)) table pred))
- (last (last all)))
- (if last (setcdr last nil))
- all)
+ (all-completions (concat prefix (car pattern)) table pred)
;; Use all-completions to do an initial cull. This is a big win,
;; since all-completions is written in C!
(let* (;; Convert search pattern to a standard regular expression.
(regex (completion-pcm--pattern->regex pattern))
- (completion-regexp-list (cons regex completion-regexp-list))
+ (case-fold-search completion-ignore-case)
+ (completion-regexp-list (cons regex completion-regexp-list))
(compl (all-completions
(concat prefix (if (stringp (car pattern)) (car pattern) ""))
- table pred))
- (last (last compl)))
- (when last
- (if (and (numberp (cdr last)) (/= (cdr last) (length prefix)))
- (message "Inconsistent base-size returned by completion table %s"
- table))
- (setcdr last nil))
+ table pred)))
(if (not (functionp table))
;; The internal functions already obeyed completion-regexp-list.
compl
- (let ((case-fold-search completion-ignore-case)
- (poss ()))
+ (let ((poss ()))
(dolist (c compl)
(when (string-match regex c) (push c poss)))
poss)))))
(defun completion-pcm--hilit-commonality (pattern completions)
(when completions
(let* ((re (completion-pcm--pattern->regex pattern '(point)))
+ (case-fold-search completion-ignore-case)
(last (last completions))
(base-size (cdr last)))
;; Remove base-size during mapcar, and add it back later.
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))
(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)
(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.
(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
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
(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)