;;; 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
;;; 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
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
;; 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
If you repeat this command after it displayed such a list,
scroll the window of possible completions."
(interactive)
- (completion-in-region (minibuffer-prompt-end) (point-max)
- minibuffer-completion-table
- minibuffer-completion-predicate))
+ (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,
;; 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)
(if (eq (car bounds) base) md-at-point
(completion-metadata (substring string 0 base) table pred))))
-(defun completion-all-sorted-completions (start end)
+(defun completion-all-sorted-completions (&optional start end)
(or completion-all-sorted-completions
(let* ((start (or start (minibuffer-prompt-end)))
(end (or end (point-max)))
(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.
(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)
(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)
(defface completions-first-difference
'((t (:inherit bold)))
- "Face added on the first uncommon character in completions in *Completions* buffer.")
+ "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.")
-
-(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
(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.
;; HACK: if the text we are completing is already in a field, we
;; want the completion field to take priority (e.g. Bug#6830).
(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)))
+ `(,(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
"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
:group 'minibuffer
- (setq completion-in-region--data nil)
+ ;; 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)
;; 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?).
- (completion-in-region-mode 1)
(setq completion-in-region--data
- (list start (copy-marker end) collection))
+ `(,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 :-(
(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
(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."
(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