;; 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 highlighting 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.
;; - Make things like icomplete-mode or lightning-completion work with
;; completion-in-region-mode.
;; - extend `metadata':
-;; - quoting/unquoting (so we can complete files names with envvars
-;; and backslashes, and all-completion can list names without
-;; quoting backslashes and dollars).
;; - 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.
+;; 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
`(completion-table-dynamic
(lambda (,str)
(when (functionp ,var)
- (setq ,var (,fun)))
+ (setq ,var (funcall #',fun)))
,var))))
(defun completion-table-case-fold (table &optional dont-fold)
(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?
(let ((pred
(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
(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 (or metadata
- (completion-metadata
- (substring string 0 point)
- table pred)))))
+ (completion--nth-completion 1 string table pred point metadata))
(defun completion-all-completions (string table pred point &optional metadata)
"List the possible completions of STRING in completion table TABLE.
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 (or metadata
- (completion-metadata
- (substring string 0 point)
- table pred)))))
+ (completion--nth-completion 2 string table pred point metadata))
(defun minibuffer--bitset (modified completions exact)
(logior (if modified 4 0)
(defvar completion-extra-properties nil
"Property list of extra properties of the current completion job.
These include:
-`:annotation-function': Function to add annotations in the completions buffer.
- The function takes a completion and should either return nil, or a string
- that will be displayed next to the completion. The function can access the
- completion data via `minibuffer-completion-table' and related variables.
+
+`: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 takes at least 2 parameters (STRING and STATUS) where STRING
- is the text to which the field was completed and STATUS indicates what
- kind of operation happened: if text is now complete it's `finished', if text
- cannot be further completed but completion is not finished, it's `sole', if
- text is a valid completion but may be further completed, it's `exact', and
- other STATUSes may be added in the future.")
+
+ 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
(let ((map (make-sparse-keymap)))
;; FIXME: Only works if completion-in-region-mode was activated via
;; completion-at-point called directly.
- (define-key map "?" 'completion-help-at-point)
+ (define-key map "\M-?" 'completion-help-at-point)
(define-key map "\t" 'completion-at-point)
map)
"Keymap activated during `completion-in-region'.")
Gets combined either with `minibuffer-local-completion-map' or
with `minibuffer-local-must-match-map'.")
-(defvar minibuffer-local-filename-must-match-map (make-sparse-keymap))
-(make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1")
(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)
;;; 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)
(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))))
(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 'read-file-name-default
(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.
;; 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 "24.1" 'get)
+;;(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.
(lambda ()
(with-current-buffer
(window-buffer (minibuffer-selected-window))
- (read-file-name--defaults dir initial)))))
+ (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)))