;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
-;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Package: emacs
;; internal use only.
;; Functional completion tables have an extended calling conventions:
-;; - The `action' can be (additionally to nil, t, and lambda) of the form
-;; (boundaries . SUFFIX) in which case it should return
+;; The `action' can be (additionally to nil, t, and lambda) of the form
+;; - (boundaries . SUFFIX) in which case it should return
;; (boundaries START . END). See `completion-boundaries'.
;; Any other return value should be ignored (so we ignore values returned
;; from completion tables that don't know about this new `action' form).
+;; - `metadata' in which case it should return (metadata . ALIST) where
+;; ALIST is the metadata of this table. See `completion-metadata'.
+;; Any other return value should be ignored (so we ignore values returned
+;; from completion tables that don't know about this new `action' form).
;;; Bugs:
;; corresponding to the displayed completions because we only
;; provide the start info but not the end info in
;; completion-base-position.
-;; - quoting is problematic. E.g. the double-dollar quoting used in
-;; substitute-in-file-name (and hence read-file-name-internal) bumps
-;; into various bugs:
-;; - choose-completion doesn't know how to quote the text it inserts.
-;; E.g. it fails to double the dollars in file-name completion, or
-;; to backslash-escape spaces and other chars in comint completion.
-;; - when completing ~/tmp/fo$$o, the highligting in *Completions*
-;; is off by one position.
-;; - all code like PCM which relies on all-completions to match
-;; its argument gets confused because all-completions returns unquoted
-;; texts (as desired for *Completions* output).
;; - C-x C-f ~/*/sr ? should not list "~/./src".
;; - minibuffer-force-complete completes ~/src/emacs/t<!>/lisp/minibuffer.el
;; to ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
;;; Todo:
-;; - extend `boundaries' to provide various other meta-data about the
-;; output of `all-completions':
-;; - preferred sorting order when displayed in *Completions*.
-;; - annotations/text-properties to add when displayed in *Completions*.
-;; - quoting/unquoting (so we can complete files names with envvars
-;; and backslashes, and all-completion can list names without
-;; quoting backslashes and dollars).
+;; - for M-x, cycle-sort commands that have no key binding first.
+;; - Make things like icomplete-mode or lightning-completion work with
+;; completion-in-region-mode.
+;; - extend `metadata':
;; - indicate how to turn all-completion's output into
;; try-completion's output: e.g. completion-ignored-extensions.
-;; maybe that could be merged with the "quote" operation above.
-;; - completion hook to run when the completion is
-;; selected/inserted (maybe this should be provided some other
-;; way, e.g. as text-property, so `try-completion can also return it?)
-;; both for when it's inserted via TAB or via choose-completion.
+;; maybe that could be merged with the "quote" operation.
;; - indicate that `all-completions' doesn't do prefix-completion
;; but just returns some list that relates in some other way to
;; the provided string (as is the case in filecache.el), in which
;; \n into something else, add special boundaries between
;; completions). E.g. when completing from the kill-ring.
-;; - make partial-completion-mode obsolete:
-;; - (?) <foo.h> style completion for file names.
-;; This can't be done identically just by tweaking completion,
-;; because partial-completion-mode's behavior is to expand <string.h>
-;; to /usr/include/string.h only when exiting the minibuffer, at which
-;; point the completion code is actually not involved normally.
-;; Partial-completion-mode does it via a find-file-not-found-function.
-;; - special code for C-x C-f <> to visit the file ref'd at point
-;; via (require 'foo) or #include "foo". ffap seems like a better
-;; place for this feature (supplemented with major-mode-provided
-;; functions to find the file ref'd at point).
-
;; - case-sensitivity currently confuses two issues:
;; - whether or not a particular completion table should be case-sensitive
;; (i.e. whether strings that differ only by case are semantically
and for file names the result is the positions delimited by
the closest directory separators."
(let ((boundaries (if (functionp table)
- (funcall table string pred (cons 'boundaries suffix)))))
+ (funcall table string pred
+ (cons 'boundaries suffix)))))
(if (not (eq (car-safe boundaries) 'boundaries))
(setq boundaries nil))
(cons (or (cadr boundaries) 0)
(or (cddr boundaries) (length suffix)))))
+(defun completion-metadata (string table pred)
+ "Return the metadata of elements to complete at the end of STRING.
+This metadata is an alist. Currently understood keys are:
+- `category': the kind of objects returned by `all-completions'.
+ Used by `completion-category-overrides'.
+- `annotation-function': function to add annotations in *Completions*.
+ Takes one argument (STRING), which is a possible completion and
+ returns a string to append to STRING.
+- `display-sort-function': function to sort entries in *Completions*.
+ Takes one argument (COMPLETIONS) and should return a new list
+ of completions. Can operate destructively.
+- `cycle-sort-function': function to sort entries when cycling.
+ Works like `display-sort-function'.
+The metadata of a completion table should be constant between two boundaries."
+ (let ((metadata (if (functionp table)
+ (funcall table string pred 'metadata))))
+ (if (eq (car-safe metadata) 'metadata)
+ metadata
+ '(metadata))))
+
+(defun completion--field-metadata (field-start)
+ (completion-metadata (buffer-substring-no-properties field-start (point))
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
+
+(defun completion-metadata-get (metadata prop)
+ (cdr (assq prop metadata)))
+
(defun completion--some (fun xs)
"Apply FUN to each element of XS in turn.
Return the first non-nil returned value.
(defun complete-with-action (action table string pred)
"Perform completion ACTION.
STRING is the string to complete.
-TABLE is the completion table, which should not be a function.
+TABLE is the completion table.
PRED is a completion predicate.
ACTION can be one of nil, t or `lambda'."
(cond
((functionp table) (funcall table string pred action))
- ((eq (car-safe action) 'boundaries)
- (cons 'boundaries (completion-boundaries string table pred (cdr action))))
+ ((eq (car-safe action) 'boundaries) nil)
+ ((eq action 'metadata) nil)
(t
(funcall
(cond
that can be used as the COLLECTION argument to `try-completion' and
`all-completions'. See Info node `(elisp)Programmed Completion'."
(lambda (string pred action)
- (with-current-buffer (let ((win (minibuffer-selected-window)))
- (if (window-live-p win) (window-buffer win)
- (current-buffer)))
- (complete-with-action action (funcall fun string) string pred))))
+ (if (or (eq (car-safe action) 'boundaries) (eq action 'metadata))
+ ;; `fun' is not supposed to return another function but a plain old
+ ;; completion table, whose boundaries are always trivial.
+ nil
+ (with-current-buffer (let ((win (minibuffer-selected-window)))
+ (if (window-live-p win) (window-buffer win)
+ (current-buffer)))
+ (complete-with-action action (funcall fun string) string pred)))))
(defmacro lazy-completion-table (var fun)
"Initialize variable VAR as a lazy completion table.
`(completion-table-dynamic
(lambda (,str)
(when (functionp ,var)
- (setq ,var (,fun)))
+ (setq ,var (funcall #',fun)))
,var))))
-(defun completion-table-case-fold (table string pred action)
- (let ((completion-ignore-case t))
- (complete-with-action action table string pred)))
+(defun completion-table-case-fold (table &optional dont-fold)
+ "Return new completion TABLE that is case insensitive.
+If DONT-FOLD is non-nil, return a completion table that is
+case sensitive instead."
+ (lambda (string pred action)
+ (let ((completion-ignore-case (not dont-fold)))
+ (complete-with-action action table string pred))))
+
+(defun completion-table-subvert (table s1 s2)
+ "Completion table that replaces the prefix S1 with S2 in STRING.
+The result is a completion table which completes strings of the
+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))
+ (concat s2 (substring string (length s1)))))
+ (res (if str (complete-with-action action table str pred))))
+ (when res
+ (cond
+ ((eq (car-safe action) 'boundaries)
+ (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0)))
+ (list* 'boundaries
+ (max (length s1)
+ (+ 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))
+ (concat s1 (substring res (length s2)))))
+ ((eq action t)
+ (let ((bounds (completion-boundaries str table pred "")))
+ (if (>= (car bounds) (length s2))
+ res
+ (let ((re (concat "\\`"
+ (regexp-quote (substring s2 (car bounds))))))
+ (delq nil
+ (mapcar (lambda (c)
+ (if (string-match re c)
+ (substring c (match-end 0))))
+ res))))))
+ ;; E.g. action=nil and it's the only completion.
+ (res))))))
(defun completion-table-with-context (prefix table string pred action)
;; TODO: add `suffix' maybe?
- ;; Notice that `pred' may not be a function in some abusive cases.
- (when (functionp pred)
- (setq pred
- ;; Predicates are called differently depending on the nature of
- ;; the completion table :-(
- (cond
- ((vectorp table) ;Obarray.
- (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
- ((hash-table-p table)
- (lambda (s _v) (funcall pred (concat prefix s))))
- ((functionp table)
- (lambda (s) (funcall pred (concat prefix s))))
- (t ;Lists and alists.
- (lambda (s)
- (funcall pred (concat prefix (if (consp s) (car s) s))))))))
- (if (eq (car-safe action) 'boundaries)
- (let* ((len (length prefix))
- (bound (completion-boundaries string table pred (cdr action))))
- (list* 'boundaries (+ (car bound) len) (cdr bound)))
- (let ((comp (complete-with-action action table string pred)))
- (cond
- ;; In case of try-completion, add the prefix.
- ((stringp comp) (concat prefix comp))
- (t comp)))))
+ (let ((pred
+ (if (not (functionp pred))
+ ;; Notice that `pred' may not be a function in some abusive cases.
+ pred
+ ;; Predicates are called differently depending on the nature of
+ ;; the completion table :-(
+ (cond
+ ((vectorp table) ;Obarray.
+ (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
+ ((hash-table-p table)
+ (lambda (s _v) (funcall pred (concat prefix s))))
+ ((functionp table)
+ (lambda (s) (funcall pred (concat prefix s))))
+ (t ;Lists and alists.
+ (lambda (s)
+ (funcall pred (concat prefix (if (consp s) (car s) s)))))))))
+ (if (eq (car-safe action) 'boundaries)
+ (let* ((len (length prefix))
+ (bound (completion-boundaries string table pred (cdr action))))
+ (list* 'boundaries (+ (car bound) len) (cdr bound)))
+ (let ((comp (complete-with-action action table string pred)))
+ (cond
+ ;; In case of try-completion, add the prefix.
+ ((stringp comp) (concat prefix comp))
+ (t comp))))))
(defun completion-table-with-terminator (terminator table string pred action)
"Construct a completion table like TABLE but with an extra TERMINATOR.
in which case TERMINATOR-REGEXP is a regular expression whose submatch
number 1 should match TERMINATOR. This is used when there is a need to
distinguish occurrences of the TERMINATOR strings which are really terminators
-from others (e.g. escaped)."
+from others (e.g. escaped). In this form, the car of TERMINATOR can also be,
+instead of a string, a function that takes the completion and returns the
+\"terminated\" string."
+ ;; FIXME: This implementation is not right since it only adds the terminator
+ ;; in try-completion, so any completion-style that builds the completion via
+ ;; all-completions won't get the terminator, and selecting an entry in
+ ;; *Completions* won't get the terminator added either.
(cond
((eq (car-safe action) 'boundaries)
(let* ((suffix (cdr action))
(bounds (completion-boundaries string table pred suffix))
(terminator-regexp (if (consp terminator)
(cdr terminator) (regexp-quote terminator)))
- (max (string-match terminator-regexp suffix)))
+ (max (and terminator-regexp
+ (string-match terminator-regexp suffix))))
(list* 'boundaries (car bounds)
(min (cdr bounds) (or max (length suffix))))))
((eq action nil)
(let ((comp (try-completion string table pred)))
(if (consp terminator) (setq terminator (car terminator)))
(if (eq comp t)
- (concat string terminator)
- (if (and (stringp comp)
- ;; FIXME: Try to avoid this second call, especially since
+ (if (functionp terminator)
+ (funcall terminator string)
+ (concat string terminator))
+ (if (and (stringp comp) (not (zerop (length comp)))
+ ;; Try to avoid the second call to try-completion, since
;; it may be very inefficient (because `comp' made us
;; jump to a new boundary, so we complete in that
;; boundary with an empty start string).
- ;; completion-boundaries might help.
+ (let ((newbounds (completion-boundaries comp table pred "")))
+ (< (car newbounds) (length comp)))
(eq (try-completion comp table pred) t))
- (concat comp terminator)
+ (if (functionp terminator)
+ (funcall terminator comp)
+ (concat comp terminator))
comp))))
- ((eq action t)
+ ;; completion-table-with-terminator is always used for
+ ;; "sub-completions" so it's only called if the terminator is missing,
+ ;; in which case `test-completion' should return nil.
+ ((eq action 'lambda) nil)
+ (t
;; FIXME: We generally want the `try' and `all' behaviors to be
;; consistent so pcm can merge the `all' output to get the `try' output,
;; but that sometimes clashes with the need for `all' output to look
;; good in *Completions*.
;; (mapcar (lambda (s) (concat s terminator))
;; (all-completions string table pred))))
- (all-completions string table pred))
- ;; completion-table-with-terminator is always used for
- ;; "sub-completions" so it's only called if the terminator is missing,
- ;; in which case `test-completion' should return nil.
- ((eq action 'lambda) nil)))
+ (complete-with-action action table string pred))))
(defun completion-table-with-predicate (table pred1 strict string pred2 action)
"Make a completion table equivalent to TABLE but filtered through PRED1.
(test-completion string table pred2))
(t
(or (complete-with-action action table string
- (if (null pred2) pred1
+ (if (not (and pred1 pred2))
+ (or pred1 pred2)
(lambda (x)
;; Call `pred1' first, so that `pred2'
;; really can't tell that `x' is in table.
- (if (funcall pred1 x) (funcall pred2 x)))))
+ (and (funcall pred1 x) (funcall pred2 x)))))
;; If completion failed and we're not applying pred1 strictly, try
;; again without pred1.
- (and (not strict)
+ (and (not strict) pred1 pred2
(complete-with-action action table string pred2))))))
(defun completion-table-in-turn (&rest tables)
(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
+ ;; vice-versa. There is no efficient and reliable algorithm that works for
+ ;; arbitrary quote and unquote functions.
+ ;; So to map from quoted positions to unquoted positions, we simply assume
+ ;; that `concat' and `unquote' commute (which tends to be the case).
+ ;; And we ask `requote' to do the work of mapping from unquoted positions
+ ;; back to quoted positions.
+ "Return a new completion table operating on quoted text.
+TABLE operates on the unquoted text.
+UNQUOTE is a function that takes a string and returns a new unquoted string.
+REQUOTE is a function of 2 args (UPOS QSTR) where
+ QSTR is a string entered by the user (and hence indicating
+ the user's preferred form of quoting); and
+ UPOS is a position within the unquoted form of QSTR.
+REQUOTE should return a pair (QPOS . QFUN) such that QPOS is the
+position corresponding to UPOS but in QSTR, and QFUN is a function
+of one argument (a string) which returns that argument appropriately quoted
+for use at QPOS."
+ ;; FIXME: One problem with the current setup is that `qfun' doesn't know if
+ ;; its argument is "the end of the completion", so if the quoting used double
+ ;; quotes (for example), we end up completing "fo" to "foobar and throwing
+ ;; away the closing double quote.
+ (lambda (string pred action)
+ (cond
+ ((eq action 'metadata)
+ (append (completion-metadata string table pred)
+ '((completion--unquote-requote . t))))
+
+ ((eq action 'lambda) ;;test-completion
+ (let ((ustring (funcall unquote string)))
+ (test-completion ustring table pred)))
+
+ ((eq (car-safe action) 'boundaries)
+ (let* ((ustring (funcall unquote string))
+ (qsuffix (cdr action))
+ (ufull (if (zerop (length qsuffix)) ustring
+ (funcall unquote (concat string qsuffix))))
+ (_ (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)))
+ (qrboundary (if (zerop (cdr boundaries)) 0 ;Common case.
+ (let* ((urfullboundary
+ (+ (cdr boundaries) (length ustring))))
+ (- (car (funcall requote urfullboundary
+ (concat string qsuffix)))
+ (length string))))))
+ (list* 'boundaries qlboundary qrboundary)))
+
+ ;; In "normal" use a c-t-with-quoting completion table should never be
+ ;; called with action in (t nil) because `completion--unquote' should have
+ ;; been called before and would have returned a different completion table
+ ;; to apply to the unquoted text. But there's still a lot of code around
+ ;; that likes to use all/try-completions directly, so we do our best to
+ ;; handle those calls as well as we can.
+
+ ((eq action nil) ;;try-completion
+ (let* ((ustring (funcall unquote string))
+ (completion (try-completion ustring table pred)))
+ ;; Most forms of quoting allow several ways to quote the same string.
+ ;; So here we could simply requote `completion' in a kind of
+ ;; "canonical" quoted form without paying attention to the way
+ ;; `string' was quoted. But since we have to solve the more complex
+ ;; problems of "pay attention to the original quoting" for
+ ;; all-completions, we may as well use it here, since it provides
+ ;; a nicer behavior.
+ (if (not (stringp completion)) completion
+ (car (completion--twq-try
+ string ustring completion 0 unquote requote)))))
+
+ ((eq action t) ;;all-completions
+ ;; When all-completions is used for completion-try/all-completions
+ ;; (e.g. for `pcm' style), we can't do the job properly here because
+ ;; the caller will match our output against some pattern derived from
+ ;; the user's (quoted) input, and we don't have access to that
+ ;; pattern, so we can't know how to requote our output so that it
+ ;; matches the quoting used in the pattern. It is to fix this
+ ;; fundamental problem that we have to introduce the new
+ ;; unquote-requote method so that completion-try/all-completions can
+ ;; pass the unquoted string to the style functions.
+ (pcase-let*
+ ((ustring (funcall unquote string))
+ (completions (all-completions ustring table pred))
+ (boundary (car (completion-boundaries ustring table pred "")))
+ (completions
+ (completion--twq-all
+ string ustring completions boundary unquote requote))
+ (last (last completions)))
+ (when (consp last) (setcdr last nil))
+ 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.
+ (assert (string-prefix-p uprefix ustring))
+ (list ustring table (length uprefix)
+ (lambda (unquoted-result op)
+ (pcase op
+ (`1 ;;try
+ (if (not (stringp (car-safe unquoted-result)))
+ unquoted-result
+ (completion--twq-try
+ string ustring
+ (car unquoted-result) (cdr unquoted-result)
+ unquote requote)))
+ (`2 ;;all
+ (let* ((last (last unquoted-result))
+ (base (or (cdr last) 0)))
+ (when last
+ (setcdr last nil)
+ (completion--twq-all string ustring
+ unquoted-result base
+ unquote requote))))))))))))
+
+(defun completion--twq-try (string ustring completion point
+ unquote requote)
+ ;; Basically two case: either the new result is
+ ;; - commonprefix1 <point> morecommonprefix <qpos> suffix
+ ;; - commonprefix <qpos> newprefix <point> suffix
+ (pcase-let*
+ ((prefix (fill-common-string-prefix ustring completion))
+ (suffix (substring completion (max point (length prefix))))
+ (`(,qpos . ,qfun) (funcall requote (length prefix) string))
+ (qstr1 (if (> point (length prefix))
+ (funcall qfun (substring completion (length prefix) point))))
+ (qsuffix (funcall qfun suffix))
+ (qstring (concat (substring string 0 qpos) qstr1 qsuffix))
+ (qpoint
+ (cond
+ ((zerop point) 0)
+ ((> point (length prefix)) (+ qpos (length qstr1)))
+ (t (car (funcall requote point string))))))
+ ;; Make sure `requote' worked.
+ (assert (equal (funcall unquote qstring) completion))
+ (cons qstring qpoint)))
+
+(defun completion--string-equal-p (s1 s2)
+ (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case)))
+
+(defun completion--twq-all (string ustring completions boundary
+ unquote requote)
+ (when completions
+ (pcase-let*
+ ((prefix
+ (let ((completion-regexp-list nil))
+ (try-completion "" (cons (substring ustring boundary)
+ completions))))
+ (`(,qfullpos . ,qfun)
+ (funcall requote (+ boundary (length prefix)) string))
+ (qfullprefix (substring string 0 qfullpos))
+ (_ (assert (completion--string-equal-p
+ (funcall unquote qfullprefix)
+ (concat (substring ustring 0 boundary) prefix))
+ t))
+ (qboundary (car (funcall requote boundary string)))
+ (_ (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
+ ;; boundaries of those faces, pass them to `requote' to find their
+ ;; equivalent positions in the quoted output and re-add the faces:
+ ;; this might actually lead to correct results but would be
+ ;; pretty expensive.
+ ;; The better solution is to not quote the *Completions* display,
+ ;; which nicely circumvents the problem. The solution I used here
+ ;; instead is to hope that `qfun' preserves the text-properties and
+ ;; presume that the `first-difference' is not within the `prefix';
+ ;; this presumption is not always true, but at least in practice it is
+ ;; true in most cases.
+ (qprefix (propertize (substring qfullprefix qboundary)
+ 'face 'completions-common-part)))
+
+ ;; Here we choose to quote all elements returned, but a better option
+ ;; would be to return unquoted elements together with a function to
+ ;; requote them, so that *Completions* can show nicer unquoted values
+ ;; which only get quoted when needed by choose-completion.
+ (nconc
+ (mapcar (lambda (completion)
+ (assert (string-prefix-p prefix completion 'ignore-case) t)
+ (let* ((new (substring completion (length prefix)))
+ (qnew (funcall qfun new))
+ (qcompletion (concat qprefix qnew)))
+ (assert
+ (completion--string-equal-p
+ (funcall unquote
+ (concat (substring string 0 qboundary)
+ qcompletion))
+ (concat (substring ustring 0 boundary)
+ completion))
+ t)
+ qcompletion))
+ completions)
+ qboundary))))
+
;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
(define-obsolete-function-alias
;; is on, the field doesn't cover the entire minibuffer contents.
(delete-region (minibuffer-prompt-end) (point-max)))
+(defvar completion-show-inline-help t
+ "If non-nil, print helpful inline messages during completion.")
+
(defcustom completion-auto-help t
"Non-nil means automatically provide help for invalid completion input.
If the value is t the *Completion* buffer is displayed whenever completion
follow the calling convention of `completion-all-completions'),
and DOC describes the way this style of completion works.")
+(defconst completion--styles-type
+ `(repeat :tag "insert a new menu to add more styles"
+ (choice ,@(mapcar (lambda (x) (list 'const (car x)))
+ completion-styles-alist))))
+(defconst completion--cycling-threshold-type
+ '(choice (const :tag "No cycling" nil)
+ (const :tag "Always cycle" t)
+ (integer :tag "Threshold")))
+
(defcustom completion-styles
;; First, use `basic' because prefix completion has been the standard
;; for "ever" and works well in most cases, so using it first
;; and simply add "bar" to the end of the result.
emacs22)
"List of completion styles to use.
-The available styles are listed in `completion-styles-alist'."
- :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x)))
- completion-styles-alist)))
+The available styles are listed in `completion-styles-alist'.
+
+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")
-(defun completion-try-completion (string table pred point)
+(defcustom completion-category-overrides
+ '((buffer (styles . (basic substring))))
+ "List of `completion-styles' overrides for specific categories.
+Each override has the shape (CATEGORY . ALIST) where ALIST is
+an association list that can specify properties such as:
+- `styles': the list of `completion-styles' to use for that category.
+- `cycle': the `completion-cycle-threshold' to use for that category.
+Categories are symbols such as `buffer' and `file', used when
+completing buffer and file names, respectively."
+ :version "24.1"
+ :type `(alist :key-type (choice :tag "Category"
+ (const buffer)
+ (const file)
+ (const unicode-name)
+ symbol)
+ :value-type
+ (set :tag "Properties to override"
+ (cons :tag "Completion Styles"
+ (const :tag "Select a style from the menu;" styles)
+ ,completion--styles-type)
+ (cons :tag "Completion Cycling"
+ (const :tag "Select one value from the menu." cycle)
+ ,completion--cycling-threshold-type))))
+
+(defun completion--styles (metadata)
+ (let* ((cat (completion-metadata-get metadata 'category))
+ (over (assq 'styles (cdr (assq cat completion-category-overrides)))))
+ (if over
+ (delete-dups (append (cdr over) (copy-sequence completion-styles)))
+ completion-styles)))
+
+(defun completion--nth-completion (n string table pred point metadata)
+ "Call the Nth method of completion styles."
+ (unless metadata
+ (setq metadata
+ (completion-metadata (substring string 0 point) table pred)))
+ ;; We provide special support for quoting/unquoting here because it cannot
+ ;; reliably be done within the normal completion-table routines: Completion
+ ;; styles such as `substring' or `partial-completion' need to match the
+ ;; output of all-completions with the user's input, and since most/all
+ ;; quoting mechanisms allow several equivalent quoted forms, the
+ ;; completion-style can't do this matching (e.g. `substring' doesn't know
+ ;; that "\a\b\e" is a valid (quoted) substring of "label").
+ ;; The quote/unquote function needs to come from the completion table (rather
+ ;; than from completion-extra-properties) because it may apply only to some
+ ;; part of the string (e.g. substitute-in-file-name).
+ (let ((requote
+ (when (completion-metadata-get metadata 'completion--unquote-requote)
+ (let ((new (funcall table string point 'completion--unquote)))
+ (setq string (pop new))
+ (setq table (pop new))
+ (setq point (pop new))
+ (pop new))))
+ (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)))
+
+(defun completion-try-completion (string table pred point &optional metadata)
"Try to complete STRING using completion table TABLE.
Only the elements of table that satisfy predicate PRED are considered.
POINT is the position of point within STRING.
The return value can be either nil to indicate that there is no completion,
t to indicate that STRING is the only possible completion,
-or a pair (STRING . NEWPOINT) of the completed result string together with
+or a pair (NEWSTRING . NEWPOINT) of the completed result string together with
a new position for point."
- (completion--some (lambda (style)
- (funcall (nth 1 (assq style completion-styles-alist))
- string table pred point))
- completion-styles))
+ (completion--nth-completion 1 string table pred point metadata))
-(defun completion-all-completions (string table pred point)
+(defun completion-all-completions (string table pred point &optional metadata)
"List the possible completions of STRING in completion table TABLE.
Only the elements of table that satisfy predicate PRED are considered.
POINT is the position of point within STRING.
in the last `cdr'."
;; FIXME: We need to additionally return the info needed for the
;; second part of completion-base-position.
- (completion--some (lambda (style)
- (funcall (nth 2 (assq style completion-styles-alist))
- string table pred point))
- completion-styles))
+ (completion--nth-completion 2 string table pred point metadata))
(defun minibuffer--bitset (modified completions exact)
(logior (if modified 4 0)
(defun completion--replace (beg end newtext)
"Replace the buffer text between BEG and END with NEWTEXT.
Moves point to the end of the new text."
+ ;; The properties on `newtext' include things like
+ ;; completions-first-difference, which we don't want to include
+ ;; upon insertion.
+ (set-text-properties 0 (length newtext) nil newtext)
;; Maybe this should be in subr.el.
;; You'd think this is trivial to do, but details matter if you want
;; to keep markers "at the right place" and be robust in the face of
(setq end (- end suffix-len))
(setq newtext (substring newtext 0 (- suffix-len))))
(goto-char beg)
- (insert newtext)
+ (insert-and-inherit newtext)
(delete-region (point) (+ (point) (- end beg)))
(forward-char suffix-len)))
If t, cycling is always used.
If an integer, cycling is used as soon as there are fewer completion
candidates than this number."
- :type '(choice (const :tag "No cycling" nil)
- (const :tag "Always cycle" t)
- (integer :tag "Threshold")))
+ :version "24.1"
+ :type completion--cycling-threshold-type)
+
+(defun completion--cycle-threshold (metadata)
+ (let* ((cat (completion-metadata-get metadata 'category))
+ (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 completion-fail-discreetly nil
"If non-nil, stay quiet when there is no match.")
-(defun completion--do-completion (&optional try-completion-function)
+(defun completion--message (msg)
+ (if completion-show-inline-help
+ (minibuffer-message msg)))
+
+(defun completion--do-completion (&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.
100 4 ??? impossible
101 5 ??? impossible
110 6 some completion happened
- 111 7 completed to an exact completion"
+ 111 7 completed to an exact completion
+
+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))
+ (md (completion--field-metadata beg))
(comp (funcall (or try-completion-function
'completion-try-completion)
string
minibuffer-completion-table
minibuffer-completion-predicate
- (- (point) beg))))
+ (- (point) beg)
+ md)))
(cond
((null comp)
(minibuffer-hide-completions)
(unless completion-fail-discreetly
- (ding) (minibuffer-message "No match"))
+ (ding)
+ (completion--message "No match"))
(minibuffer--bitset nil nil nil))
((eq t comp)
(minibuffer-hide-completions)
- (goto-char (field-end))
+ (goto-char end)
+ (completion--done string 'finished
+ (unless expect-exact "Sole completion"))
(minibuffer--bitset nil nil t)) ;Exact and unique match.
(t
;; `completed' should be t if some completion was done, which doesn't
;; 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)
+ (completion--do-completion try-completion-function expect-exact)
;; It did find a match. Do we match some possibility exactly now?
- (let ((exact (test-completion completion
- minibuffer-completion-table
- minibuffer-completion-predicate))
- (comps
- ;; Check to see if we want to do cycling. We do it
- ;; here, after having performed the normal completion,
- ;; so as to take advantage of the difference between
- ;; try-completion and all-completions, for things
- ;; like completion-ignored-extensions.
- (when (and completion-cycle-threshold
- ;; Check that the completion didn't make
- ;; us jump to a different boundary.
- (or (not completed)
- (< (car (completion-boundaries
- (substring completion 0 comp-pos)
+ (let* ((exact (test-completion completion
minibuffer-completion-table
- minibuffer-completion-predicate
+ minibuffer-completion-predicate))
+ (threshold (completion--cycle-threshold md))
+ (comps
+ ;; Check to see if we want to do cycling. We do it
+ ;; here, after having performed the normal completion,
+ ;; so as to take advantage of the difference between
+ ;; try-completion and all-completions, for things
+ ;; like completion-ignored-extensions.
+ (when (and threshold
+ ;; Check that the completion didn't make
+ ;; us jump to a different boundary.
+ (or (not completed)
+ (< (car (completion-boundaries
+ (substring completion 0 comp-pos)
+ minibuffer-completion-table
+ minibuffer-completion-predicate
""))
comp-pos)))
(completion-all-sorted-completions))))
(not (ignore-errors
;; This signal an (intended) error if comps is too
;; short or if completion-cycle-threshold is t.
- (consp (nthcdr completion-cycle-threshold comps)))))
+ (consp (nthcdr threshold comps)))))
;; Fewer than completion-cycle-threshold remaining
;; completions: let's cycle.
(setq completed t exact t)
- (setq completion-all-sorted-completions comps)
+ (completion--cache-all-sorted-completions comps)
(minibuffer-force-complete))
(completed
;; We could also decide to refresh the completions,
;; if they're displayed (and assuming there are
;; completions left).
- (minibuffer-hide-completions))
+ (minibuffer-hide-completions)
+ (if exact
+ ;; If completion did not put point at end of field,
+ ;; it's a sign that completion is not finished.
+ (completion--done completion
+ (if (< comp-pos (length completion))
+ 'exact 'unknown))))
;; Show the completion table, if requested.
((not exact)
- (if (case completion-auto-help
+ (if (case completion-auto-help
(lazy (eq this-command last-command))
(t completion-auto-help))
(minibuffer-completion-help)
- (minibuffer-message "Next char not unique")))
+ (completion--message "Next char not unique")))
;; If the last exact completion and this one were the same, it
- ;; means we've already given a "Next char not unique" message
+ ;; means we've already given a "Complete, but not unique" message
;; and the user's hit TAB again, so now we give him help.
- ((eq this-command last-command)
- (if completion-auto-help (minibuffer-completion-help))))
+ (t
+ (if (and (eq this-command last-command) completion-auto-help)
+ (minibuffer-completion-help))
+ (completion--done completion 'exact
+ (unless expect-exact
+ "Complete, but not unique"))))
(minibuffer--bitset completed t exact))))))))
(interactive)
;; If the previous command was not this,
;; mark the completion buffer obsolete.
- (unless (eq this-command last-command)
+ (setq this-command 'completion-at-point)
+ (unless (eq 'completion-at-point last-command)
(completion--flush-all-sorted-completions)
(setq minibuffer-scroll-window nil))
(cond
- ;; If there's a fresh completion window with a live buffer,
- ;; and this command is repeated, scroll that window.
+ ;; If there's a fresh completion window with a live buffer,
+ ;; and this command is repeated, scroll that window.
((window-live-p minibuffer-scroll-window)
(let ((window minibuffer-scroll-window))
- (with-current-buffer (window-buffer window)
- (if (pos-visible-in-window-p (point-max) window)
- ;; 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-current-buffer (window-buffer window)
+ (if (pos-visible-in-window-p (point-max) window)
+ ;; 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))
nil)))
;; If we're cycling, keep on cycling.
((and completion-cycling completion-all-sorted-completions)
t)
(t (case (completion--do-completion)
(#b000 nil)
- (#b001 (minibuffer-message "Sole completion")
- t)
- (#b011 (minibuffer-message "Complete, but not unique")
- t)
(t t)))))
+(defun completion--cache-all-sorted-completions (comps)
+ (add-hook 'after-change-functions
+ 'completion--flush-all-sorted-completions nil t)
+ (setq completion-all-sorted-completions comps))
+
(defun completion--flush-all-sorted-completions (&rest _ignore)
+ (remove-hook 'after-change-functions
+ 'completion--flush-all-sorted-completions t)
(setq completion-cycling nil)
(setq completion-all-sorted-completions nil))
+(defun completion--metadata (string base md-at-point table pred)
+ ;; Like completion-metadata, but for the specific case of getting the
+ ;; metadata at `base', which tends to trigger pathological behavior for old
+ ;; completion tables which don't understand `metadata'.
+ (let ((bounds (completion-boundaries string table pred "")))
+ (if (eq (car bounds) base) md-at-point
+ (completion-metadata (substring string 0 base) table pred))))
+
(defun completion-all-sorted-completions ()
(or completion-all-sorted-completions
(let* ((start (field-beginning))
(end (field-end))
- (all (completion-all-completions (buffer-substring start end)
- minibuffer-completion-table
- minibuffer-completion-predicate
- (- (point) start)))
+ (string (buffer-substring start end))
+ (md (completion--field-metadata start))
+ (all (completion-all-completions
+ string
+ minibuffer-completion-table
+ minibuffer-completion-predicate
+ (- (point) start)
+ md))
(last (last all))
- (base-size (or (cdr last) 0)))
+ (base-size (or (cdr last) 0))
+ (all-md (completion--metadata (buffer-substring-no-properties
+ start (point))
+ base-size md
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
+ (sort-fun (completion-metadata-get all-md 'cycle-sort-function)))
(when last
(setcdr last nil)
- ;; Prefer shorter completions.
- (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2)))))
+ (setq all (if sort-fun (funcall sort-fun all)
+ ;; Prefer shorter completions, by default.
+ (sort all (lambda (c1 c2) (< (length c1) (length c2))))))
;; Prefer recently used completions.
- (let ((hist (symbol-value minibuffer-history-variable)))
- (setq all (sort all (lambda (c1 c2)
- (> (length (member c1 hist))
- (length (member c2 hist)))))))
+ (when (minibufferp)
+ (let ((hist (symbol-value minibuffer-history-variable)))
+ (setq all (sort all (lambda (c1 c2)
+ (> (length (member c1 hist))
+ (length (member c2 hist))))))))
;; Cache the result. This is not just for speed, but also so that
;; repeated calls to minibuffer-force-complete can cycle through
;; all possibilities.
- (add-hook 'after-change-functions
- 'completion--flush-all-sorted-completions nil t)
- (setq completion-all-sorted-completions
- (nconc all base-size))))))
+ (completion--cache-all-sorted-completions (nconc all base-size))))))
(defun minibuffer-force-complete ()
"Complete the minibuffer to an exact match.
;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
(let* ((start (field-beginning))
(end (field-end))
- (all (completion-all-sorted-completions)))
- (if (not (consp all))
- (minibuffer-message (if all "No more completions" "No completions"))
+ ;; (md (completion--field-metadata start))
+ (all (completion-all-sorted-completions))
+ (base (+ start (or (cdr (last all)) 0))))
+ (cond
+ ((not (consp all))
+ (completion--message
+ (if all "No more completions" "No completions")))
+ ((not (consp (cdr all)))
+ (let ((mod (equal (car all) (buffer-substring-no-properties base end))))
+ (if mod (completion--replace base end (car all)))
+ (completion--done (buffer-substring-no-properties start (point))
+ 'finished (unless mod "Sole completion"))))
+ (t
+ (completion--replace base end (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)
- (goto-char end)
- (insert (car all))
- (delete-region (+ start (cdr (last all))) end)
;; 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)))
- (setq completion-all-sorted-completions (cdr all))))))
+ (completion--cache-all-sorted-completions (cdr all)))))))
(defvar minibuffer-confirm-exit-commands
'(minibuffer-complete minibuffer-complete-word PC-complete PC-complete-word)
;; file, so `try-completion' actually completes to
;; that file.
(= (length string) (length compl)))
- (goto-char end)
- (insert compl)
- (delete-region beg end))))
+ (completion--replace beg end compl))))
(exit-minibuffer))
((memq minibuffer-completion-confirm '(confirm confirm-after-completion))
(t
;; Call do-completion, but ignore errors.
(case (condition-case nil
- (completion--do-completion)
+ (completion--do-completion nil 'expect-exact)
(error 1))
((#b001 #b011) (exit-minibuffer))
(#b111 (if (not minibuffer-completion-confirm)
nil))
(t nil))))))
-(defun completion--try-word-completion (string table predicate point)
- (let ((comp (completion-try-completion string table predicate point)))
+(defun completion--try-word-completion (string table predicate point md)
+ (let ((comp (completion-try-completion string table predicate point md)))
(if (not (consp comp))
comp
(while (and exts (not (consp tem)))
(setq tem (completion-try-completion
(concat before (pop exts) after)
- table predicate (1+ point))))
+ table predicate (1+ point) md)))
(if (consp tem) (setq comp tem))))
;; Completing a single word is actually more difficult than completing
(interactive)
(case (completion--do-completion 'completion--try-word-completion)
(#b000 nil)
- (#b001 (minibuffer-message "Sole completion")
- t)
- (#b011 (minibuffer-message "Complete, but not unique")
- t)
(t t)))
(defface completions-annotations '((t :inherit italic))
(column 0)
(rows (/ (length strings) columns))
(row 0)
+ (first t)
(laststring nil))
;; The insertion should be "sensible" no matter what choices were made
;; for the parameters above.
(dolist (str strings)
(unless (equal laststring str) ; Remove (consecutive) duplicates.
(setq laststring str)
+ ;; FIXME: `string-width' doesn't pay attention to
+ ;; `display' properties.
(let ((length (if (consp str)
(+ (string-width (car str))
(string-width (cadr str)))
(forward-line 1)
(end-of-line)))
(insert " \t")
- (set-text-properties (- (point) 1) (point)
+ (set-text-properties (1- (point)) (point)
`(display (space :align-to ,column)))))
(t
;; Horizontal format
- (unless (bolp)
+ (unless first
(if (< wwidth (+ (max colwidth length) column))
;; No space for `str' at point, move to next line.
(progn (insert "\n") (setq column 0))
;; Leave the space unpropertized so that in the case we're
;; already past the goal column, there is still
;; a space displayed.
- (set-text-properties (- (point) 1) (point)
+ (set-text-properties (1- (point)) (point)
;; We can't just set tab-width, because
- ;; completion-setup-function will kill all
- ;; local variables :-(
+ ;; completion-setup-function will kill
+ ;; all local variables :-(
`(display (space :align-to ,column)))
nil))))
+ (setq first nil)
(if (not (consp str))
(put-text-property (point) (progn (insert str) (point))
'mouse-face 'highlight)
'mouse-face 'highlight)
(add-text-properties (point) (progn (insert (cadr str)) (point))
'(mouse-face nil
- face completions-annotations)))
+ face completions-annotations)))
(cond
((eq completions-format 'vertical)
;; Vertical format
(run-hooks 'completion-setup-hook)))
nil)
+(defvar completion-extra-properties nil
+ "Property list of extra properties of the current completion job.
+These include:
+
+`:annotation-function': Function to annotate the completions buffer.
+ The function must accept one argument, a completion string,
+ and return either nil or a string which is to be displayed
+ next to the completion (but which is not part of the
+ completion). The function can access the completion data via
+ `minibuffer-completion-table' and related variables.
+
+`:exit-function': Function to run after completion is performed.
+
+ The function must accept two arguments, STRING and STATUS.
+ STRING is the text to which the field was completed, and
+ STATUS indicates what kind of operation happened:
+ `finished' - text is now complete
+ `sole' - text cannot be further completed but
+ completion is not finished
+ `exact' - text is a valid completion but may be further
+ completed.")
+
(defvar completion-annotate-function
nil
;; Note: there's a lot of scope as for when to add annotations and
will be displayed next to the completion. The function can access the
completion table and predicates via `minibuffer-completion-table' and related
variables.")
+(make-obsolete-variable 'completion-annotate-function
+ 'completion-extra-properties "24.1")
+
+(defun completion--done (string &optional finished message)
+ (let* ((exit-fun (plist-get completion-extra-properties :exit-function))
+ (pre-msg (and exit-fun (current-message))))
+ (assert (memq finished '(exact sole finished unknown)))
+ ;; FIXME: exit-fun should receive `finished' as a parameter.
+ (when exit-fun
+ (when (eq finished 'unknown)
+ (setq finished
+ (if (eq (try-completion string
+ minibuffer-completion-table
+ minibuffer-completion-predicate)
+ t)
+ 'finished 'exact)))
+ (funcall exit-fun string finished))
+ (when (and message
+ ;; Don't output any message if the exit-fun already did so.
+ (equal pre-msg (and exit-fun (current-message))))
+ (completion--message message))))
(defun minibuffer-completion-help ()
"Display a list of possible completions of the current minibuffer contents."
(let* ((start (field-beginning))
(end (field-end))
(string (field-string))
+ (md (completion--field-metadata start))
(completions (completion-all-completions
string
minibuffer-completion-table
minibuffer-completion-predicate
- (- (point) (field-beginning)))))
+ (- (point) (field-beginning))
+ md)))
(message nil)
- (if (and completions
- (or (consp (cdr completions))
- (not (equal (car completions) string))))
- (let* ((last (last completions))
- (base-size (cdr last))
- ;; If the *Completions* buffer is shown in a new
- ;; window, mark it as softly-dedicated, so bury-buffer in
- ;; minibuffer-hide-completions will know whether to
- ;; delete the window or not.
- (display-buffer-mark-dedicated 'soft))
- (with-output-to-temp-buffer "*Completions*"
- ;; Remove the base-size tail because `sort' requires a properly
- ;; nil-terminated list.
- (when last (setcdr last nil))
- (setq completions (sort completions 'string-lessp))
- (when completion-annotate-function
- (setq completions
- (mapcar (lambda (s)
- (let ((ann
- (funcall completion-annotate-function s)))
- (if ann (list s ann) s)))
- completions)))
- (with-current-buffer standard-output
- (set (make-local-variable 'completion-base-position)
- (list (+ start base-size)
- ;; FIXME: We should pay attention to completion
- ;; boundaries here, but currently
- ;; completion-all-completions does not give us the
- ;; necessary information.
- end)))
- (display-completion-list completions)))
-
- ;; If there are no completions, or if the current input is already the
- ;; only possible completion, then hide (previous&stale) completions.
- (minibuffer-hide-completions)
- (ding)
- (minibuffer-message
- (if completions "Sole completion" "No completions")))
+ (if (or (null completions)
+ (and (not (consp (cdr completions)))
+ (equal (car completions) string)))
+ (progn
+ ;; If there are no completions, or if the current input is already
+ ;; the sole completion, then hide (previous&stale) completions.
+ (minibuffer-hide-completions)
+ (ding)
+ (minibuffer-message
+ (if completions "Sole completion" "No completions")))
+
+ (let* ((last (last completions))
+ (base-size (cdr last))
+ (prefix (unless (zerop base-size) (substring string 0 base-size)))
+ (all-md (completion--metadata (buffer-substring-no-properties
+ start (point))
+ base-size md
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
+ (afun (or (completion-metadata-get all-md 'annotation-function)
+ (plist-get completion-extra-properties
+ :annotation-function)
+ completion-annotate-function))
+ ;; If the *Completions* buffer is shown in a new
+ ;; window, mark it as softly-dedicated, so bury-buffer in
+ ;; minibuffer-hide-completions will know whether to
+ ;; delete the window or not.
+ (display-buffer-mark-dedicated 'soft))
+ (with-output-to-temp-buffer "*Completions*"
+ ;; Remove the base-size tail because `sort' requires a properly
+ ;; nil-terminated list.
+ (when last (setcdr last nil))
+ (setq completions
+ ;; FIXME: This function is for the output of all-completions,
+ ;; not completion-all-completions. Often it's the same, but
+ ;; not always.
+ (let ((sort-fun (completion-metadata-get
+ all-md 'display-sort-function)))
+ (if sort-fun
+ (funcall sort-fun completions)
+ (sort completions 'string-lessp))))
+ (when afun
+ (setq completions
+ (mapcar (lambda (s)
+ (let ((ann (funcall afun s)))
+ (if ann (list s ann) s)))
+ completions)))
+
+ (with-current-buffer standard-output
+ (set (make-local-variable 'completion-base-position)
+ (list (+ start base-size)
+ ;; FIXME: We should pay attention to completion
+ ;; boundaries here, but currently
+ ;; completion-all-completions does not give us the
+ ;; necessary information.
+ end))
+ (set (make-local-variable 'completion-list-insert-choice-function)
+ (let ((ctable minibuffer-completion-table)
+ (cpred minibuffer-completion-predicate)
+ (cprops completion-extra-properties))
+ (lambda (start end choice)
+ (unless (or (zerop (length prefix))
+ (equal prefix
+ (buffer-substring-no-properties
+ (max (point-min)
+ (- start (length prefix)))
+ start)))
+ (message "*Completions* out of date"))
+ ;; FIXME: Use `md' to do quoting&terminator here.
+ (completion--replace start end choice)
+ (let* ((minibuffer-completion-table ctable)
+ (minibuffer-completion-predicate cpred)
+ (completion-extra-properties cprops)
+ (result (concat prefix choice))
+ (bounds (completion-boundaries
+ result ctable cpred "")))
+ ;; If the completion introduces a new field, then
+ ;; completion is not finished.
+ (completion--done result
+ (if (eq (car bounds) (length result))
+ 'exact 'finished)))))))
+
+ (display-completion-list completions))))
nil))
(defun minibuffer-hide-completions ()
are expected to perform completion on START..END using COLLECTION
and PREDICATE, either by calling NEXT-FUN or by doing it themselves.")
+(defvar completion-in-region--data nil)
+
+(defvar completion-in-region-mode-predicate nil
+ "Predicate to tell `completion-in-region-mode' when to exit.
+It is called with no argument and should return nil when
+`completion-in-region-mode' should exit (and hence pop down
+the *Completions* buffer).")
+
+(defvar completion-in-region-mode--predicate nil
+ "Copy of the value of `completion-in-region-mode-predicate'.
+This holds the value `completion-in-region-mode-predicate' had when
+we entered `completion-in-region-mode'.")
+
(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."
+Point needs to be somewhere between START and END.
+PREDICATE (a function called with no arguments) says when to
+exit."
(assert (<= start (point)) (<= (point) end))
- ;; FIXME: undisplay the *Completions* buffer once the completion is done.
(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)
+ ;; 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 (current-buffer) start end collection)))
(unwind-protect
(call-interactively 'minibuffer-complete)
(delete-overlay ol)))))
+(defvar completion-in-region-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; FIXME: Only works if completion-in-region-mode was activated via
+ ;; completion-at-point called directly.
+ (define-key map "\M-?" 'completion-help-at-point)
+ (define-key map "\t" 'completion-at-point)
+ map)
+ "Keymap activated during `completion-in-region'.")
+
+;; It is difficult to know when to exit completion-in-region-mode (i.e. hide
+;; the *Completions*).
+;; - 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.
+;; - semantic: use a post-command-hook check similar to this one.
+(defun completion-in-region--postch ()
+ (or unread-command-events ;Don't pop down the completions in the middle of
+ ;mouse-drag-region/mouse-set-point.
+ (and completion-in-region--data
+ (and (eq (car completion-in-region--data)
+ (current-buffer))
+ (>= (point) (nth 1 completion-in-region--data))
+ (<= (point)
+ (save-excursion
+ (goto-char (nth 2 completion-in-region--data))
+ (line-end-position)))
+ (funcall completion-in-region-mode--predicate)))
+ (completion-in-region-mode -1)))
+
+;; (defalias 'completion-in-region--prech 'completion-in-region--postch)
+
+(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."
+ :global t
+ (setq completion-in-region--data nil)
+ ;; (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))
+ ;; (add-hook 'pre-command-hook #'completion-in-region--prech)
+ (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)
+ (push `(completion-in-region-mode . ,completion-in-region-mode-map)
+ minor-mode-overriding-map-alist)))
+
+;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it
+;; on minor-mode-overriding-map-alist instead.
+(setq minor-mode-map-alist
+ (delq (assq 'completion-in-region-mode minor-mode-map-alist)
+ minor-mode-map-alist))
+
(defvar completion-at-point-functions '(tags-completion-at-point-function)
"Special hook to find the completion table for the thing at point.
-It is called without any argument and should return either nil,
+Each function on this hook is called in turns without any argument and should
+return either nil to mean that it is not applicable at point,
or a function of no argument to perform completion (discouraged),
-or a list of the form (START END COLLECTION &rest PROPS) where
+or a list of the form (START END COLLECTION . PROPS) where
START and END delimit the entity to complete and should include point,
COLLECTION is the completion table to use to complete it, and
PROPS is a property list for additional information.
-Currently supported properties are:
- `:predicate' a predicate that completion candidates need to satisfy.
- `:annotation-function' the value to use for `completion-annotate-function'.")
+Currently supported properties are all the properties that can appear in
+`completion-extra-properties' plus:
+ `:predicate' a predicate that completion candidates need to satisfy.
+ `:exclusive' If `no', means that if the completion table fails to
+ match the text at point, then instead of reporting a completion
+ failure, the completion should try the next completion function.")
+
+(defvar completion--capf-misbehave-funs nil
+ "List of functions found on `completion-at-point-functions' that misbehave.
+These are functions that neither return completion data nor a completion
+function but instead perform completion right away.")
+(defvar completion--capf-safe-funs nil
+ "List of well-behaved functions found on `completion-at-point-functions'.
+These are functions which return proper completion data rather than
+a completion function or god knows what else.")
+
+(defun completion--capf-wrapper (fun which)
+ ;; FIXME: The safe/misbehave handling assumes that a given function will
+ ;; always return the same kind of data, but this breaks down with functions
+ ;; like comint-completion-at-point or mh-letter-completion-at-point, which
+ ;; could be sometimes safe and sometimes misbehaving (and sometimes neither).
+ (if (case which
+ (all t)
+ (safe (member fun completion--capf-safe-funs))
+ (optimist (not (member fun completion--capf-misbehave-funs))))
+ (let ((res (funcall fun)))
+ (cond
+ ((and (consp res) (not (functionp res)))
+ (unless (member fun completion--capf-safe-funs)
+ (push fun completion--capf-safe-funs))
+ (and (eq 'no (plist-get (nthcdr 3 res) :exclusive))
+ ;; FIXME: Here we'd need to decide whether there are
+ ;; valid completions against the current text. But this depends
+ ;; on the actual completion UI (e.g. with the default completion
+ ;; it depends on completion-style) ;-(
+ ;; We approximate this result by checking whether prefix
+ ;; completion might work, which means that non-prefix completion
+ ;; will not work (or not right) for completion functions that
+ ;; are non-exclusive.
+ (null (try-completion (buffer-substring-no-properties
+ (car res) (point))
+ (nth 2 res)
+ (plist-get (nthcdr 3 res) :predicate)))
+ (setq res nil)))
+ ((not (or (listp res) (functionp res)))
+ (unless (member fun completion--capf-misbehave-funs)
+ (message
+ "Completion function %S uses a deprecated calling convention" fun)
+ (push fun completion--capf-misbehave-funs))))
+ (if res (cons fun res)))))
(defun completion-at-point ()
"Perform completion on the text around point.
The completion method is determined by `completion-at-point-functions'."
(interactive)
- (let ((res (run-hook-with-args-until-success
- 'completion-at-point-functions)))
- (cond
- ((functionp res) (funcall res))
- (res
- (let* ((plist (nthcdr 3 res))
- (start (nth 0 res))
- (end (nth 1 res))
- (completion-annotate-function
- (or (plist-get plist :annotation-function)
- completion-annotate-function)))
- (completion-in-region start end (nth 2 res)
- (plist-get plist :predicate)))))))
+ (let ((res (run-hook-wrapped 'completion-at-point-functions
+ #'completion--capf-wrapper 'all)))
+ (pcase res
+ (`(,_ . ,(and (pred functionp) f)) (funcall f))
+ (`(,hookfun . (,start ,end ,collection . ,plist))
+ (let* ((completion-extra-properties plist)
+ (completion-in-region-mode-predicate
+ (lambda ()
+ ;; We're still in the same completion field.
+ (eq (car-safe (funcall hookfun)) start))))
+ (completion-in-region start end collection
+ (plist-get plist :predicate))))
+ ;; Maybe completion already happened and the function returned t.
+ (_ (cdr res)))))
+
+(defun completion-help-at-point ()
+ "Display the completions on the text around point.
+The completion method is determined by `completion-at-point-functions'."
+ (interactive)
+ (let ((res (run-hook-wrapped 'completion-at-point-functions
+ ;; Ignore misbehaving functions.
+ #'completion--capf-wrapper 'optimist)))
+ (pcase res
+ (`(,_ . ,(and (pred functionp) f))
+ (message "Don't know how to show completions for %S" f))
+ (`(,hookfun . (,start ,end ,collection . ,plist))
+ (let* ((minibuffer-completion-table collection)
+ (minibuffer-completion-predicate (plist-get plist :predicate))
+ (completion-extra-properties plist)
+ (completion-in-region-mode-predicate
+ (lambda ()
+ ;; We're still in the same completion field.
+ (eq (car-safe (funcall hookfun)) start)))
+ (ol (make-overlay start end nil nil t)))
+ ;; 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 (current-buffer) start end collection))
+ (unwind-protect
+ (call-interactively 'minibuffer-completion-help)
+ (delete-overlay ol))))
+ (`(,hookfun . ,_)
+ ;; The hook function already performed completion :-(
+ ;; Not much we can do at this point.
+ (message "%s already performed completion!" hookfun)
+ nil)
+ (_ (message "Nothing to complete at point")))))
;;; Key bindings.
-(define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map
- 'minibuffer-local-filename-must-match-map "23.1")
-
(let ((map minibuffer-local-map))
(define-key map "\C-g" 'abort-recursive-edit)
(define-key map "\r" 'exit-minibuffer)
(define-key map "\n" 'exit-minibuffer))
-(let ((map minibuffer-local-completion-map))
- (define-key map "\t" 'minibuffer-complete)
- ;; M-TAB is already abused for many other purposes, so we should find
- ;; another binding for it.
- ;; (define-key map "\e\t" 'minibuffer-force-complete)
- (define-key map " " 'minibuffer-complete-word)
- (define-key map "?" 'minibuffer-completion-help))
-
-(let ((map minibuffer-local-must-match-map))
- (define-key map "\r" 'minibuffer-complete-and-exit)
- (define-key map "\n" 'minibuffer-complete-and-exit))
+(defvar minibuffer-local-completion-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map "\t" 'minibuffer-complete)
+ ;; M-TAB is already abused for many other purposes, so we should find
+ ;; another binding for it.
+ ;; (define-key map "\e\t" 'minibuffer-force-complete)
+ (define-key map " " 'minibuffer-complete-word)
+ (define-key map "?" 'minibuffer-completion-help)
+ map)
+ "Local keymap for minibuffer input with completion.")
+
+(defvar minibuffer-local-must-match-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-completion-map)
+ (define-key map "\r" 'minibuffer-complete-and-exit)
+ (define-key map "\n" 'minibuffer-complete-and-exit)
+ map)
+ "Local keymap for minibuffer input with completion, for exact match.")
+
+(defvar minibuffer-local-filename-completion-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map " " nil)
+ map)
+ "Local keymap for minibuffer input with completion for filenames.
+Gets combined either with `minibuffer-local-completion-map' or
+with `minibuffer-local-must-match-map'.")
-(let ((map minibuffer-local-filename-completion-map))
- (define-key map " " nil))
-(let ((map minibuffer-local-filename-must-match-map))
- (define-key map " " nil))
+(define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map
+ 'minibuffer-local-filename-must-match-map "23.1")
+(defvar minibuffer-local-filename-must-match-map (make-sparse-keymap))
+(make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1")
(let ((map minibuffer-local-ns-map))
(define-key map " " 'exit-minibuffer)
(define-key map "\t" 'exit-minibuffer)
(define-key map "?" 'self-insert-and-exit))
+(defvar minibuffer-inactive-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map "e" 'find-file-other-frame)
+ (define-key map "f" 'find-file-other-frame)
+ (define-key map "b" 'switch-to-buffer-other-frame)
+ (define-key map "i" 'info)
+ (define-key map "m" 'mail)
+ (define-key map "n" 'make-frame)
+ (define-key map [mouse-1] (lambda () (interactive)
+ (with-current-buffer "*Messages*"
+ (goto-char (point-max))
+ (display-buffer (current-buffer)))))
+ ;; So the global down-mouse-1 binding doesn't clutter the execution of the
+ ;; above mouse-1 binding.
+ (define-key map [down-mouse-1] #'ignore)
+ map)
+ "Keymap for use in the minibuffer when it is not active.
+The non-mouse bindings in this keymap can only be used in minibuffer-only
+frames, since the minibuffer can normally not be selected when it is
+not active.")
+
+(define-derived-mode minibuffer-inactive-mode nil "InactiveMinibuffer"
+ :abbrev-table nil ;abbrev.el is not loaded yet during dump.
+ ;; Note: this major mode is called from minibuf.c.
+ "Major mode to use in the minibuffer when it is not active.
+This is only used when the minibuffer area has no active minibuffer.")
+
;;; Completion tables.
(defun minibuffer--double-dollars (str)
- (replace-regexp-in-string "\\$" "$$" str))
+ ;; Reuse the actual "$" from the string to preserve any text-property it
+ ;; might have, such as `face'.
+ (replace-regexp-in-string "\\$" (lambda (dollar) (concat dollar dollar))
+ str))
(defun completion--make-envvar-table ()
(mapcar (lambda (enventry)
;; other table that provides the "main" completion. Let the
;; other table handle the test-completion case.
nil)
- ((eq (car-safe action) 'boundaries)
- ;; Only return boundaries if there's something to complete,
- ;; since otherwise when we're used in
- ;; completion-table-in-turn, we could return boundaries and
- ;; let some subsequent table return a list of completions.
- ;; FIXME: Maybe it should rather be fixed in
- ;; completion-table-in-turn instead, but it's difficult to
- ;; do it efficiently there.
+ ((or (eq (car-safe action) 'boundaries) (eq action 'metadata))
+ ;; Only return boundaries/metadata if there's something to complete,
+ ;; since otherwise when we're used in
+ ;; completion-table-in-turn, we could return boundaries and
+ ;; let some subsequent table return a list of completions.
+ ;; FIXME: Maybe it should rather be fixed in
+ ;; completion-table-in-turn instead, but it's difficult to
+ ;; do it efficiently there.
(when (try-completion (substring string beg) table nil)
- ;; Compute the boundaries of the subfield to which this
- ;; completion applies.
+ ;; Compute the boundaries of the subfield to which this
+ ;; completion applies.
+ (if (eq action 'metadata)
+ '(metadata (category . environment-variable))
(let ((suffix (cdr action)))
(list* 'boundaries
(or (match-beginning 2) (match-beginning 1))
(when (string-match "[^[:alnum:]_]" suffix)
- (match-beginning 0))))))
+ (match-beginning 0)))))))
(t
(if (eq (aref string (1- beg)) ?{)
(setq table (apply-partially 'completion-table-with-terminator
(defun completion-file-name-table (string pred action)
"Completion table for file names."
- (ignore-errors
- (cond
- ((eq (car-safe action) 'boundaries)
- (let ((start (length (file-name-directory string)))
- (end (string-match-p "/" (cdr action))))
- (list* 'boundaries
- ;; if `string' is "C:" in w32, (file-name-directory string)
- ;; returns "C:/", so `start' is 3 rather than 2.
- ;; Not quite sure what is The Right Fix, but clipping it
- ;; back to 2 will work for this particular case. We'll
- ;; see if we can come up with a better fix when we bump
- ;; into more such problematic cases.
- (min start (length string)) end)))
-
- ((eq action 'lambda)
- (if (zerop (length string))
- nil ;Not sure why it's here, but it probably doesn't harm.
- (funcall (or pred 'file-exists-p) string)))
+ (condition-case nil
+ (cond
+ ((eq action 'metadata) '(metadata (category . file)))
+ ((string-match-p "\\`~[^/\\]*\\'" string)
+ (completion-table-with-context "~"
+ (mapcar (lambda (u) (concat u "/"))
+ (system-users))
+ (substring string 1)
+ pred action))
+ ((eq (car-safe action) 'boundaries)
+ (let ((start (length (file-name-directory string)))
+ (end (string-match-p "/" (cdr action))))
+ (list* 'boundaries
+ ;; if `string' is "C:" in w32, (file-name-directory string)
+ ;; returns "C:/", so `start' is 3 rather than 2.
+ ;; Not quite sure what is The Right Fix, but clipping it
+ ;; back to 2 will work for this particular case. We'll
+ ;; see if we can come up with a better fix when we bump
+ ;; into more such problematic cases.
+ (min start (length string)) end)))
- (t
- (let* ((name (file-name-nondirectory string))
- (specdir (file-name-directory string))
- (realdir (or specdir default-directory)))
+ ((eq action 'lambda)
+ (if (zerop (length string))
+ nil ;Not sure why it's here, but it probably doesn't harm.
+ (funcall (or pred 'file-exists-p) string)))
- (cond
- ((null action)
- (let ((comp (file-name-completion name realdir pred)))
- (if (stringp comp)
- (concat specdir comp)
- comp)))
-
- ((eq action t)
- (let ((all (file-name-all-completions name realdir)))
-
- ;; Check the predicate, if necessary.
- (unless (memq pred '(nil file-exists-p))
- (let ((comp ())
- (pred
- (if (eq pred 'file-directory-p)
- ;; Brute-force speed up for directory checking:
- ;; Discard strings which don't end in a slash.
- (lambda (s)
- (let ((len (length s)))
- (and (> len 0) (eq (aref s (1- len)) ?/))))
- ;; Must do it the hard (and slow) way.
- pred)))
- (let ((default-directory (expand-file-name realdir)))
- (dolist (tem all)
- (if (funcall pred tem) (push tem comp))))
- (setq all (nreverse comp))))
-
- all))))))))
+ (t
+ (let* ((name (file-name-nondirectory string))
+ (specdir (file-name-directory string))
+ (realdir (or specdir default-directory)))
+
+ (cond
+ ((null action)
+ (let ((comp (file-name-completion name realdir pred)))
+ (if (stringp comp)
+ (concat specdir comp)
+ comp)))
+
+ ((eq action t)
+ (let ((all (file-name-all-completions name realdir)))
+
+ ;; Check the predicate, if necessary.
+ (unless (memq pred '(nil file-exists-p))
+ (let ((comp ())
+ (pred
+ (if (eq pred 'file-directory-p)
+ ;; Brute-force speed up for directory checking:
+ ;; Discard strings which don't end in a slash.
+ (lambda (s)
+ (let ((len (length s)))
+ (and (> len 0) (eq (aref s (1- len)) ?/))))
+ ;; Must do it the hard (and slow) way.
+ pred)))
+ (let ((default-directory (expand-file-name realdir)))
+ (dolist (tem all)
+ (if (funcall pred tem) (push tem comp))))
+ (setq all (nreverse comp))))
+
+ all))))))
+ (file-error nil))) ;PCM often calls with invalid directories.
(defvar read-file-name-predicate nil
"Current predicate used by `read-file-name-internal'.")
(make-obsolete-variable 'read-file-name-predicate
"use the regular PRED argument" "23.2")
-(defun completion--file-name-table (string pred action)
+(defun completion--sifn-requote (upos qstr)
+ ;; We're looking for `qupos' such that:
+ ;; (equal (substring (substitute-in-file-name qstr) 0 upos)
+ ;; (substitute-in-file-name (substring qstr 0 qupos)))
+ ;; Big problem here: we have to reverse engineer substitute-in-file-name to
+ ;; find the position corresponding to UPOS in QSTR, but
+ ;; substitute-in-file-name can do anything, depending on file-name-handlers.
+ ;; Kind of like in rfn-eshadow-update-overlay, only worse.
+ (let ((qpos 0))
+ ;; Handle substitute-in-file-name's truncation behavior.
+ (let (tpos)
+ (while (and (string-match "[\\/][~/\\]" qstr qpos)
+ ;; Hopefully our regexp covers all truncation cases.
+ ;; Also let's make sure sifn indeed truncates here.
+ (progn
+ (setq tpos (1+ (match-beginning 0)))
+ (equal (substitute-in-file-name qstr)
+ (substitute-in-file-name (substring qstr tpos)))))
+ (setq qpos tpos)))
+ ;; `upos' is relative to the position corresponding to `qpos' in
+ ;; (substitute-in-file-name qstr), so as qpos moves forward, upos
+ ;; gets smaller.
+ (while (and (> upos 0)
+ (string-match "\\$\\(\\$\\|\\([[:alnum:]_]+\\|{[^}]*}\\)\\)?"
+ qstr qpos))
+ (cond
+ ((>= (- (match-beginning 0) qpos) upos) ; UPOS is before current match.
+ (setq qpos (+ qpos upos))
+ (setq upos 0))
+ ((not (match-end 1)) ;A sole $: probably an error.
+ (setq upos (- upos (- (match-end 0) qpos)))
+ (setq qpos (match-end 0)))
+ (t
+ (setq upos (- upos (- (match-beginning 0) qpos)))
+ (setq qpos (match-end 0))
+ (setq upos (- upos (length (substitute-in-file-name
+ (match-string 0 qstr))))))))
+ ;; If `upos' is negative, it's because it's within the expansion of an
+ ;; envvar, i.e. there is no exactly matching qpos, so we just use the next
+ ;; available qpos right after the envvar.
+ (cons (if (>= upos 0) (+ qpos upos) qpos)
+ #'minibuffer--double-dollars)))
+
+(defalias 'completion--file-name-table
+ (completion-table-with-quoting #'completion-file-name-table
+ #'substitute-in-file-name
+ #'completion--sifn-requote)
"Internal subroutine for `read-file-name'. Do not call this.
This is a completion table for file names, like `completion-file-name-table'
-except that it passes the file name through `substitute-in-file-name'."
- (cond
- ((eq (car-safe action) 'boundaries)
- ;; For the boundaries, we can't really delegate to
- ;; substitute-in-file-name+completion-file-name-table and then fix
- ;; them up (as we do for the other actions), because it would
- ;; require us to track the relationship between `str' and
- ;; `string', which is difficult. And in any case, if
- ;; substitute-in-file-name turns "fo-$TO-ba" into "fo-o/b-ba",
- ;; there's no way for us to return proper boundaries info, because
- ;; the boundary is not (yet) in `string'.
- ;;
- ;; FIXME: Actually there is a way to return correct boundaries
- ;; info, at the condition of modifying the all-completions
- ;; return accordingly. But for now, let's not bother.
- (completion-file-name-table string pred action))
-
- (t
- (let* ((default-directory
- (if (stringp pred)
- ;; It used to be that `pred' was abused to pass `dir'
- ;; as an argument.
- (prog1 (file-name-as-directory (expand-file-name pred))
- (setq pred nil))
- default-directory))
- (str (condition-case nil
- (substitute-in-file-name string)
- (error string)))
- (comp (completion-file-name-table
- str
- (with-no-warnings (or pred read-file-name-predicate))
- action)))
-
- (cond
- ((stringp comp)
- ;; Requote the $s before returning the completion.
- (minibuffer--double-dollars comp))
- ((and (null action) comp
- ;; Requote the $s before checking for changes.
- (setq str (minibuffer--double-dollars str))
- (not (string-equal string str)))
- ;; If there's no real completion, but substitute-in-file-name
- ;; changed the string, then return the new string.
- str)
- (t comp))))))
+except that it passes the file name through `substitute-in-file-name'.")
(defalias 'read-file-name-internal
- (completion-table-in-turn 'completion--embedded-envvar-table
- 'completion--file-name-table)
+ (completion-table-in-turn #'completion--embedded-envvar-table
+ #'completion--file-name-table)
"Internal subroutine for `read-file-name'. Do not call this.")
-(defvar read-file-name-function nil
- "If this is non-nil, `read-file-name' does its work by calling this function.")
+(defvar read-file-name-function 'read-file-name-default
+ "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))
(declare-function x-file-dialog "xfns.c"
(prompt dir &optional default-filename mustmatch only-dir-p))
-(defun read-file-name-defaults (&optional dir initial)
+(defun read-file-name--defaults (&optional dir initial)
(let ((default
(cond
;; With non-nil `initial', use `dir' as the first default.
If this command was invoked with the mouse, use a graphical file
dialog if `use-dialog-box' is non-nil, and the window system or X
toolkit in use provides a file dialog box, and DIR is not a
-remote file. For graphical file dialogs, any the special values
-of MUSTMATCH; `confirm' and `confirm-after-completion' are
-treated as equivalent to nil.
+remote file. For graphical file dialogs, any of the special values
+of MUSTMATCH `confirm' and `confirm-after-completion' are
+treated as equivalent to nil. Some graphical file dialogs respect
+a MUSTMATCH value of t, and some do not (or it only has a cosmetic
+effect, and does not actually prevent the user from entering a
+non-existent file).
See also `read-file-name-completion-ignore-case'
and `read-file-name-function'."
+ ;; If x-gtk-use-old-file-dialog = t (xg_get_file_with_selection),
+ ;; then MUSTMATCH is enforced. But with newer Gtk
+ ;; (xg_get_file_with_chooser), it only has a cosmetic effect.
+ ;; The user can still type a non-existent file name.
+ (funcall (or read-file-name-function #'read-file-name-default)
+ prompt dir default-filename mustmatch initial predicate))
+
+(defvar minibuffer-local-filename-syntax
+ (let ((table (make-syntax-table))
+ (punctuation (car (string-to-syntax "."))))
+ ;; Convert all punctuation entries to symbol.
+ (map-char-table (lambda (c syntax)
+ (when (eq (car syntax) punctuation)
+ (modify-syntax-entry c "_" table)))
+ table)
+ (mapc
+ (lambda (c)
+ (modify-syntax-entry c "." table))
+ '(?/ ?: ?\\))
+ table)
+ "Syntax table to be used in minibuffer for reading file name.")
+
+;; minibuffer-completing-file-name is a variable used internally in minibuf.c
+;; to determine whether to use minibuffer-local-filename-completion-map or
+;; minibuffer-local-completion-map. It shouldn't be exported to Elisp.
+;; FIXME: Actually, it is also used in rfn-eshadow.el we'd otherwise have to
+;; use (eq minibuffer-completion-table #'read-file-name-internal), which is
+;; probably even worse. Maybe We should add some read-file-name-setup-hook
+;; instead, but for now, let's keep this non-obsolete.
+;;(make-obsolete-variable 'minibuffer-completing-file-name nil "future" 'get)
+
+(defun read-file-name-default (prompt &optional dir default-filename mustmatch initial predicate)
+ "Default method for reading file names.
+See `read-file-name' for the meaning of the arguments."
(unless dir (setq dir default-directory))
(unless (file-name-absolute-p dir) (setq dir (expand-file-name dir)))
(unless default-filename
(minibuffer--double-dollars dir)))
(initial (cons (minibuffer--double-dollars initial) 0)))))
- (if read-file-name-function
- (funcall read-file-name-function
- prompt dir default-filename mustmatch initial predicate)
- (let ((completion-ignore-case read-file-name-completion-ignore-case)
- (minibuffer-completing-file-name t)
- (pred (or predicate 'file-exists-p))
- (add-to-history nil))
-
- (let* ((val
- (if (or (not (next-read-file-uses-dialog-p))
- ;; Graphical file dialogs can't handle remote
- ;; files (Bug#99).
- (file-remote-p dir))
- ;; We used to pass `dir' to `read-file-name-internal' by
- ;; abusing the `predicate' argument. It's better to
- ;; just use `default-directory', but in order to avoid
- ;; changing `default-directory' in the current buffer,
- ;; we don't let-bind it.
- (let ((dir (file-name-as-directory
- (expand-file-name dir))))
- (minibuffer-with-setup-hook
- (lambda ()
- (setq default-directory dir)
- ;; When the first default in `minibuffer-default'
- ;; duplicates initial input `insdef',
- ;; reset `minibuffer-default' to nil.
- (when (equal (or (car-safe insdef) insdef)
- (or (car-safe minibuffer-default)
- minibuffer-default))
- (setq minibuffer-default
- (cdr-safe minibuffer-default)))
- ;; On the first request on `M-n' fill
- ;; `minibuffer-default' with a list of defaults
- ;; relevant for file-name reading.
- (set (make-local-variable 'minibuffer-default-add-function)
- (lambda ()
- (with-current-buffer
- (window-buffer (minibuffer-selected-window))
- (read-file-name-defaults dir initial)))))
- (completing-read prompt 'read-file-name-internal
- pred mustmatch insdef
- 'file-name-history default-filename)))
- ;; If DEFAULT-FILENAME not supplied and DIR contains
- ;; a file name, split it.
- (let ((file (file-name-nondirectory dir))
- ;; When using a dialog, revert to nil and non-nil
- ;; interpretation of mustmatch. confirm options
- ;; need to be interpreted as nil, otherwise
- ;; it is impossible to create new files using
- ;; dialogs with the default settings.
- (dialog-mustmatch
- (not (memq mustmatch
- '(nil confirm confirm-after-completion)))))
- (when (and (not default-filename)
- (not (zerop (length file))))
- (setq default-filename file)
- (setq dir (file-name-directory dir)))
- (when default-filename
- (setq default-filename
- (expand-file-name (if (consp default-filename)
- (car default-filename)
- default-filename)
- dir)))
- (setq add-to-history t)
- (x-file-dialog prompt dir default-filename
- dialog-mustmatch
- (eq predicate 'file-directory-p)))))
-
- (replace-in-history (eq (car-safe file-name-history) val)))
- ;; If completing-read returned the inserted default string itself
- ;; (rather than a new string with the same contents),
- ;; it has to mean that the user typed RET with the minibuffer empty.
- ;; In that case, we really want to return ""
- ;; so that commands such as set-visited-file-name can distinguish.
- (when (consp default-filename)
- (setq default-filename (car default-filename)))
- (when (eq val default-filename)
- ;; In this case, completing-read has not added an element
- ;; to the history. Maybe we should.
- (if (not replace-in-history)
- (setq add-to-history t))
- (setq val ""))
- (unless val (error "No file name specified"))
-
- (if (and default-filename
- (string-equal val (if (consp insdef) (car insdef) insdef)))
- (setq val default-filename))
- (setq val (substitute-in-file-name val))
-
- (if replace-in-history
- ;; Replace what Fcompleting_read added to the history
- ;; with what we will actually return. As an exception,
- ;; if that's the same as the second item in
- ;; file-name-history, it's really a repeat (Bug#4657).
+ (let ((completion-ignore-case read-file-name-completion-ignore-case)
+ (minibuffer-completing-file-name t)
+ (pred (or predicate 'file-exists-p))
+ (add-to-history nil))
+
+ (let* ((val
+ (if (or (not (next-read-file-uses-dialog-p))
+ ;; Graphical file dialogs can't handle remote
+ ;; files (Bug#99).
+ (file-remote-p dir))
+ ;; We used to pass `dir' to `read-file-name-internal' by
+ ;; abusing the `predicate' argument. It's better to
+ ;; just use `default-directory', but in order to avoid
+ ;; changing `default-directory' in the current buffer,
+ ;; we don't let-bind it.
+ (let ((dir (file-name-as-directory
+ (expand-file-name dir))))
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq default-directory dir)
+ ;; When the first default in `minibuffer-default'
+ ;; duplicates initial input `insdef',
+ ;; reset `minibuffer-default' to nil.
+ (when (equal (or (car-safe insdef) insdef)
+ (or (car-safe minibuffer-default)
+ minibuffer-default))
+ (setq minibuffer-default
+ (cdr-safe minibuffer-default)))
+ ;; On the first request on `M-n' fill
+ ;; `minibuffer-default' with a list of defaults
+ ;; relevant for file-name reading.
+ (set (make-local-variable 'minibuffer-default-add-function)
+ (lambda ()
+ (with-current-buffer
+ (window-buffer (minibuffer-selected-window))
+ (read-file-name--defaults dir initial))))
+ (set-syntax-table minibuffer-local-filename-syntax))
+ (completing-read prompt 'read-file-name-internal
+ pred mustmatch insdef
+ 'file-name-history default-filename)))
+ ;; If DEFAULT-FILENAME not supplied and DIR contains
+ ;; a file name, split it.
+ (let ((file (file-name-nondirectory dir))
+ ;; When using a dialog, revert to nil and non-nil
+ ;; interpretation of mustmatch. confirm options
+ ;; need to be interpreted as nil, otherwise
+ ;; it is impossible to create new files using
+ ;; dialogs with the default settings.
+ (dialog-mustmatch
+ (not (memq mustmatch
+ '(nil confirm confirm-after-completion)))))
+ (when (and (not default-filename)
+ (not (zerop (length file))))
+ (setq default-filename file)
+ (setq dir (file-name-directory dir)))
+ (when default-filename
+ (setq default-filename
+ (expand-file-name (if (consp default-filename)
+ (car default-filename)
+ default-filename)
+ dir)))
+ (setq add-to-history t)
+ (x-file-dialog prompt dir default-filename
+ dialog-mustmatch
+ (eq predicate 'file-directory-p)))))
+
+ (replace-in-history (eq (car-safe file-name-history) val)))
+ ;; If completing-read returned the inserted default string itself
+ ;; (rather than a new string with the same contents),
+ ;; it has to mean that the user typed RET with the minibuffer empty.
+ ;; In that case, we really want to return ""
+ ;; so that commands such as set-visited-file-name can distinguish.
+ (when (consp default-filename)
+ (setq default-filename (car default-filename)))
+ (when (eq val default-filename)
+ ;; In this case, completing-read has not added an element
+ ;; to the history. Maybe we should.
+ (if (not replace-in-history)
+ (setq add-to-history t))
+ (setq val ""))
+ (unless val (error "No file name specified"))
+
+ (if (and default-filename
+ (string-equal val (if (consp insdef) (car insdef) insdef)))
+ (setq val default-filename))
+ (setq val (substitute-in-file-name val))
+
+ (if replace-in-history
+ ;; Replace what Fcompleting_read added to the history
+ ;; with what we will actually return. As an exception,
+ ;; if that's the same as the second item in
+ ;; file-name-history, it's really a repeat (Bug#4657).
+ (let ((val1 (minibuffer--double-dollars val)))
+ (if history-delete-duplicates
+ (setcdr file-name-history
+ (delete val1 (cdr file-name-history))))
+ (if (string= val1 (cadr file-name-history))
+ (pop file-name-history)
+ (setcar file-name-history val1)))
+ (if add-to-history
+ ;; Add the value to the history--but not if it matches
+ ;; the last value already there.
(let ((val1 (minibuffer--double-dollars val)))
- (if history-delete-duplicates
- (setcdr file-name-history
- (delete val1 (cdr file-name-history))))
- (if (string= val1 (cadr file-name-history))
- (pop file-name-history)
- (setcar file-name-history val1)))
- (if add-to-history
- ;; Add the value to the history--but not if it matches
- ;; the last value already there.
- (let ((val1 (minibuffer--double-dollars val)))
- (unless (and (consp file-name-history)
- (equal (car file-name-history) val1))
- (setq file-name-history
- (cons val1
- (if history-delete-duplicates
- (delete val1 file-name-history)
- file-name-history)))))))
- val)))))
+ (unless (and (consp file-name-history)
+ (equal (car file-name-history) val1))
+ (setq file-name-history
+ (cons val1
+ (if history-delete-duplicates
+ (delete val1 file-name-history)
+ file-name-history)))))))
+ val))))
(defun internal-complete-buffer-except (&optional buffer)
"Perform completion on all buffers excluding BUFFER.
(defun completion-pcm--prepare-delim-re (delims)
(setq completion-pcm--delim-wild-regex (concat "[" delims "*]")))
-(defcustom completion-pcm-word-delimiters "-_./: "
+(defcustom completion-pcm-word-delimiters "-_./:| "
"A string of characters treated as word delimiters for completion.
Some arcane rules:
If `]' is in this string, it must come first.
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."
+ :version "24.1"
:type 'boolean)
(defun completion-pcm--pattern-trivial-p (pattern)
(defun completion-pcm--string->pattern (string &optional point)
"Split STRING into a pattern.
A pattern is a list where each element is either a string
-or a symbol chosen among `any', `star', `point', `prefix'."
+or a symbol, see `completion-pcm--merge-completions'."
(if (and point (< point (length string)))
(let ((prefix (substring string 0 point))
(suffix (substring string point)))
(append (completion-pcm--string->pattern prefix)
'(point)
(completion-pcm--string->pattern suffix)))
- (let ((pattern nil)
- (p 0)
- (p0 0))
+ (let* ((pattern nil)
+ (p 0)
+ (p0 p))
(while (and (setq p (string-match completion-pcm--delim-wild-regex
string p))
(case-fold-search completion-ignore-case)
(completion-regexp-list (cons regex completion-regexp-list))
(compl (all-completions
- (concat prefix (if (stringp (car pattern)) (car pattern) ""))
+ (concat prefix
+ (if (stringp (car pattern)) (car pattern) ""))
table pred)))
(if (not (functionp table))
;; The internal functions already obeyed completion-regexp-list.
"Find all completions for STRING at POINT in TABLE, satisfying PRED.
POINT is a position inside STRING.
FILTER is a function applied to the return value, that can be used, e.g. to
-filter out additional entries (because TABLE migth not obey PRED)."
+filter out additional entries (because TABLE might not obey PRED)."
(unless filter (setq filter 'identity))
(let* ((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(- (length newbeforepoint)
(car newbounds)))))
(dolist (submatch suball)
- (setq all (nconc (mapcar
- (lambda (s) (concat submatch between s))
- (funcall filter
- (completion-pcm--all-completions
- (concat subprefix submatch between)
- pattern table pred)))
- all)))
+ (setq all (nconc
+ (mapcar
+ (lambda (s) (concat submatch between s))
+ (funcall filter
+ (completion-pcm--all-completions
+ (concat subprefix submatch between)
+ pattern table pred)))
+ all)))
;; FIXME: This can come in handy for try-completion,
;; but isn't right for all-completions, since it lists
;; invalid completions.
(mapcar 'completion--sreverse strs))))
(defun completion-pcm--merge-completions (strs pattern)
- "Extract the commonality in STRS, with the help of PATTERN."
+ "Extract the commonality in STRS, with the help of PATTERN.
+PATTERN can contain strings and symbols chosen among `star', `any', `point',
+and `prefix'. They all match anything (aka \".*\") but are merged differently:
+`any' only grows from the left (when matching \"a1b\" and \"a2b\" it gets
+ completed to just \"a\").
+`prefix' only grows from the right (when matching \"a1b\" and \"a2b\" it gets
+ completed to just \"b\").
+`star' grows from both ends and is reified into a \"*\" (when matching \"a1b\"
+ and \"a2b\" it gets completed to \"a*b\").
+`point' is like `star' except that it gets reified as the position of point
+ instead of being reified as a \"*\" character.
+The underlying idea is that we should return a string which still matches
+the same set of elements."
;; When completing while ignoring case, we want to try and avoid
;; completing "fo" to "foO" when completing against "FOO" (bug#4219).
;; So we try and make sure that the string we return is all made up
(let* ((prefix (try-completion fixed comps))
(unique (or (and (eq prefix t) (setq prefix fixed))
(eq t (try-completion prefix comps)))))
- (unless (equal prefix "") (push prefix res))
+ (unless (or (eq elem 'prefix)
+ (equal prefix ""))
+ (push prefix res))
;; If there's only one completion, `elem' is not useful
;; any more: it can only match the empty string.
;; FIXME: in some cases, it may be necessary to turn an
(defun completion-pcm--pattern->string (pattern)
(mapconcat (lambda (x) (cond
- ((stringp x) x)
- ((eq x 'star) "*")
- (t ""))) ;any, point, prefix.
+ ((stringp x) x)
+ ((eq x 'star) "*")
+ (t ""))) ;any, point, prefix.
pattern
""))
;; second alternative.
(defun completion-pcm--filename-try-filter (all)
"Filter to adjust `all' file completion to the behavior of `try'."
- (when all
+ (when all
(let ((try ())
(re (concat "\\(?:\\`\\.\\.?/\\|"
(regexp-opt completion-ignored-extensions)
(equal (completion-pcm--pattern->string pattern) (car all)))
t)
(t
- (let* ((mergedpat (completion-pcm--merge-completions all pattern))
- ;; `mergedpat' is in reverse order. Place new point (by
- ;; order of preference) either at the old point, or at
- ;; the last place where there's something to choose, or
- ;; at the very end.
- (pointpat (or (memq 'point mergedpat)
- (memq 'any mergedpat)
- (memq 'star mergedpat)
- ;; Not `prefix'.
- mergedpat))
- ;; New pos from the start.
- (newpos (length (completion-pcm--pattern->string pointpat)))
- ;; Do it afterwards because it changes `pointpat' by sideeffect.
- (merged (completion-pcm--pattern->string (nreverse mergedpat))))
+ (let* ((mergedpat (completion-pcm--merge-completions all pattern))
+ ;; `mergedpat' is in reverse order. Place new point (by
+ ;; order of preference) either at the old point, or at
+ ;; the last place where there's something to choose, or
+ ;; at the very end.
+ (pointpat (or (memq 'point mergedpat)
+ (memq 'any mergedpat)
+ (memq 'star mergedpat)
+ ;; Not `prefix'.
+ mergedpat))
+ ;; New pos from the start.
+ (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))
- (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
+ (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
(defun completion-pcm-try-completion (string table pred point)
(destructuring-bind (pattern all prefix suffix)
(let ((newstr (completion-initials-expand string table pred)))
(when newstr
(completion-pcm-try-completion newstr table pred (length newstr)))))
-
+\f
+(defvar completing-read-function 'completing-read-default
+ "The function called by `completing-read' to do its work.
+It should accept the same arguments as `completing-read'.")
+
+(defun completing-read-default (prompt collection &optional predicate
+ require-match initial-input
+ hist def inherit-input-method)
+ "Default method for reading from the minibuffer with completion.
+See `completing-read' for the meaning of the arguments."
+
+ (when (consp initial-input)
+ (setq initial-input
+ (cons (car initial-input)
+ ;; `completing-read' uses 0-based index while
+ ;; `read-from-minibuffer' uses 1-based index.
+ (1+ (cdr initial-input)))))
+
+ (let* ((minibuffer-completion-table collection)
+ (minibuffer-completion-predicate predicate)
+ (minibuffer-completion-confirm (unless (eq require-match t)
+ require-match))
+ (base-keymap (if require-match
+ minibuffer-local-must-match-map
+ minibuffer-local-completion-map))
+ (keymap (if (memq minibuffer-completing-file-name '(nil lambda))
+ base-keymap
+ ;; Layer minibuffer-local-filename-completion-map
+ ;; on top of the base map.
+ (make-composed-keymap
+ minibuffer-local-filename-completion-map
+ ;; Set base-keymap as the parent, so that nil bindings
+ ;; in minibuffer-local-filename-completion-map can
+ ;; override bindings in base-keymap.
+ base-keymap)))
+ (result (read-from-minibuffer prompt initial-input keymap
+ nil hist def inherit-input-method)))
+ (when (and (equal result "") def)
+ (setq result (if (consp def) (car def) def)))
+ result))
\f
;; Miscellaneous