;; - 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 . POS) in which case it should return (boundaries START . END).
+;; (boundaries . SUFFIX) in which case it should return
+;; (boundaries START . END). See `completion-boundaries'.
;; Any other return value should be ignored (so we ignore values returned
;; from completion tables that don't know about this new `action' form).
;; 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.
-;; - New command minibuffer-force-complete that chooses one of all-completions.
;; - 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:
;;; Completion table manipulation
;; New completion-table operation.
-(defun completion-boundaries (string table pred pos)
- "Return the boundaries of the completions returned by TABLE at POS.
+(defun completion-boundaries (string table pred suffix)
+ "Return the boundaries of the completions returned by TABLE for STRING.
STRING is the string on which completion will be performed.
-The result is of the form (START . END) and gives the start and end position
-corresponding to the substring of STRING that can be completed by one
-of the elements returned by
-\(all-completions (substring STRING 0 POS) TABLE PRED).
+SUFFIX is the string after point.
+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 STRING))
-and for file names the result is the substring around POS delimited by
+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."
(let ((boundaries (if (functionp table)
- (funcall table string pred (cons 'boundaries pos)))))
+ (funcall table string pred (cons 'boundaries suffix)))))
(if (not (eq (car-safe boundaries) 'boundaries))
(setq boundaries nil))
(cons (or (cadr boundaries) 0)
- (or (cddr boundaries) (length string)))))
+ (or (cddr boundaries) (length suffix)))))
(defun completion--some (fun xs)
"Apply FUN to each element of XS in turn.
FUN will be called in the buffer from which the minibuffer was entered.
The result of the `dynamic-completion-table' form is a function
-that can be used as the ALIST argument to `try-completion' and
+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)
(funcall pred (concat prefix (if (consp s) (car s) s)))))))))
(if (eq (car-safe action) 'boundaries)
(let* ((len (length prefix))
- (bound (completion-boundaries string table pred
- (- (cdr action) len))))
- (list* 'boundaries (+ (car bound) len) (+ (cdr bound) len)))
+ (bound (completion-boundaries string table pred (cdr action))))
+ (list* 'boundaries (+ (car bound) len) (cdr bound)))
(let ((comp (complete-with-action action table string pred)))
(cond
;; In case of try-completion, add the prefix.
(copy-sequence message)
(concat " [" message "]")))
(when args (setq message (apply 'format message args)))
- (let ((ol (make-overlay (point-max) (point-max) nil t t)))
+ (let ((ol (make-overlay (point-max) (point-max) nil t t))
+ ;; 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
(unless (zerop (length message))
(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)
;;; Key bindings.
+(define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map
+ 'minibuffer-local-filename-must-match-map "23.1")
+
(let ((map minibuffer-local-map))
(define-key map "\C-g" 'abort-recursive-edit)
(define-key map "\r" 'exit-minibuffer)
(let ((map minibuffer-local-filename-completion-map))
(define-key map " " nil))
-(let ((map minibuffer-local-must-match-filename-map))
+(let ((map minibuffer-local-filename-must-match-map))
(define-key map " " nil))
(let ((map minibuffer-local-ns-map))
(if (eq (car-safe action) 'boundaries)
;; Compute the boundaries of the subfield to which this
;; completion applies.
- (let* ((pos (cdr action))
- (suffix (substring string pos)))
- (if (string-match completion--embedded-envvar-re
- (substring string 0 pos))
- (list* 'boundaries (or (match-beginning 2) (match-beginning 1))
+ (let ((suffix (cdr action)))
+ (if (string-match completion--embedded-envvar-re string)
+ (list* 'boundaries
+ (or (match-beginning 2) (match-beginning 1))
(when (string-match "[^[:alnum:]_]" suffix)
- (+ pos (match-beginning 0))))))
+ (match-beginning 0)))))
(when (string-match completion--embedded-envvar-re string)
(let* ((beg (or (match-beginning 2) (match-beginning 1)))
(table (completion--make-envvar-table))
((eq (car-safe action) 'boundaries)
;; FIXME: Actually, this is not always right in the presence of
;; envvars, but there's not much we can do, I think.
- (let ((start (length (file-name-directory
- (substring string 0 (cdr action)))))
- (end (string-match "/" string (cdr action))))
+ (let ((start (length (file-name-directory string)))
+ (end (string-match "/" (cdr action))))
(list* 'boundaries start end)))
-
+
(t
(let* ((dir (if (stringp pred)
;; It used to be that `pred' was abused to pass `dir'
"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))
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)
+ (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)))
(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))
-(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)))))
+;;; 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))
-(defalias 'completion-basic-all-completions 'completion-emacs22-all-completions)
+(defun completion-basic-try-completion (string table pred point)
+ (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
+ (if (consp all) (nconc all (car bounds)) all)
+ point)))
;;; 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)
completions)
base-size))))
-(defun completion-pcm--find-all-completions (string table pred point)
- (let* ((bounds (completion-boundaries string table pred point))
- (prefix (substring string 0 (car bounds)))
- (suffix (substring string (cdr bounds)))
- (origstring string)
+(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))
+ (prefix (substring beforepoint 0 (car bounds)))
+ (suffix (substring afterpoint (cdr bounds)))
firsterror)
- (setq string (substring string (car bounds) (cdr bounds)))
- (let* ((pattern (completion-pcm--string->pattern
- string (- point (car bounds))))
+ (setq string (substring string (car bounds) (+ point (cdr bounds))))
+ (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.
;; Update the boundaries and corresponding pattern.
;; We assume that all submatches result in the same boundaries
;; since we wouldn't know how to merge them otherwise anyway.
- (let* ((newstring (concat subprefix (car suball) string suffix))
- (newpoint (+ point (- (length newstring)
- (length origstring))))
+ ;; FIXME: COMPLETE REWRITE!!!
+ (let* ((newbeforepoint
+ (concat subprefix (car suball)
+ (substring string 0 relpoint)))
+ (leftbound (+ (length subprefix) (length (car suball))))
(newbounds (completion-boundaries
- newstring table pred newpoint))
- (newsubstring
- (substring newstring (car newbounds) (cdr newbounds))))
- (unless (or (equal newsubstring string)
+ newbeforepoint table pred afterpoint)))
+ (unless (or (and (eq (cdr bounds) (cdr newbounds))
+ (eq (car newbounds) leftbound))
;; Refuse new boundaries if they step over
;; the submatch.
- (< (car newbounds)
- (+ (length subprefix) (length (car suball)))))
+ (< (car newbounds) leftbound))
;; The new completed prefix does change the boundaries
;; of the completed substring.
- (setq suffix (substring newstring (cdr newbounds)))
- (setq string newsubstring)
- (setq between (substring newstring
- (+ (length subprefix)
- (length (car suball)))
+ (setq suffix (substring afterpoint (cdr newbounds)))
+ (setq string
+ (concat (substring newbeforepoint (car newbounds))
+ (substring afterpoint 0 (cdr newbounds))))
+ (setq between (substring newbeforepoint leftbound
(car newbounds)))
(setq pattern (completion-pcm--string->pattern
- string (- newpoint (car bounds)))))
+ string
+ (- (length newbeforepoint)
+ (car newbounds)))))
(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)))
- (unless all
- ;; Even though we found expansions in the prefix, none
- ;; leads to a valid completion.
- ;; Let's keep the expansions, tho.
- (dolist (submatch suball)
- (push (concat submatch between newsubstring) all)))))
+ ;; FIXME: This can come in handy for try-completion,
+ ;; but isn't right for all-completions, since it lists
+ ;; invalid completions.
+ ;; (unless all
+ ;; ;; Even though we found expansions in the prefix, none
+ ;; ;; leads to a valid completion.
+ ;; ;; Let's keep the expansions, tho.
+ ;; (dolist (submatch suball)
+ ;; (push (concat submatch between newsubstring) all)))
+ ))
(setq pattern (append subpat (list 'any (string sep))
(if between (list between)) pattern))
(setq prefix subprefix)))))
(defun completion-pcm-all-completions (string table pred point)
(destructuring-bind (pattern all &optional prefix suffix)
(completion-pcm--find-all-completions string table pred point)
- (completion-pcm--hilit-commonality pattern all)))
+ (when all
+ (nconc (completion-pcm--hilit-commonality pattern all)
+ (length prefix)))))
(defun completion-pcm--merge-completions (strs pattern)
"Extract the commonality in STRS, with the help of 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
(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)
HCoop / bpt / emacs.git / blobdiff