;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
-;; Copyright (C) 2008-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2014 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Package: emacs
;;; Bugs:
-;; - completion-all-sorted-completions list all the completions, whereas
+;; - completion-all-sorted-completions lists 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
;;; Code:
-(eval-when-compile (require 'cl-lib))
+;;(eval-when-compile (require 'cl-lib))
+
+(defun minibuf-conform-representation (string basis)
+ (cond
+ ((eq (multibyte-string-p string) (multibyte-string-p basis))
+ string)
+ ((multibyte-string-p string)
+ (string-make-unibyte string))
+ (t
+ (string-make-multibyte string))))
+
+(defun try-completion (string collection &optional predicate)
+ "Return common substring of all completions of STRING in COLLECTION.
+Test each possible completion specified by COLLECTION
+to see if it begins with STRING. The possible completions may be
+strings or symbols. Symbols are converted to strings before testing,
+see `symbol-name'.
+All that match STRING are compared together; the longest initial sequence
+common to all these matches is the return value.
+If there is no match at all, the return value is nil.
+For a unique match which is exact, the return value is t.
+
+If COLLECTION is an alist, the keys (cars of elements) are the
+possible completions. If an element is not a cons cell, then the
+element itself is the possible completion.
+If COLLECTION is a hash-table, all the keys that are strings or symbols
+are the possible completions.
+If COLLECTION is an obarray, the names of all symbols in the obarray
+are the possible completions.
+
+COLLECTION can also be a function to do the completion itself.
+It receives three arguments: the values STRING, PREDICATE and nil.
+Whatever it returns becomes the value of `try-completion'.
+
+If optional third argument PREDICATE is non-nil,
+it is used to test each possible match.
+The match is a candidate only if PREDICATE returns non-nil.
+The argument given to PREDICATE is the alist element
+or the symbol from the obarray. If COLLECTION is a hash-table,
+predicate is called with two arguments: the key and the value.
+Additionally to this predicate, `completion-regexp-list'
+is used to further constrain the set of candidates."
+ (catch 'return
+ (let (bestmatch
+ eltstring
+ ;; Size in bytes of BESTMATCH.
+ (bestmatchsize 0)
+ ;; These are in bytes, too.
+ (compare 0)
+ (matchsize 0)
+ (type (cond
+ ((hash-table-p collection) 'hash-table)
+ ((vectorp collection) 'obarray)
+ ((or (null collection)
+ (and (consp collection)
+ (not (functionp collection))))
+ 'list)
+ (t 'function)))
+ (matchcount 0))
+ ;;(cl-check-type string string)
+ (when (eq type 'function)
+ (throw 'return
+ (funcall collection string predicate nil)))
+ (catch 'break
+ (funcall
+ (cond
+ ((eq type 'hash-table) #'maphash)
+ ((eq type 'list) #'mapc)
+ ((eq type 'obarray) #'mapatoms))
+ (lambda (elt &optional hash-value)
+ (catch 'continue
+ ;; Is this element a possible completion?
+ (setq eltstring (if (and (eq type 'list) (consp elt))
+ (car elt)
+ elt))
+ (when (symbolp eltstring)
+ (setq eltstring (symbol-name eltstring)))
+ (when (and (stringp eltstring)
+ (<= (length string) (length eltstring))
+ (eq t (compare-strings eltstring
+ 0
+ (length string)
+ string
+ 0
+ nil
+ completion-ignore-case)))
+ ;; Yes.
+ (let ((case-fold-search completion-ignore-case))
+ (let ((regexps completion-regexp-list))
+ (while (consp regexps)
+ (when (null (string-match (car regexps) eltstring 0))
+ (throw 'continue nil))
+ (setq regexps (cdr regexps)))))
+ ;; Ignore this element if there is a predicate and the
+ ;; predicate doesn't like it.
+ (unless (cond
+ ((null predicate) t)
+ ((eq predicate 'commandp)
+ (commandp elt nil))
+ ((eq type 'hash-table)
+ (funcall predicate elt hash-value))
+ (t (funcall predicate elt)))
+ (throw 'continue nil))
+ ;; Update computation of how much all possible completions match
+ (if (null bestmatch)
+ (setq matchcount 1
+ bestmatch eltstring
+ bestmatchsize (length eltstring))
+ (setq compare (min bestmatchsize (length eltstring))
+ matchsize
+ (let ((tem (compare-strings bestmatch
+ 0
+ compare
+ eltstring
+ 0
+ compare
+ completion-ignore-case)))
+ (if (eq tem t) compare (1- (abs tem)))))
+ (when completion-ignore-case
+ ;; If this is an exact match except for case, use it as
+ ;; the best match rather than one that is not an exact
+ ;; match. This way, we get the case pattern of the actual
+ ;; match.
+ (when (or (and (eql matchsize (length eltstring))
+ (< matchsize (length bestmatch)))
+ ;; If there is more than one exact match
+ ;; ignoring case, and one of them is exact
+ ;; including case, prefer that one. If there is
+ ;; no exact match ignoring case, prefer a match
+ ;; that does not change the case of the input.
+ (and (eql (eql matchsize (length eltstring))
+ (eql matchsize (length bestmatch)))
+ (eq t (compare-strings eltstring
+ 0
+ (length string)
+ string
+ 0
+ nil
+ nil))
+ (not (eq t (compare-strings bestmatch
+ 0
+ (length string)
+ string
+ 0
+ nil
+ nil)))))
+ (setq bestmatch eltstring)))
+ (when (or (not (eql bestmatchsize (length eltstring)))
+ (not (eql bestmatchsize matchsize)))
+ ;; Don't count the same string multiple times.
+ (if (<= matchcount 1)
+ (setq matchcount (+ matchcount 1))))
+ (setq bestmatchsize matchsize)
+ (when (and (<= matchsize (length string))
+ ;; If completion-ignore-case is non-nil, don't
+ ;; short-circuit because we want to find the
+ ;; best possible match *including* case
+ ;; differences.
+ (not completion-ignore-case)
+ (> matchcount 1))
+ ;; No need to look any further.
+ (throw 'break nil))))))
+ collection))
+ (cond
+ ;; No completions found.
+ ((null bestmatch)
+ nil)
+ ;; If we are ignoring case, and there is no exact match, and no
+ ;; additional text was supplied, don't change the case of what the
+ ;; user typed.
+ ((and completion-ignore-case
+ (eql bestmatchsize (length string))
+ (> (length bestmatch) bestmatchsize))
+ (minibuf-conform-representation string bestmatch))
+ ;; Return t if the supplied string is an exact match (counting
+ ;; case); it does not require any change to be made.
+ ((and (eql matchcount 1) (equal bestmatch string))
+ t)
+ ;; Else extract the part in which all completions agree.
+ (t (substring bestmatch 0 bestmatchsize))))))
+
+(defun all-completions (string collection &optional predicate hide-spaces)
+ "Search for partial matches to STRING in COLLECTION.
+Test each of the possible completions specified by COLLECTION
+to see if it begins with STRING. The possible completions may be
+strings or symbols. Symbols are converted to strings before testing,
+see `symbol-name'.
+The value is a list of all the possible completions that match STRING.
+
+If COLLECTION is an alist, the keys (cars of elements) are the
+possible completions. If an element is not a cons cell, then the
+element itself is the possible completion.
+If COLLECTION is a hash-table, all the keys that are strings or symbols
+are the possible completions.
+If COLLECTION is an obarray, the names of all symbols in the obarray
+are the possible completions.
+
+COLLECTION can also be a function to do the completion itself.
+It receives three arguments: the values STRING, PREDICATE and t.
+Whatever it returns becomes the value of `all-completions'.
+
+If optional third argument PREDICATE is non-nil,
+it is used to test each possible match.
+The match is a candidate only if PREDICATE returns non-nil.
+The argument given to PREDICATE is the alist element
+or the symbol from the obarray. If COLLECTION is a hash-table,
+predicate is called with two arguments: the key and the value.
+Additionally to this predicate, `completion-regexp-list'
+is used to further constrain the set of candidates.
+
+An obsolete optional fourth argument HIDE-SPACES is still accepted for
+backward compatibility. If non-nil, strings in COLLECTION that start
+with a space are ignored unless STRING itself starts with a space."
+ (catch 'return
+ (let (eltstring
+ allmatches
+ (type (cond ((hash-table-p collection) 'hash-table)
+ ((vectorp collection) 'obarray)
+ ((or (null collection)
+ (and (consp collection)
+ (not (functionp collection))))
+ 'list)
+ (t 'function))))
+ ;;(cl-check-type string string)
+ (when (eq type 'function)
+ (throw 'return
+ (funcall collection string predicate t)))
+ (catch 'break
+ (funcall
+ (cond
+ ((eq type 'hash-table) #'maphash)
+ ((eq type 'obarray) #'mapatoms)
+ ((eq type 'list) #'mapc))
+ (lambda (elt &optional hash-value)
+ (catch 'continue
+ (setq eltstring (if (and (eq type 'list) (consp elt))
+ (car elt)
+ elt))
+ ;; Is this element a possible completion?
+ (when (symbolp eltstring)
+ (setq eltstring (symbol-name eltstring)))
+ (when (and (stringp eltstring)
+ (<= (length string) (length eltstring))
+ ;; If HIDE_SPACES, reject alternatives that start
+ ;; with space unless the input starts with space.
+ (or (not hide-spaces)
+ (and (> (length string) 0)
+ (eql (aref string 0) ?\ ))
+ (eql (aref eltstring 0) ?\ ))
+ (eq t (compare-strings eltstring 0
+ (length string)
+ string 0
+ (length string)
+ completion-ignore-case)))
+ (let ((case-fold-search completion-ignore-case))
+ (let ((regexps completion-regexp-list))
+ (while (consp regexps)
+ (unless (string-match (car regexps) eltstring 0)
+ (throw 'continue nil))
+ (setq regexps (cdr regexps)))))
+ ;; Ignore this element if there is a predicate and the
+ ;; predicate doesn't like it.
+ (unless (cond
+ ((not predicate) t)
+ ((eq predicate 'commandp) (commandp elt nil))
+ ((eq type 'hash-table) (funcall predicate elt hash-value))
+ (t (funcall predicate elt)))
+ (throw 'continue nil))
+ ;; Ok => put it on the list.
+ (setq allmatches (cons eltstring allmatches)))))
+ collection))
+ (nreverse allmatches))))
+
+(set-advertised-calling-convention
+ 'all-completions '(string collection &optional predicate) "23.1")
+
+(defun test-completion (string collection &optional predicate)
+ "Return non-nil if STRING is a valid completion.
+Takes the same arguments as `all-completions' and `try-completion'.
+If COLLECTION is a function, it is called with three arguments:
+the values STRING, PREDICATE and `lambda'."
+ (catch 'return
+ (let (tem)
+ ;; check-string string
+ (cond
+ ((or (null collection)
+ (and (consp collection)
+ (not (functionp collection))))
+ (setq tem (assoc-string string collection completion-ignore-case))
+ (unless tem
+ (throw 'return nil)))
+ ((vectorp collection)
+ (setq tem (intern-soft string collection)) ; XXX nil
+ (unless tem
+ (let ((string (if (multibyte-string-p string)
+ (string-make-unibyte string)
+ (string-make-multibyte string))))
+ (setq tem (intern-soft string collection))))
+ (when (and completion-ignore-case (not tem))
+ (catch 'break
+ (mapatoms
+ #'(lambda (symbol)
+ (if (eq t (compare-strings string 0 nil
+ (symbol-name symbol) 0 nil
+ t))
+ (setq tem symbol)
+ (throw 'break nil)))
+ collection)))
+ (unless tem
+ (throw 'return nil)))
+ ((hash-table-p collection)
+ (let ((unique (cons nil nil)))
+ (let ((x (gethash string collection unique)))
+ (if (not (eq x unique))
+ (setq tem x)
+ (catch 'break
+ (maphash
+ #'(lambda (key value)
+ value ; ignore
+ (let ((key (if (symbolp key) (symbol-name key) key)))
+ (when (and (stringp key)
+ (eq t (compare-strings string 0 nil
+ key 0 nil
+ completion-ignore-case)))
+ (setq tem key)
+ (throw 'break nil))))
+ collection)))
+ (unless (stringp tem)
+ (throw 'return nil)))))
+ (t (throw 'return (funcall collection string predicate 'lambda))))
+ ;; Reject this element if it fails to match all the regexps.
+ (when (consp completion-regexp-list)
+ (let ((case-fold-search completion-ignore-case))
+ (let ((regexps completion-regexp-list))
+ (while (consp regexps)
+ (unless (string-match (car regexps)
+ (if (symbolp tem) string tem)
+ nil)
+ (throw 'return nil))
+ (setq regexps (cdr regexps))))))
+ ;; Finally, check the predicate.
+ (if predicate
+ (if (hash-table-p collection)
+ (funcall predicate tem (gethash tem collection))
+ (funcall predicate tem))
+ t))))
+
+(defun internal-complete-buffer (string predicate flag)
+ "Perform completion on buffer names.
+STRING and PREDICATE have the same meanings as in `try-completion',
+`all-completions', and `test-completion'.
+
+If FLAG is nil, invoke `try-completion'; if it is t, invoke
+`all-completions'; otherwise invoke `test-completion'."
+ (let ((buffer-alist (mapcar #'(lambda (buf)
+ (cons (buffer-name buf) buf))
+ (buffer-list))))
+ (cond
+ ((not flag)
+ (try-completion string buffer-alist predicate))
+ ((eq flag t)
+ (let ((res (all-completions string buffer-alist predicate nil)))
+ (if (> (length string) 0)
+ res
+ ;; Strip out internal buffers.
+ (let ((bufs res))
+ ;; First, look for a non-internal buffer in `res'.
+ (while (and (consp bufs)
+ (eql (aref (car bufs) 0) ?\ ))
+ (setq bufs (cdr bufs)))
+ (if (null bufs)
+ (if (eql (length res) (length buffer-alist))
+ ;; If all bufs are internal don't strip them out.
+ res
+ bufs)
+ (setq res bufs)
+ (while (consp (cdr bufs))
+ (if (eql (aref (cadr bufs) 0) ?\ )
+ (rplacd bufs (cddr bufs))
+ (setq bufs (cdr bufs))))
+ res)))))
+ ((eq flag 'lambda)
+ (test-completion string buffer-alist predicate))
+ ((eq flag 'metadata)
+ (list 'metadata (cons 'category 'buffer)))
+ (t nil))))
;;; Completion table manipulation
(let ((firsterror nil)
res)
(while (and (not res) xs)
- (condition-case err
+ (condition-case-unless-debug err
(setq res (funcall fun (pop xs)))
(error (unless firsterror (setq firsterror err)) nil)))
(or res
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'."
+`all-completions'. See Info node `(elisp)Programmed Completion'.
+
+See also the related function `completion-table-with-cache'."
(lambda (string pred action)
(if (or (eq (car-safe action) 'boundaries) (eq action 'metadata))
;; `fun' is not supposed to return another function but a plain old
(current-buffer)))
(complete-with-action action (funcall fun string) string pred)))))
+(defun completion-table-with-cache (fun &optional ignore-case)
+ "Create dynamic completion table from function FUN, with cache.
+This is a wrapper for `completion-table-dynamic' that saves the last
+argument-result pair from FUN, so that several lookups with the
+same argument (or with an argument that starts with the first one)
+only need to call FUN once. This can be useful when FUN performs a
+relatively slow operation, such as calling an external process.
+
+When IGNORE-CASE is non-nil, FUN is expected to be case-insensitive."
+ ;; See eg bug#11906.
+ (let* (last-arg last-result
+ (new-fun
+ (lambda (arg)
+ (if (and last-arg (string-prefix-p last-arg arg ignore-case))
+ last-result
+ (prog1
+ (setq last-result (funcall fun arg))
+ (setq last-arg arg))))))
+ (completion-table-dynamic new-fun)))
+
(defmacro lazy-completion-table (var fun)
"Initialize variable VAR as a lazy completion table.
If the completion table VAR is used for the first time (e.g., by passing VAR
form (concat S1 S) in the same way as TABLE completes strings of
the form (concat S2 S)."
(lambda (string pred action)
- (let* ((str (if (eq t (compare-strings string 0 (length s1) s1 nil nil
- completion-ignore-case))
+ (let* ((str (if (string-prefix-p s1 string completion-ignore-case)
(concat s2 (substring string (length s1)))))
(res (if str (complete-with-action action table str pred))))
(when res
(+ 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))
+ (if (string-prefix-p s2 string completion-ignore-case)
(concat s1 (substring res (length s2)))))
((eq action t)
(let ((bounds (completion-boundaries str table pred "")))
"Create a completion table that tries each table in TABLES in turn."
;; FIXME: the boundaries may come from TABLE1 even when the completion list
;; is returned by TABLE2 (because TABLE1 returned an empty list).
+ ;; Same potential problem if any of the tables use quoting.
(lambda (string pred action)
(completion--some (lambda (table)
(complete-with-action action table string pred))
tables)))
+(defun completion-table-merge (&rest tables)
+ "Create a completion table that collects completions from all TABLES."
+ ;; FIXME: same caveats as in `completion-table-in-turn'.
+ (lambda (string pred action)
+ (cond
+ ((null action)
+ (let ((retvals (mapcar (lambda (table)
+ (try-completion string table pred))
+ tables)))
+ (if (member string retvals)
+ string
+ (try-completion string
+ (mapcar (lambda (value)
+ (if (eq value t) string value))
+ (delq nil retvals))
+ pred))))
+ ((eq action t)
+ (apply #'append (mapcar (lambda (table)
+ (all-completions string table pred))
+ tables)))
+ (t
+ (completion--some (lambda (table)
+ (complete-with-action action table string pred))
+ tables)))))
+
(defun completion-table-with-quoting (table unquote requote)
;; A difficult part of completion-with-quoting is to map positions in the
;; quoted string to equivalent positions in the unquoted string and
(qsuffix (cdr action))
(ufull (if (zerop (length qsuffix)) ustring
(funcall unquote (concat string qsuffix))))
- (_ (cl-assert (string-prefix-p ustring ufull)))
+ ;;(_ (cl-assert (string-prefix-p ustring ufull)))
(usuffix (substring ufull (length ustring)))
(boundaries (completion-boundaries ustring table pred usuffix))
(qlboundary (car (funcall requote (car boundaries) string)))
completions))
((eq action 'completion--unquote)
- (let ((ustring (funcall unquote string))
- (uprefix (funcall unquote (substring string 0 pred))))
- ;; We presume (more or less) that `concat' and `unquote' commute.
- (cl-assert (string-prefix-p uprefix ustring))
- (list ustring table (length uprefix)
+ ;; PRED is really a POINT in STRING.
+ ;; We should return a new set (STRING TABLE POINT REQUOTE)
+ ;; where STRING is a new (unquoted) STRING to match against the new TABLE
+ ;; using a new POINT inside it, and REQUOTE is a requoting function which
+ ;; should reverse the unquoting, (i.e. it receives the completion result
+ ;; of using the new TABLE and should turn it into the corresponding
+ ;; quoted result).
+ (let* ((qpos pred)
+ (ustring (funcall unquote string))
+ (uprefix (funcall unquote (substring string 0 qpos)))
+ ;; FIXME: we really should pass `qpos' to `unquote' and have that
+ ;; function give us the corresponding `uqpos'. But for now we
+ ;; presume (more or less) that `concat' and `unquote' commute.
+ (uqpos (if (string-prefix-p uprefix ustring)
+ ;; Yay!! They do seem to commute!
+ (length uprefix)
+ ;; They don't commute this time! :-(
+ ;; Maybe qpos is in some text that disappears in the
+ ;; ustring (bug#17239). Let's try a second chance guess.
+ (let ((usuffix (funcall unquote (substring string qpos))))
+ (if (string-suffix-p usuffix ustring)
+ ;; Yay!! They still "commute" in a sense!
+ (- (length ustring) (length usuffix))
+ ;; Still no luck! Let's just choose *some* position
+ ;; within ustring.
+ (/ (+ (min (length uprefix) (length ustring))
+ (max (- (length ustring) (length usuffix)) 0))
+ 2))))))
+ (list ustring table uqpos
(lambda (unquoted-result op)
(pcase op
(1 ;;try
;; (concat (substring ustring 0 boundary) prefix))
;; t))
(qboundary (car (funcall requote boundary string)))
- (_ (cl-assert (<= qboundary qfullpos)))
+ ;;(_ (cl-assert (<= qboundary qfullpos)))
;; FIXME: this split/quote/concat business messes up the carefully
;; placed completions-common-part and completions-first-difference
;; faces. We could try within the mapcar loop to search for the
;; which only get quoted when needed by choose-completion.
(nconc
(mapcar (lambda (completion)
- (cl-assert (string-prefix-p prefix completion 'ignore-case) t)
+ ;;(cl-assert (string-prefix-p prefix completion 'ignore-case) t)
(let* ((new (substring completion (length prefix)))
(qnew (funcall qfun new))
+ (qprefix
+ (if (not completion-ignore-case)
+ qprefix
+ ;; Make qprefix inherit the case from `completion'.
+ (let* ((rest (substring completion
+ 0 (length prefix)))
+ (qrest (funcall qfun rest)))
+ (if (completion--string-equal-p qprefix qrest)
+ (propertize qrest 'face
+ 'completions-common-part)
+ qprefix))))
(qcompletion (concat qprefix qnew)))
;; FIXME: Similarly here, Cygwin's mapping trips this
;; assertion.
(message nil)))
;; Clear out any old echo-area message to make way for our new thing.
(message nil)
- (setq message (if (and (null args) (string-match-p "\\` *\\[.+\\]\\'" message))
+ (setq message (if (and (null args)
+ (string-match-p "\\` *\\[.+\\]\\'" message))
;; Make sure we can put-text-property.
(copy-sequence message)
(concat " [" message "]")))
(defun minibuffer-completion-contents ()
"Return the user input in a minibuffer before point as a string.
-That is what completion commands operate on."
- (buffer-substring (field-beginning) (point)))
+In Emacs-22, that was what completion commands operated on."
+ (declare (obsolete nil "24.4"))
+ (buffer-substring (minibuffer-prompt-end) (point)))
(defun delete-minibuffer-contents ()
"Delete all user input in a minibuffer.
is requested but cannot be done.
If the value is `lazy', the *Completions* buffer is only displayed after
the second failed attempt to complete."
- :type '(choice (const nil) (const t) (const lazy))
- :group 'minibuffer)
+ :type '(choice (const nil) (const t) (const lazy)))
(defconst completion-styles-alist
'((emacs21
Note that `completion-category-overrides' may override these
styles for specific categories, such as files, buffers, etc."
:type completion--styles-type
- :group 'minibuffer
:version "23.1")
(defcustom completion-category-overrides
;; part of the string (e.g. substitute-in-file-name).
(let ((requote
(when (completion-metadata-get metadata 'completion--unquote-requote)
+ ;;(cl-assert (functionp table))
(let ((new (funcall table string point 'completion--unquote)))
(setq string (pop new))
(setq table (pop new))
(setq point (pop new))
+ ;;(cl-assert (<= point (length string)))
(pop new))))
- (result
- (completion--some (lambda (style)
- (funcall (nth n (assq style
- completion-styles-alist))
- string table pred point))
- (completion--styles metadata))))
+ (result
+ (completion--some (lambda (style)
+ (funcall (nth n (assq style
+ completion-styles-alist))
+ string table pred point))
+ (completion--styles metadata))))
(if requote
(funcall requote result n)
result)))
(setq end (- end suffix-len))
(setq newtext (substring newtext 0 (- suffix-len))))
(goto-char beg)
- (insert-and-inherit newtext)
- (delete-region (point) (+ (point) (- end beg)))
+ (let ((length (- end beg))) ;Read `end' before we insert the text.
+ (insert-and-inherit newtext)
+ (delete-region (point) (+ (point) length)))
(forward-char suffix-len)))
(defcustom completion-cycle-threshold nil
"Number of completion candidates below which cycling is used.
-Depending on this setting `minibuffer-complete' may use cycling,
+Depending on this setting `completion-in-region' may use cycling,
like `minibuffer-force-complete'.
If nil, cycling is never used.
If t, cycling is always used.
(over (assq 'cycle (cdr (assq cat completion-category-overrides)))))
(if over (cdr over) completion-cycle-threshold)))
-(defvar completion-all-sorted-completions nil)
-(make-variable-buffer-local 'completion-all-sorted-completions)
+(defvar-local completion-all-sorted-completions nil)
(defvar-local completion--all-sorted-completions-location nil)
(defvar completion-cycling nil)
(if completion-show-inline-help
(minibuffer-message msg)))
-(defun completion--do-completion (&optional try-completion-function
- expect-exact)
+(defun completion--do-completion (beg end &optional
+ try-completion-function expect-exact)
"Do the completion and return a summary of what happened.
M = completion was performed, the text was Modified.
C = there were available Completions.
TRY-COMPLETION-FUNCTION is a function to use in place of `try-completion'.
EXPECT-EXACT, if non-nil, means that there is no need to tell the user
when the buffer's text is already an exact match."
- (let* ((beg (field-beginning))
- (end (field-end))
- (string (buffer-substring beg end))
+ (let* ((string (buffer-substring beg end))
(md (completion--field-metadata beg))
(comp (funcall (or try-completion-function
'completion-try-completion)
(if unchanged
(goto-char end)
;; Insert in minibuffer the chars we got.
- (completion--replace beg end completion))
+ (completion--replace beg end completion)
+ (setq end (+ beg (length completion))))
;; Move point to its completion-mandated destination.
(forward-char (- comp-pos (length completion)))
;; whether this is a unique completion or not, so try again using
;; the real case (this shouldn't recurse again, because the next
;; time try-completion will return either t or the exact string).
- (completion--do-completion try-completion-function expect-exact)
+ (completion--do-completion beg end
+ try-completion-function expect-exact)
;; It did find a match. Do we match some possibility exactly now?
(let* ((exact (test-completion completion
minibuffer-completion-predicate
""))
comp-pos)))
- (completion-all-sorted-completions))))
+ (completion-all-sorted-completions beg end))))
(completion--flush-all-sorted-completions)
(cond
((and (consp (cdr comps)) ;; There's something to cycle.
;; Not more than completion-cycle-threshold remaining
;; completions: let's cycle.
(setq completed t exact t)
- (completion--cache-all-sorted-completions comps)
- (minibuffer-force-complete))
+ (completion--cache-all-sorted-completions beg end comps)
+ (minibuffer-force-complete beg end))
(completed
;; We could also decide to refresh the completions,
;; if they're displayed (and assuming there are
(if (pcase completion-auto-help
(`lazy (eq this-command last-command))
(_ completion-auto-help))
- (minibuffer-completion-help)
+ (minibuffer-completion-help beg end)
(completion--message "Next char not unique")))
;; If the last exact completion and this one were the same, it
;; means we've already given a "Complete, but not unique" message
;; and the user's hit TAB again, so now we give him help.
(t
(if (and (eq this-command last-command) completion-auto-help)
- (minibuffer-completion-help))
+ (minibuffer-completion-help beg end))
(completion--done completion 'exact
(unless expect-exact
"Complete, but not unique"))))
If you repeat this command after it displayed such a list,
scroll the window of possible completions."
(interactive)
+ (when (<= (minibuffer-prompt-end) (point))
+ (completion-in-region (minibuffer-prompt-end) (point-max)
+ minibuffer-completion-table
+ minibuffer-completion-predicate)))
+
+(defun completion--in-region-1 (beg end)
;; If the previous command was not this,
;; mark the completion buffer obsolete.
(setq this-command 'completion-at-point)
;; If end is in view, scroll up to the beginning.
(set-window-start window (point-min) nil)
;; Else scroll down one screen.
- (scroll-other-window))
+ (with-selected-window window
+ (scroll-up)))
nil)))
;; If we're cycling, keep on cycling.
((and completion-cycling completion-all-sorted-completions)
- (minibuffer-force-complete)
+ (minibuffer-force-complete beg end)
t)
- (t (pcase (completion--do-completion)
+ (t (pcase (completion--do-completion beg end)
(#b000 nil)
(_ t)))))
-(defun completion--cache-all-sorted-completions (comps)
+(defun completion--cache-all-sorted-completions (beg end comps)
(add-hook 'after-change-functions
'completion--flush-all-sorted-completions nil t)
(setq completion--all-sorted-completions-location
- (cons (copy-marker (field-beginning)) (copy-marker (field-end))))
+ (cons (copy-marker beg) (copy-marker end)))
(setq completion-all-sorted-completions comps))
(defun completion--flush-all-sorted-completions (&optional start end _len)
(if (eq (car bounds) base) md-at-point
(completion-metadata (substring string 0 base) table pred))))
-(defun completion-all-sorted-completions ()
+(defun completion-all-sorted-completions (&optional start end)
(or completion-all-sorted-completions
- (let* ((start (field-beginning))
- (end (field-end))
+ (let* ((start (or start (minibuffer-prompt-end)))
+ (end (or end (point-max)))
(string (buffer-substring start end))
(md (completion--field-metadata start))
(all (completion-all-completions
;; Cache the result. This is not just for speed, but also so that
;; repeated calls to minibuffer-force-complete can cycle through
;; all possibilities.
- (completion--cache-all-sorted-completions (nconc all base-size))))))
+ (completion--cache-all-sorted-completions
+ start end (nconc all base-size))))))
(defun minibuffer-force-complete-and-exit ()
"Complete the minibuffer with first of the matches and exit."
(interactive)
- (minibuffer-force-complete)
- (minibuffer--complete-and-exit
- ;; If the previous completion completed to an element which fails
- ;; test-completion, then we shouldn't exit, but that should be rare.
- (lambda () (minibuffer-message "Incomplete"))))
+ (if (and (eq (minibuffer-prompt-end) (point-max))
+ minibuffer-default)
+ ;; Use the provided default if there's one (bug#17545).
+ (minibuffer-complete-and-exit)
+ (minibuffer-force-complete)
+ (completion--complete-and-exit
+ (minibuffer-prompt-end) (point-max) #'exit-minibuffer
+ ;; If the previous completion completed to an element which fails
+ ;; test-completion, then we shouldn't exit, but that should be rare.
+ (lambda () (minibuffer-message "Incomplete")))))
-(defun minibuffer-force-complete ()
+(defun minibuffer-force-complete (&optional start end)
"Complete the minibuffer to an exact match.
Repeated uses step through the possible completions."
(interactive)
;; FIXME: Need to deal with the extra-size issue here as well.
;; FIXME: ~/src/emacs/t<M-TAB>/lisp/minibuffer.el completes to
;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
- (let* ((start (copy-marker (field-beginning)))
- (end (field-end))
+ (let* ((start (copy-marker (or start (minibuffer-prompt-end))))
+ (end (or end (point-max)))
;; (md (completion--field-metadata start))
- (all (completion-all-sorted-completions))
+ (all (completion-all-sorted-completions start end))
(base (+ start (or (cdr (last all)) 0))))
(cond
((not (consp all))
'finished (when done "Sole completion"))))
(t
(completion--replace base end (car all))
+ (setq end (+ base (length (car all))))
(completion--done (buffer-substring-no-properties start (point)) 'sole)
;; Set cycling after modifying the buffer since the flush hook resets it.
(setq completion-cycling t)
- (setq this-command 'completion-at-point) ;For minibuffer-complete.
+ (setq this-command 'completion-at-point) ;For completion-in-region.
;; If completing file names, (car all) may be a directory, so we'd now
;; have a new set of possible completions and might want to reset
;; completion-all-sorted-completions to nil, but we prefer not to,
;; through the previous possible completions.
(let ((last (last all)))
(setcdr last (cons (car all) (cdr last)))
- (completion--cache-all-sorted-completions (cdr all)))
+ (completion--cache-all-sorted-completions start end (cdr all)))
;; Make sure repeated uses cycle, even though completion--done might
;; have added a space or something that moved us outside of the field.
;; (bug#12221).
(interactive)
(let ((completion-extra-properties extra-prop))
(completion-in-region start (point) table pred)))))
- (set-temporary-overlay-map
+ (set-transient-map
(let ((map (make-sparse-keymap)))
(define-key map [remap completion-at-point] cmd)
(define-key map (vector last-command-event) cmd)
`minibuffer-confirm-exit-commands', and accept the input
otherwise."
(interactive)
- (minibuffer--complete-and-exit
+ (completion-complete-and-exit (minibuffer-prompt-end) (point-max)
+ #'exit-minibuffer))
+
+(defun completion-complete-and-exit (beg end exit-function)
+ (completion--complete-and-exit
+ beg end exit-function
(lambda ()
(pcase (condition-case nil
- (completion--do-completion nil 'expect-exact)
+ (completion--do-completion beg end
+ nil 'expect-exact)
(error 1))
- ((or #b001 #b011) (exit-minibuffer))
+ ((or #b001 #b011) (funcall exit-function))
(#b111 (if (not minibuffer-completion-confirm)
- (exit-minibuffer)
+ (funcall exit-function)
(minibuffer-message "Confirm")
nil))
(_ nil)))))
-(defun minibuffer--complete-and-exit (completion-function)
+(defun completion--complete-and-exit (beg end
+ exit-function completion-function)
"Exit from `require-match' minibuffer.
COMPLETION-FUNCTION is called if the current buffer's content does not
appear to be a match."
- (let ((beg (field-beginning))
- (end (field-end)))
(cond
;; Allow user to specify null string
- ((= beg end) (exit-minibuffer))
+ ((= beg end) (funcall exit-function))
((test-completion (buffer-substring beg end)
minibuffer-completion-table
minibuffer-completion-predicate)
;; that file.
(= (length string) (length compl)))
(completion--replace beg end compl))))
- (exit-minibuffer))
+ (funcall exit-function))
((memq minibuffer-completion-confirm '(confirm confirm-after-completion))
;; The user is permitted to exit with an input that's rejected
;; catches most minibuffer typos).
(and (eq minibuffer-completion-confirm 'confirm-after-completion)
(not (memq last-command minibuffer-confirm-exit-commands))))
- (exit-minibuffer)
+ (funcall exit-function)
(minibuffer-message "Confirm")
nil))
(t
;; Call do-completion, but ignore errors.
- (funcall completion-function)))))
+ (funcall completion-function))))
(defun completion--try-word-completion (string table predicate point md)
(let ((comp (completion-try-completion string table predicate point md)))
(before (substring string 0 point))
(after (substring string point))
tem)
+ ;; If both " " and "-" lead to completions, prefer " " so SPC behaves
+ ;; a bit more like a self-inserting key (bug#17375).
(while (and exts (not (consp tem)))
(setq tem (completion-try-completion
(concat before (pop exts) after)
is added, provided that matches some possible completion.
Return nil if there is no valid completion, else t."
(interactive)
- (pcase (completion--do-completion 'completion--try-word-completion)
+ (completion-in-region--single-word
+ (minibuffer-prompt-end) (point-max)
+ minibuffer-completion-table minibuffer-completion-predicate))
+
+(defun completion-in-region--single-word (beg end collection
+ &optional predicate)
+ (let ((minibuffer-completion-table collection)
+ (minibuffer-completion-predicate predicate))
+ (pcase (completion--do-completion beg end
+ #'completion--try-word-completion)
(#b000 nil)
- (_ t)))
+ (_ t))))
(defface completions-annotations '((t :inherit italic))
"Face to use for annotations in the *Completions* buffer.")
If the value is `horizontal', display completions sorted
horizontally in alphabetical order, rather than down the screen."
:type '(choice (const horizontal) (const vertical))
- :group 'minibuffer
:version "23.2")
(defun completion--insert-strings (strings)
(defface completions-first-difference
'((t (:inherit bold)))
- "Face added on the first uncommon character in completions in *Completions* buffer."
- :group 'completion)
+ "Face for the first uncommon character in completions.
+See also the face `completions-common-part'.")
(defface completions-common-part '((t nil))
- "Face added on the common prefix substring in completions in *Completions* buffer.
-The idea of `completions-common-part' is that you can use it to
-make the common parts less visible than normal, so that the rest
-of the differing parts is, by contrast, slightly highlighted."
- :group 'completion)
-
-(defun completion-hilit-commonality (completions prefix-len base-size)
+ "Face for the common prefix substring in completions.
+The idea of this face is that you can use it to make the common parts
+less visible than normal, so that the differing parts are emphasized
+by contrast.
+See also the face `completions-first-difference'.")
+
+(defun completion-hilit-commonality (completions prefix-len &optional base-size)
+ "Apply font-lock highlighting to a list of completions, COMPLETIONS.
+PREFIX-LEN is an integer. BASE-SIZE is an integer or nil (meaning zero).
+
+This adds the face `completions-common-part' to the first
+\(PREFIX-LEN - BASE-SIZE) characters of each completion, and the face
+`completions-first-difference' to the first character after that.
+
+It returns a list with font-lock properties applied to each element,
+and with BASE-SIZE appended as the last element."
(when completions
(let ((com-str-len (- prefix-len (or base-size 0))))
(nconc
The actual completion alternatives, as inserted, are given `mouse-face'
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 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."
+It can find the completion buffer in `standard-output'."
+ (declare (advertised-calling-convention (completions) "24.4"))
(if common-substring
(setq completions (completion-hilit-commonality
completions (length common-substring)
(defun completion--done (string &optional finished message)
(let* ((exit-fun (plist-get completion-extra-properties :exit-function))
(pre-msg (and exit-fun (current-message))))
- (cl-assert (memq finished '(exact sole finished unknown)))
+ ;;(cl-assert (memq finished '(exact sole finished unknown)))
(when exit-fun
(when (eq finished 'unknown)
(setq finished
(equal pre-msg (and exit-fun (current-message))))
(completion--message message))))
-(defun minibuffer-completion-help ()
+(defun minibuffer-completion-help (&optional start end)
"Display a list of possible completions of the current minibuffer contents."
(interactive)
(message "Making completion list...")
- (let* ((start (field-beginning))
- (end (field-end))
- (string (field-string))
+ (let* ((start (or start (minibuffer-prompt-end)))
+ (end (or end (point-max)))
+ (string (buffer-substring start end))
(md (completion--field-metadata start))
(completions (completion-all-completions
string
minibuffer-completion-table
minibuffer-completion-predicate
- (- (point) (field-beginning))
+ (- (point) start)
md)))
(message nil)
(if (or (null completions)
(exit-minibuffer))
(defvar completion-in-region-functions nil
- "Wrapper hook around `completion-in-region'.
-The functions on this special hook are called with 5 arguments:
- NEXT-FUN START END COLLECTION PREDICATE.
-NEXT-FUN is a function of four arguments (START END COLLECTION PREDICATE)
-that performs the default operation. The other four arguments are like
-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.")
+ "Wrapper hook around `completion--in-region'.")
+(make-obsolete-variable 'completion-in-region-functions
+ 'completion-in-region-function "24.4")
+
+(defvar completion-in-region-function #'completion--in-region
+ "Function to perform the job of `completion-in-region'.
+The function is called with 4 arguments: START END COLLECTION PREDICATE.
+The arguments and expected return value are as specified for
+`completion-in-region'.")
(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.
Point needs to be somewhere between START and END.
-PREDICATE (a function called with no arguments) says when to
-exit."
- (cl-assert (<= start (point)) (<= (point) end))
+PREDICATE (a function called with no arguments) says when to exit.
+This calls the function that `completion-in-region-function' specifies
+\(passing the same four arguments that it received) to do the work,
+and returns whatever it does. The return value should be nil
+if there was no valid completion, else t."
+ ;;(cl-assert (<= start (point)) (<= (point) end))
+ (funcall completion-in-region-function start end collection predicate))
+
+(defcustom read-file-name-completion-ignore-case
+ (if (memq system-type '(ms-dos windows-nt darwin cygwin))
+ t nil)
+ "Non-nil means when reading a file name completion ignores case."
+ :type 'boolean
+ :version "22.1")
+
+(defun completion--in-region (start end collection &optional predicate)
+ "Default function to use for `completion-in-region-function'.
+Its arguments and return value are as specified for `completion-in-region'.
+This respects the wrapper hook `completion-in-region-functions'."
(with-wrapper-hook
;; FIXME: Maybe we should use this hook to provide a "display
;; completions" operation as well.
completion-in-region-functions (start end collection predicate)
(let ((minibuffer-completion-table collection)
- (minibuffer-completion-predicate predicate)
- (ol (make-overlay start end nil nil t)))
- (overlay-put ol 'field 'completion)
+ (minibuffer-completion-predicate predicate))
;; HACK: if the text we are completing is already in a field, we
;; want the completion field to take priority (e.g. Bug#6830).
- (overlay-put ol 'priority 100)
(when completion-in-region-mode-predicate
- (completion-in-region-mode 1)
(setq completion-in-region--data
- (list (if (markerp start) start (copy-marker start))
- (copy-marker end) collection)))
- ;; FIXME: `minibuffer-complete' should call `completion-in-region' rather
- ;; than the other way around!
- (unwind-protect
- (call-interactively 'minibuffer-complete)
- (delete-overlay ol)))))
+ `(,(if (markerp start) start (copy-marker start))
+ ,(copy-marker end t) ,collection ,predicate))
+ (completion-in-region-mode 1))
+ (completion--in-region-1 start end))))
(defvar completion-in-region-mode-map
(let ((map (make-sparse-keymap)))
"Keymap activated during `completion-in-region'.")
;; It is difficult to know when to exit completion-in-region-mode (i.e. hide
-;; the *Completions*).
+;; the *Completions*). Here's how previous packages did it:
;; - 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.
;; (defalias 'completion-in-region--prech 'completion-in-region--postch)
+(defvar completion-in-region-mode nil) ;Explicit defvar, i.s.o defcustom.
+
(define-minor-mode completion-in-region-mode
- "Transient minor mode used during `completion-in-region'.
-With a prefix argument ARG, enable the modemode if ARG is
-positive, and disable it otherwise. If called from Lisp, enable
-the mode if ARG is omitted or nil."
+ "Transient minor mode used during `completion-in-region'."
:global t
- (setq completion-in-region--data nil)
+ :group 'minibuffer
+ ;; Prevent definition of a custom-variable since it makes no sense to
+ ;; customize this variable.
+ :variable completion-in-region-mode
;; (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)
- (unless (equal "*Completions*" (buffer-name (window-buffer)))
- (minibuffer-hide-completions))
+ (progn
+ (setq completion-in-region--data nil)
+ (unless (equal "*Completions*" (buffer-name (window-buffer)))
+ (minibuffer-hide-completions)))
;; (add-hook 'pre-command-hook #'completion-in-region--prech)
- (cl-assert completion-in-region-mode-predicate)
+ ;;(cl-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)
(lambda ()
;; We're still in the same completion field.
(let ((newstart (car-safe (funcall hookfun))))
- (and newstart (= newstart start)))))
- (ol (make-overlay start end nil nil t)))
+ (and newstart (= newstart start))))))
;; 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)
- (overlay-put ol 'priority 100)
- (completion-in-region-mode 1)
(setq completion-in-region--data
- (list start (copy-marker end) collection))
- (unwind-protect
- (call-interactively 'minibuffer-completion-help)
- (delete-overlay ol))))
+ `(,start ,(copy-marker end t) ,collection
+ ,(plist-get plist :predicate)))
+ (completion-in-region-mode 1)
+ (minibuffer-completion-help start end)))
(`(,hookfun . ,_)
;; The hook function already performed completion :-(
;; Not much we can do at this point.
"The function called by `read-file-name' to do its work.
It should accept the same arguments as `read-file-name'.")
-(defcustom read-file-name-completion-ignore-case
- (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
- :type 'boolean
- :version "22.1")
-
(defcustom insert-default-directory t
"Non-nil means when reading a filename start with default dir in minibuffer.
For some commands, exiting with an empty minibuffer has a special meaning,
such as making the current buffer visit no file in the case of
`set-visited-file-name'."
- :group 'minibuffer
:type 'boolean)
;; Not always defined, but only called if next-read-file-uses-dialog-p says so.
(defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate)
"Read file name, prompting with PROMPT and completing in directory DIR.
-Value is not expanded---you must call `expand-file-name' yourself.
+The return value is not expanded---you must call `expand-file-name' yourself.
DIR is the directory to use for completing relative file names.
It should be an absolute directory name, or nil (which means the
;; Refresh other vars.
(completion-pcm--prepare-delim-re value))
:initialize 'custom-initialize-reset
- :group 'minibuffer
:type 'string)
(defcustom completion-pcm-complete-word-inserts-delimiters nil
"Treat the SPC or - inserted by `minibuffer-complete-word' as delimiters.
-Those chars are treated as delimiters iff this variable is non-nil.
+Those chars are treated as delimiters if this variable is non-nil.
I.e. if non-nil, M-x SPC will just insert a \"-\" in the minibuffer, whereas
if nil, it will list all possible commands in *Completions* because none of
the commands start with a \"-\" or a SPC."
(completion-pcm--string->pattern suffix)))
(let* ((pattern nil)
(p 0)
- (p0 p))
+ (p0 p)
+ (pending nil))
(while (and (setq p (string-match completion-pcm--delim-wild-regex
string p))
;; This is determined by the presence of a submatch-1 which delimits
;; the prefix.
(if (match-end 1) (setq p (match-end 1)))
- (push (substring string p0 p) pattern)
+ (unless (= p0 p)
+ (if pending (push pending pattern))
+ (push (substring string p0 p) pattern))
+ (setq pending nil)
(if (eq (aref string p) ?*)
(progn
(push 'star pattern)
(setq p0 (1+ p)))
(push 'any pattern)
- (setq p0 p))
- (cl-incf p))
-
+ (if (match-end 1)
+ (setq p0 p)
+ (push (substring string p (match-end 0)) pattern)
+ ;; `any-delim' is used so that "a-b" also finds "array->beginning".
+ (setq pending 'any-delim)
+ (setq p0 (match-end 0))))
+ (setq p p0))
+
+ (when (> (length string) p0)
+ (if pending (push pending pattern))
+ (push (substring string p0) pattern))
;; An empty string might be erroneously added at the beginning.
;; It should be avoided properly, but it's so easy to remove it here.
- (delete "" (nreverse (cons (substring string p0) pattern))))))
+ (delete "" (nreverse pattern)))))
+
+(defun completion-pcm--optimize-pattern (p)
+ ;; Remove empty strings in a separate phase since otherwise a ""
+ ;; might prevent some other optimization, as in '(any "" any).
+ (setq p (delete "" p))
+ (let ((n '()))
+ (while p
+ (pcase p
+ (`(,(and s1 (pred stringp)) ,(and s2 (pred stringp)) . ,rest)
+ (setq p (cons (concat s1 s2) rest)))
+ (`(,(and p1 (pred symbolp)) ,(and p2 (guard (eq p1 p2))) . ,_)
+ (setq p (cdr p)))
+ (`(star ,(pred symbolp) . ,rest) (setq p `(star . ,rest)))
+ (`(,(pred symbolp) star . ,rest) (setq p `(star . ,rest)))
+ (`(point ,(or `any `any-delim) . ,rest) (setq p `(point . ,rest)))
+ (`(,(or `any `any-delim) point . ,rest) (setq p `(point . ,rest)))
+ (`(any ,(or `any `any-delim) . ,rest) (setq p `(any . ,rest)))
+ (`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'.
+ (_ (push (pop p) n))))
+ (nreverse n)))
(defun completion-pcm--pattern->regex (pattern &optional group)
(let ((re
(lambda (x)
(cond
((stringp x) (regexp-quote x))
- ((if (consp group) (memq x group) group) "\\(.*?\\)")
- (t ".*?")))
+ (t
+ (let ((re (if (eq x 'any-delim)
+ (concat completion-pcm--delim-wild-regex "*?")
+ ".*?")))
+ (if (if (consp group) (memq x group) group)
+ (concat "\\(" re "\\)")
+ re)))))
pattern
""))))
;; Avoid pathological backtracking.
(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
+ (all (condition-case-unless-debug err
(funcall filter
(completion-pcm--all-completions
prefix pattern table pred))
- (error (unless firsterror (setq firsterror err)) nil))))
+ (error (setq firsterror err) nil))))
(when (and (null all)
(> (car bounds) 0)
(null (ignore-errors (try-completion prefix table pred))))
(nconc (completion-pcm--hilit-commonality pattern all)
(length prefix)))))
-(defun completion--sreverse (str)
- "Like `reverse' but for a string STR rather than a list."
- (apply #'string (nreverse (mapcar 'identity str))))
-
(defun completion--common-suffix (strs)
"Return the common suffix of the strings STRS."
- (completion--sreverse
- (try-completion
- ""
- (mapcar #'completion--sreverse strs))))
+ (nreverse (try-completion "" (mapcar #'reverse strs))))
(defun completion-pcm--merge-completions (strs pattern)
"Extract the commonality in STRS, with the help of PATTERN.
(let ((skip (length prefix)))
(mapcar (lambda (str) (substring str skip))
comps))))))
- (cl-assert (stringp suffix))
+ ;;(cl-assert (stringp suffix))
(unless (equal suffix "")
(push suffix res)))))
(setq fixed "")))))
;; Not `prefix'.
mergedpat))
;; New pos from the start.
- (newpos (length (completion-pcm--pattern->string pointpat)))
+ (newpos (length (completion-pcm--pattern->string pointpat)))
;; Do it afterwards because it changes `pointpat' by side effect.
(merged (completion-pcm--pattern->string (nreverse mergedpat))))
- (setq suffix (completion--merge-suffix merged newpos suffix))
+ (setq suffix (completion--merge-suffix
+ ;; The second arg should ideally be "the position right
+ ;; after the last char of `merged' that comes from the text
+ ;; to be completed". But completion-pcm--merge-completions
+ ;; currently doesn't give us that info. So instead we just
+ ;; use the "last but one" position, which tends to work
+ ;; well in practice since `suffix' always starts
+ ;; with a boundary and we hence mostly/only care about
+ ;; merging this boundary (bug#15419).
+ merged (max 0 (1- (length merged))) suffix))
(cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
(defun completion-pcm-try-completion (string table pred point)
HCoop / bpt / emacs.git / blobdiff