;;; 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
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 "")))
(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)))
(let* ((qpos pred)
(ustring (funcall unquote string))
(uprefix (funcall unquote (substring string 0 qpos)))
- ;; FIXME: we really should pass `qpos' to `unuote' and have that
+ ;; 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)
;; (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
;; 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)))
+ ;;(cl-assert (<= point (length string)))
(pop new))))
(result
(completion--some (lambda (style)
(defun minibuffer-force-complete-and-exit ()
"Complete the minibuffer with first of the matches and exit."
(interactive)
- (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"))))
+ (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 (&optional start end)
"Complete the minibuffer to an exact match.
(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
(exit-minibuffer))
(defvar completion-in-region-functions nil
- "Wrapper hook around `completion-in-region'.")
+ "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 like the ones of
+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
: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.
"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.
(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)
(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 "")))))