Commit | Line | Data |
---|---|---|
a647cb26 | 1 | ;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*- |
32bae13c | 2 | |
ba318903 | 3 | ;; Copyright (C) 2008-2014 Free Software Foundation, Inc. |
32bae13c SM |
4 | |
5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | |
bd78fa1d | 6 | ;; Package: emacs |
32bae13c SM |
7 | |
8 | ;; This file is part of GNU Emacs. | |
9 | ||
eb3fa2cf | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
32bae13c SM |
11 | ;; it under the terms of the GNU General Public License as published by |
12 | ;; the Free Software Foundation, either version 3 of the License, or | |
13 | ;; (at your option) any later version. | |
14 | ||
eb3fa2cf | 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
32bae13c SM |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
eb3fa2cf | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
32bae13c SM |
22 | |
23 | ;;; Commentary: | |
24 | ||
a38313e1 SM |
25 | ;; Names with "--" are for functions and variables that are meant to be for |
26 | ;; internal use only. | |
27 | ||
28 | ;; Functional completion tables have an extended calling conventions: | |
30a23501 SM |
29 | ;; The `action' can be (additionally to nil, t, and lambda) of the form |
30 | ;; - (boundaries . SUFFIX) in which case it should return | |
f8381803 | 31 | ;; (boundaries START . END). See `completion-boundaries'. |
a38313e1 SM |
32 | ;; Any other return value should be ignored (so we ignore values returned |
33 | ;; from completion tables that don't know about this new `action' form). | |
30a23501 SM |
34 | ;; - `metadata' in which case it should return (metadata . ALIST) where |
35 | ;; ALIST is the metadata of this table. See `completion-metadata'. | |
36 | ;; Any other return value should be ignored (so we ignore values returned | |
37 | ;; from completion tables that don't know about this new `action' form). | |
a38313e1 SM |
38 | |
39 | ;;; Bugs: | |
40 | ||
67982e2b | 41 | ;; - completion-all-sorted-completions lists all the completions, whereas |
eee6de73 SM |
42 | ;; it should only lists the ones that `try-completion' would consider. |
43 | ;; E.g. it should honor completion-ignored-extensions. | |
a38313e1 | 44 | ;; - choose-completion can't automatically figure out the boundaries |
528c56e2 SM |
45 | ;; corresponding to the displayed completions because we only |
46 | ;; provide the start info but not the end info in | |
47 | ;; completion-base-position. | |
528c56e2 SM |
48 | ;; - C-x C-f ~/*/sr ? should not list "~/./src". |
49 | ;; - minibuffer-force-complete completes ~/src/emacs/t<!>/lisp/minibuffer.el | |
50 | ;; to ~/src/emacs/trunk/ and throws away lisp/minibuffer.el. | |
ba5ff07b | 51 | |
3911966b SM |
52 | ;;; Todo: |
53 | ||
3b11e6ac SM |
54 | ;; - Make *Completions* readable even if some of the completion |
55 | ;; entries have LF chars or spaces in them (including at | |
56 | ;; beginning/end) or are very long. | |
a2a25d24 | 57 | ;; - for M-x, cycle-sort commands that have no key binding first. |
2dbaa080 SM |
58 | ;; - Make things like icomplete-mode or lightning-completion work with |
59 | ;; completion-in-region-mode. | |
620c53a6 | 60 | ;; - extend `metadata': |
365b9a62 SM |
61 | ;; - indicate how to turn all-completion's output into |
62 | ;; try-completion's output: e.g. completion-ignored-extensions. | |
ef24141c | 63 | ;; maybe that could be merged with the "quote" operation. |
365b9a62 SM |
64 | ;; - indicate that `all-completions' doesn't do prefix-completion |
65 | ;; but just returns some list that relates in some other way to | |
66 | ;; the provided string (as is the case in filecache.el), in which | |
67 | ;; case partial-completion (for example) doesn't make any sense | |
68 | ;; and neither does the completions-first-difference highlight. | |
902a6d8d SM |
69 | ;; - indicate how to display the completions in *Completions* (turn |
70 | ;; \n into something else, add special boundaries between | |
71 | ;; completions). E.g. when completing from the kill-ring. | |
365b9a62 | 72 | |
528c56e2 | 73 | ;; - case-sensitivity currently confuses two issues: |
ab22be48 | 74 | ;; - whether or not a particular completion table should be case-sensitive |
528c56e2 | 75 | ;; (i.e. whether strings that differ only by case are semantically |
ab22be48 SM |
76 | ;; equivalent) |
77 | ;; - whether the user wants completion to pay attention to case. | |
78 | ;; e.g. we may want to make it possible for the user to say "first try | |
79 | ;; completion case-sensitively, and if that fails, try to ignore case". | |
3b11e6ac SM |
80 | ;; Maybe the trick is that we should distinguish completion-ignore-case in |
81 | ;; try/all-completions (obey user's preference) from its use in | |
82 | ;; test-completion (obey the underlying object's semantics). | |
ab22be48 | 83 | |
a38313e1 | 84 | ;; - add support for ** to pcm. |
3911966b SM |
85 | ;; - Add vc-file-name-completion-table to read-file-name-internal. |
86 | ;; - A feature like completing-help.el. | |
32bae13c SM |
87 | |
88 | ;;; Code: | |
89 | ||
f58e0fd5 | 90 | (eval-when-compile (require 'cl-lib)) |
32bae13c | 91 | |
21622c6d SM |
92 | ;;; Completion table manipulation |
93 | ||
a38313e1 | 94 | ;; New completion-table operation. |
f8381803 SM |
95 | (defun completion-boundaries (string table pred suffix) |
96 | "Return the boundaries of the completions returned by TABLE for STRING. | |
a38313e1 | 97 | STRING is the string on which completion will be performed. |
f8381803 SM |
98 | SUFFIX is the string after point. |
99 | The result is of the form (START . END) where START is the position | |
100 | in STRING of the beginning of the completion field and END is the position | |
101 | in SUFFIX of the end of the completion field. | |
f8381803 SM |
102 | E.g. for simple completion tables, the result is always (0 . (length SUFFIX)) |
103 | and for file names the result is the positions delimited by | |
a38313e1 SM |
104 | the closest directory separators." |
105 | (let ((boundaries (if (functionp table) | |
30a23501 SM |
106 | (funcall table string pred |
107 | (cons 'boundaries suffix))))) | |
a38313e1 SM |
108 | (if (not (eq (car-safe boundaries) 'boundaries)) |
109 | (setq boundaries nil)) | |
110 | (cons (or (cadr boundaries) 0) | |
f8381803 | 111 | (or (cddr boundaries) (length suffix))))) |
a38313e1 | 112 | |
620c53a6 SM |
113 | (defun completion-metadata (string table pred) |
114 | "Return the metadata of elements to complete at the end of STRING. | |
115 | This metadata is an alist. Currently understood keys are: | |
116 | - `category': the kind of objects returned by `all-completions'. | |
117 | Used by `completion-category-overrides'. | |
118 | - `annotation-function': function to add annotations in *Completions*. | |
119 | Takes one argument (STRING), which is a possible completion and | |
120 | returns a string to append to STRING. | |
121 | - `display-sort-function': function to sort entries in *Completions*. | |
122 | Takes one argument (COMPLETIONS) and should return a new list | |
123 | of completions. Can operate destructively. | |
124 | - `cycle-sort-function': function to sort entries when cycling. | |
30a23501 SM |
125 | Works like `display-sort-function'. |
126 | The metadata of a completion table should be constant between two boundaries." | |
620c53a6 SM |
127 | (let ((metadata (if (functionp table) |
128 | (funcall table string pred 'metadata)))) | |
129 | (if (eq (car-safe metadata) 'metadata) | |
4cb3bfa0 SM |
130 | metadata |
131 | '(metadata)))) | |
620c53a6 SM |
132 | |
133 | (defun completion--field-metadata (field-start) | |
134 | (completion-metadata (buffer-substring-no-properties field-start (point)) | |
135 | minibuffer-completion-table | |
136 | minibuffer-completion-predicate)) | |
137 | ||
138 | (defun completion-metadata-get (metadata prop) | |
139 | (cdr (assq prop metadata))) | |
140 | ||
e2947429 SM |
141 | (defun completion--some (fun xs) |
142 | "Apply FUN to each element of XS in turn. | |
143 | Return the first non-nil returned value. | |
144 | Like CL's `some'." | |
a647cb26 SM |
145 | (let ((firsterror nil) |
146 | res) | |
e2947429 | 147 | (while (and (not res) xs) |
67982e2b | 148 | (condition-case-unless-debug err |
a38313e1 SM |
149 | (setq res (funcall fun (pop xs))) |
150 | (error (unless firsterror (setq firsterror err)) nil))) | |
151 | (or res | |
152 | (if firsterror (signal (car firsterror) (cdr firsterror)))))) | |
e2947429 | 153 | |
21622c6d SM |
154 | (defun complete-with-action (action table string pred) |
155 | "Perform completion ACTION. | |
156 | STRING is the string to complete. | |
dbbc2e69 | 157 | TABLE is the completion table. |
21622c6d SM |
158 | PRED is a completion predicate. |
159 | ACTION can be one of nil, t or `lambda'." | |
a38313e1 SM |
160 | (cond |
161 | ((functionp table) (funcall table string pred action)) | |
30a23501 SM |
162 | ((eq (car-safe action) 'boundaries) nil) |
163 | ((eq action 'metadata) nil) | |
a38313e1 SM |
164 | (t |
165 | (funcall | |
166 | (cond | |
167 | ((null action) 'try-completion) | |
168 | ((eq action t) 'all-completions) | |
169 | (t 'test-completion)) | |
170 | string table pred)))) | |
21622c6d SM |
171 | |
172 | (defun completion-table-dynamic (fun) | |
173 | "Use function FUN as a dynamic completion table. | |
174 | FUN is called with one argument, the string for which completion is required, | |
b95c7600 JB |
175 | and it should return an alist containing all the intended possible completions. |
176 | This alist may be a full list of possible completions so that FUN can ignore | |
177 | the value of its argument. If completion is performed in the minibuffer, | |
178 | FUN will be called in the buffer from which the minibuffer was entered. | |
21622c6d | 179 | |
e8061cd9 | 180 | The result of the `completion-table-dynamic' form is a function |
d9aa6b33 | 181 | that can be used as the COLLECTION argument to `try-completion' and |
ea7826ba GM |
182 | `all-completions'. See Info node `(elisp)Programmed Completion'. |
183 | ||
184 | See also the related function `completion-table-with-cache'." | |
a647cb26 | 185 | (lambda (string pred action) |
30a23501 | 186 | (if (or (eq (car-safe action) 'boundaries) (eq action 'metadata)) |
03408648 SM |
187 | ;; `fun' is not supposed to return another function but a plain old |
188 | ;; completion table, whose boundaries are always trivial. | |
189 | nil | |
190 | (with-current-buffer (let ((win (minibuffer-selected-window))) | |
191 | (if (window-live-p win) (window-buffer win) | |
192 | (current-buffer))) | |
193 | (complete-with-action action (funcall fun string) string pred))))) | |
21622c6d | 194 | |
16588fad | 195 | (defun completion-table-with-cache (fun &optional ignore-case) |
ea7826ba GM |
196 | "Create dynamic completion table from function FUN, with cache. |
197 | This is a wrapper for `completion-table-dynamic' that saves the last | |
16588fad DG |
198 | argument-result pair from FUN, so that several lookups with the |
199 | same argument (or with an argument that starts with the first one) | |
ea7826ba GM |
200 | only need to call FUN once. This can be useful when FUN performs a |
201 | relatively slow operation, such as calling an external process. | |
202 | ||
16588fad | 203 | When IGNORE-CASE is non-nil, FUN is expected to be case-insensitive." |
ea7826ba | 204 | ;; See eg bug#11906. |
16588fad DG |
205 | (let* (last-arg last-result |
206 | (new-fun | |
207 | (lambda (arg) | |
208 | (if (and last-arg (string-prefix-p last-arg arg ignore-case)) | |
209 | last-result | |
210 | (prog1 | |
211 | (setq last-result (funcall fun arg)) | |
212 | (setq last-arg arg)))))) | |
213 | (completion-table-dynamic new-fun))) | |
214 | ||
21622c6d SM |
215 | (defmacro lazy-completion-table (var fun) |
216 | "Initialize variable VAR as a lazy completion table. | |
217 | If the completion table VAR is used for the first time (e.g., by passing VAR | |
218 | as an argument to `try-completion'), the function FUN is called with no | |
219 | arguments. FUN must return the completion table that will be stored in VAR. | |
220 | If completion is requested in the minibuffer, FUN will be called in the buffer | |
221 | from which the minibuffer was entered. The return value of | |
222 | `lazy-completion-table' must be used to initialize the value of VAR. | |
223 | ||
224 | You should give VAR a non-nil `risky-local-variable' property." | |
69e018a7 | 225 | (declare (debug (symbolp lambda-expr))) |
21622c6d SM |
226 | (let ((str (make-symbol "string"))) |
227 | `(completion-table-dynamic | |
228 | (lambda (,str) | |
229 | (when (functionp ,var) | |
0d42eb3e | 230 | (setq ,var (funcall #',fun))) |
21622c6d SM |
231 | ,var)))) |
232 | ||
3dc61a09 SM |
233 | (defun completion-table-case-fold (table &optional dont-fold) |
234 | "Return new completion TABLE that is case insensitive. | |
235 | If DONT-FOLD is non-nil, return a completion table that is | |
236 | case sensitive instead." | |
237 | (lambda (string pred action) | |
238 | (let ((completion-ignore-case (not dont-fold))) | |
239 | (complete-with-action action table string pred)))) | |
e2784c87 | 240 | |
ef24141c | 241 | (defun completion-table-subvert (table s1 s2) |
96d03571 | 242 | "Return a completion table from TABLE with S1 replaced by S2. |
ef24141c | 243 | The result is a completion table which completes strings of the |
9011078f BG |
244 | form (concat S1 S) in the same way as TABLE completes strings of |
245 | the form (concat S2 S)." | |
ef24141c | 246 | (lambda (string pred action) |
5697ca55 | 247 | (let* ((str (if (string-prefix-p s1 string completion-ignore-case) |
ef24141c SM |
248 | (concat s2 (substring string (length s1))))) |
249 | (res (if str (complete-with-action action table str pred)))) | |
250 | (when res | |
251 | (cond | |
252 | ((eq (car-safe action) 'boundaries) | |
253 | (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0))) | |
f58e0fd5 SM |
254 | `(boundaries |
255 | ,(max (length s1) | |
256 | (+ beg (- (length s1) (length s2)))) | |
257 | . ,(and (eq (car-safe res) 'boundaries) (cddr res))))) | |
ef24141c | 258 | ((stringp res) |
5697ca55 | 259 | (if (string-prefix-p s2 string completion-ignore-case) |
ef24141c SM |
260 | (concat s1 (substring res (length s2))))) |
261 | ((eq action t) | |
262 | (let ((bounds (completion-boundaries str table pred ""))) | |
263 | (if (>= (car bounds) (length s2)) | |
264 | res | |
265 | (let ((re (concat "\\`" | |
266 | (regexp-quote (substring s2 (car bounds)))))) | |
267 | (delq nil | |
268 | (mapcar (lambda (c) | |
269 | (if (string-match re c) | |
270 | (substring c (match-end 0)))) | |
271 | res)))))) | |
272 | ;; E.g. action=nil and it's the only completion. | |
273 | (res)))))) | |
274 | ||
21622c6d | 275 | (defun completion-table-with-context (prefix table string pred action) |
25c0d999 | 276 | ;; TODO: add `suffix' maybe? |
b291b572 SM |
277 | (let ((pred |
278 | (if (not (functionp pred)) | |
279 | ;; Notice that `pred' may not be a function in some abusive cases. | |
280 | pred | |
281 | ;; Predicates are called differently depending on the nature of | |
282 | ;; the completion table :-( | |
283 | (cond | |
284 | ((vectorp table) ;Obarray. | |
285 | (lambda (sym) (funcall pred (concat prefix (symbol-name sym))))) | |
286 | ((hash-table-p table) | |
287 | (lambda (s _v) (funcall pred (concat prefix s)))) | |
288 | ((functionp table) | |
289 | (lambda (s) (funcall pred (concat prefix s)))) | |
290 | (t ;Lists and alists. | |
291 | (lambda (s) | |
292 | (funcall pred (concat prefix (if (consp s) (car s) s))))))))) | |
293 | (if (eq (car-safe action) 'boundaries) | |
294 | (let* ((len (length prefix)) | |
295 | (bound (completion-boundaries string table pred (cdr action)))) | |
f58e0fd5 | 296 | `(boundaries ,(+ (car bound) len) . ,(cdr bound))) |
b291b572 SM |
297 | (let ((comp (complete-with-action action table string pred))) |
298 | (cond | |
299 | ;; In case of try-completion, add the prefix. | |
300 | ((stringp comp) (concat prefix comp)) | |
301 | (t comp)))))) | |
21622c6d SM |
302 | |
303 | (defun completion-table-with-terminator (terminator table string pred action) | |
528c56e2 SM |
304 | "Construct a completion table like TABLE but with an extra TERMINATOR. |
305 | This is meant to be called in a curried way by first passing TERMINATOR | |
306 | and TABLE only (via `apply-partially'). | |
307 | TABLE is a completion table, and TERMINATOR is a string appended to TABLE's | |
308 | completion if it is complete. TERMINATOR is also used to determine the | |
a452eee8 SM |
309 | completion suffix's boundary. |
310 | TERMINATOR can also be a cons cell (TERMINATOR . TERMINATOR-REGEXP) | |
311 | in which case TERMINATOR-REGEXP is a regular expression whose submatch | |
312 | number 1 should match TERMINATOR. This is used when there is a need to | |
313 | distinguish occurrences of the TERMINATOR strings which are really terminators | |
c0a193ea SM |
314 | from others (e.g. escaped). In this form, the car of TERMINATOR can also be, |
315 | instead of a string, a function that takes the completion and returns the | |
316 | \"terminated\" string." | |
3e2d70fd SM |
317 | ;; FIXME: This implementation is not right since it only adds the terminator |
318 | ;; in try-completion, so any completion-style that builds the completion via | |
319 | ;; all-completions won't get the terminator, and selecting an entry in | |
320 | ;; *Completions* won't get the terminator added either. | |
25c0d999 | 321 | (cond |
528c56e2 SM |
322 | ((eq (car-safe action) 'boundaries) |
323 | (let* ((suffix (cdr action)) | |
324 | (bounds (completion-boundaries string table pred suffix)) | |
a452eee8 SM |
325 | (terminator-regexp (if (consp terminator) |
326 | (cdr terminator) (regexp-quote terminator))) | |
c0a193ea SM |
327 | (max (and terminator-regexp |
328 | (string-match terminator-regexp suffix)))) | |
f58e0fd5 SM |
329 | `(boundaries ,(car bounds) |
330 | . ,(min (cdr bounds) (or max (length suffix)))))) | |
25c0d999 SM |
331 | ((eq action nil) |
332 | (let ((comp (try-completion string table pred))) | |
a452eee8 | 333 | (if (consp terminator) (setq terminator (car terminator))) |
88893215 | 334 | (if (eq comp t) |
c0a193ea SM |
335 | (if (functionp terminator) |
336 | (funcall terminator string) | |
337 | (concat string terminator)) | |
338 | (if (and (stringp comp) (not (zerop (length comp))) | |
339 | ;; Try to avoid the second call to try-completion, since | |
528c56e2 SM |
340 | ;; it may be very inefficient (because `comp' made us |
341 | ;; jump to a new boundary, so we complete in that | |
342 | ;; boundary with an empty start string). | |
c0a193ea SM |
343 | (let ((newbounds (completion-boundaries comp table pred ""))) |
344 | (< (car newbounds) (length comp))) | |
25c0d999 | 345 | (eq (try-completion comp table pred) t)) |
c0a193ea SM |
346 | (if (functionp terminator) |
347 | (funcall terminator comp) | |
348 | (concat comp terminator)) | |
25c0d999 | 349 | comp)))) |
30a23501 SM |
350 | ;; completion-table-with-terminator is always used for |
351 | ;; "sub-completions" so it's only called if the terminator is missing, | |
352 | ;; in which case `test-completion' should return nil. | |
353 | ((eq action 'lambda) nil) | |
354 | (t | |
a38313e1 SM |
355 | ;; FIXME: We generally want the `try' and `all' behaviors to be |
356 | ;; consistent so pcm can merge the `all' output to get the `try' output, | |
357 | ;; but that sometimes clashes with the need for `all' output to look | |
358 | ;; good in *Completions*. | |
125f7951 SM |
359 | ;; (mapcar (lambda (s) (concat s terminator)) |
360 | ;; (all-completions string table pred)))) | |
30a23501 | 361 | (complete-with-action action table string pred)))) |
25c0d999 SM |
362 | |
363 | (defun completion-table-with-predicate (table pred1 strict string pred2 action) | |
364 | "Make a completion table equivalent to TABLE but filtered through PRED1. | |
cf43708e | 365 | PRED1 is a function of one argument which returns non-nil if and only if the |
25c0d999 SM |
366 | argument is an element of TABLE which should be considered for completion. |
367 | STRING, PRED2, and ACTION are the usual arguments to completion tables, | |
368 | as described in `try-completion', `all-completions', and `test-completion'. | |
3911966b SM |
369 | If STRICT is t, the predicate always applies; if nil it only applies if |
370 | it does not reduce the set of possible completions to nothing. | |
25c0d999 SM |
371 | Note: TABLE needs to be a proper completion table which obeys predicates." |
372 | (cond | |
373 | ((and (not strict) (eq action 'lambda)) | |
374 | ;; Ignore pred1 since it doesn't really have to apply anyway. | |
af48580e | 375 | (test-completion string table pred2)) |
25c0d999 SM |
376 | (t |
377 | (or (complete-with-action action table string | |
78054a46 SM |
378 | (if (not (and pred1 pred2)) |
379 | (or pred1 pred2) | |
a647cb26 SM |
380 | (lambda (x) |
381 | ;; Call `pred1' first, so that `pred2' | |
382 | ;; really can't tell that `x' is in table. | |
78054a46 | 383 | (and (funcall pred1 x) (funcall pred2 x))))) |
25c0d999 SM |
384 | ;; If completion failed and we're not applying pred1 strictly, try |
385 | ;; again without pred1. | |
78054a46 | 386 | (and (not strict) pred1 pred2 |
25c0d999 | 387 | (complete-with-action action table string pred2)))))) |
21622c6d | 388 | |
e2947429 SM |
389 | (defun completion-table-in-turn (&rest tables) |
390 | "Create a completion table that tries each table in TABLES in turn." | |
528c56e2 SM |
391 | ;; FIXME: the boundaries may come from TABLE1 even when the completion list |
392 | ;; is returned by TABLE2 (because TABLE1 returned an empty list). | |
a333e4d2 | 393 | ;; Same potential problem if any of the tables use quoting. |
a647cb26 SM |
394 | (lambda (string pred action) |
395 | (completion--some (lambda (table) | |
396 | (complete-with-action action table string pred)) | |
397 | tables))) | |
e2947429 | 398 | |
a333e4d2 DG |
399 | (defun completion-table-merge (&rest tables) |
400 | "Create a completion table that collects completions from all TABLES." | |
401 | ;; FIXME: same caveats as in `completion-table-in-turn'. | |
402 | (lambda (string pred action) | |
403 | (cond | |
404 | ((null action) | |
405 | (let ((retvals (mapcar (lambda (table) | |
406 | (try-completion string table pred)) | |
407 | tables))) | |
408 | (if (member string retvals) | |
409 | string | |
410 | (try-completion string | |
411 | (mapcar (lambda (value) | |
412 | (if (eq value t) string value)) | |
413 | (delq nil retvals)) | |
414 | pred)))) | |
415 | ((eq action t) | |
416 | (apply #'append (mapcar (lambda (table) | |
417 | (all-completions string table pred)) | |
418 | tables))) | |
419 | (t | |
420 | (completion--some (lambda (table) | |
421 | (complete-with-action action table string pred)) | |
422 | tables))))) | |
423 | ||
ef24141c SM |
424 | (defun completion-table-with-quoting (table unquote requote) |
425 | ;; A difficult part of completion-with-quoting is to map positions in the | |
426 | ;; quoted string to equivalent positions in the unquoted string and | |
427 | ;; vice-versa. There is no efficient and reliable algorithm that works for | |
428 | ;; arbitrary quote and unquote functions. | |
429 | ;; So to map from quoted positions to unquoted positions, we simply assume | |
430 | ;; that `concat' and `unquote' commute (which tends to be the case). | |
431 | ;; And we ask `requote' to do the work of mapping from unquoted positions | |
432 | ;; back to quoted positions. | |
86957a0c SM |
433 | ;; FIXME: For some forms of "quoting" such as the truncation behavior of |
434 | ;; substitute-in-file-name, it would be desirable not to requote completely. | |
ef24141c SM |
435 | "Return a new completion table operating on quoted text. |
436 | TABLE operates on the unquoted text. | |
437 | UNQUOTE is a function that takes a string and returns a new unquoted string. | |
438 | REQUOTE is a function of 2 args (UPOS QSTR) where | |
439 | QSTR is a string entered by the user (and hence indicating | |
440 | the user's preferred form of quoting); and | |
441 | UPOS is a position within the unquoted form of QSTR. | |
442 | REQUOTE should return a pair (QPOS . QFUN) such that QPOS is the | |
443 | position corresponding to UPOS but in QSTR, and QFUN is a function | |
444 | of one argument (a string) which returns that argument appropriately quoted | |
445 | for use at QPOS." | |
446 | ;; FIXME: One problem with the current setup is that `qfun' doesn't know if | |
447 | ;; its argument is "the end of the completion", so if the quoting used double | |
448 | ;; quotes (for example), we end up completing "fo" to "foobar and throwing | |
449 | ;; away the closing double quote. | |
450 | (lambda (string pred action) | |
451 | (cond | |
452 | ((eq action 'metadata) | |
453 | (append (completion-metadata string table pred) | |
454 | '((completion--unquote-requote . t)))) | |
455 | ||
456 | ((eq action 'lambda) ;;test-completion | |
457 | (let ((ustring (funcall unquote string))) | |
458 | (test-completion ustring table pred))) | |
459 | ||
460 | ((eq (car-safe action) 'boundaries) | |
461 | (let* ((ustring (funcall unquote string)) | |
462 | (qsuffix (cdr action)) | |
463 | (ufull (if (zerop (length qsuffix)) ustring | |
464 | (funcall unquote (concat string qsuffix)))) | |
f58e0fd5 | 465 | (_ (cl-assert (string-prefix-p ustring ufull))) |
ef24141c SM |
466 | (usuffix (substring ufull (length ustring))) |
467 | (boundaries (completion-boundaries ustring table pred usuffix)) | |
468 | (qlboundary (car (funcall requote (car boundaries) string))) | |
469 | (qrboundary (if (zerop (cdr boundaries)) 0 ;Common case. | |
470 | (let* ((urfullboundary | |
471 | (+ (cdr boundaries) (length ustring)))) | |
472 | (- (car (funcall requote urfullboundary | |
473 | (concat string qsuffix))) | |
474 | (length string)))))) | |
f58e0fd5 | 475 | `(boundaries ,qlboundary . ,qrboundary))) |
ef24141c | 476 | |
6eac8dc9 SM |
477 | ;; In "normal" use a c-t-with-quoting completion table should never be |
478 | ;; called with action in (t nil) because `completion--unquote' should have | |
479 | ;; been called before and would have returned a different completion table | |
480 | ;; to apply to the unquoted text. But there's still a lot of code around | |
481 | ;; that likes to use all/try-completions directly, so we do our best to | |
482 | ;; handle those calls as well as we can. | |
483 | ||
ef24141c SM |
484 | ((eq action nil) ;;try-completion |
485 | (let* ((ustring (funcall unquote string)) | |
486 | (completion (try-completion ustring table pred))) | |
487 | ;; Most forms of quoting allow several ways to quote the same string. | |
488 | ;; So here we could simply requote `completion' in a kind of | |
489 | ;; "canonical" quoted form without paying attention to the way | |
490 | ;; `string' was quoted. But since we have to solve the more complex | |
491 | ;; problems of "pay attention to the original quoting" for | |
492 | ;; all-completions, we may as well use it here, since it provides | |
493 | ;; a nicer behavior. | |
494 | (if (not (stringp completion)) completion | |
495 | (car (completion--twq-try | |
496 | string ustring completion 0 unquote requote))))) | |
497 | ||
498 | ((eq action t) ;;all-completions | |
499 | ;; When all-completions is used for completion-try/all-completions | |
500 | ;; (e.g. for `pcm' style), we can't do the job properly here because | |
501 | ;; the caller will match our output against some pattern derived from | |
502 | ;; the user's (quoted) input, and we don't have access to that | |
503 | ;; pattern, so we can't know how to requote our output so that it | |
504 | ;; matches the quoting used in the pattern. It is to fix this | |
505 | ;; fundamental problem that we have to introduce the new | |
506 | ;; unquote-requote method so that completion-try/all-completions can | |
507 | ;; pass the unquoted string to the style functions. | |
508 | (pcase-let* | |
509 | ((ustring (funcall unquote string)) | |
510 | (completions (all-completions ustring table pred)) | |
6eac8dc9 SM |
511 | (boundary (car (completion-boundaries ustring table pred ""))) |
512 | (completions | |
513 | (completion--twq-all | |
514 | string ustring completions boundary unquote requote)) | |
515 | (last (last completions))) | |
516 | (when (consp last) (setcdr last nil)) | |
517 | completions)) | |
6b11952a | 518 | |
ef24141c | 519 | ((eq action 'completion--unquote) |
dccb0688 SM |
520 | ;; PRED is really a POINT in STRING. |
521 | ;; We should return a new set (STRING TABLE POINT REQUOTE) | |
522 | ;; where STRING is a new (unquoted) STRING to match against the new TABLE | |
523 | ;; using a new POINT inside it, and REQUOTE is a requoting function which | |
524 | ;; should reverse the unquoting, (i.e. it receives the completion result | |
525 | ;; of using the new TABLE and should turn it into the corresponding | |
526 | ;; quoted result). | |
527 | (let* ((qpos pred) | |
528 | (ustring (funcall unquote string)) | |
529 | (uprefix (funcall unquote (substring string 0 qpos))) | |
f62d0f2a | 530 | ;; FIXME: we really should pass `qpos' to `unquote' and have that |
dccb0688 SM |
531 | ;; function give us the corresponding `uqpos'. But for now we |
532 | ;; presume (more or less) that `concat' and `unquote' commute. | |
533 | (uqpos (if (string-prefix-p uprefix ustring) | |
534 | ;; Yay!! They do seem to commute! | |
535 | (length uprefix) | |
536 | ;; They don't commute this time! :-( | |
537 | ;; Maybe qpos is in some text that disappears in the | |
538 | ;; ustring (bug#17239). Let's try a second chance guess. | |
539 | (let ((usuffix (funcall unquote (substring string qpos)))) | |
540 | (if (string-suffix-p usuffix ustring) | |
541 | ;; Yay!! They still "commute" in a sense! | |
542 | (- (length ustring) (length usuffix)) | |
543 | ;; Still no luck! Let's just choose *some* position | |
544 | ;; within ustring. | |
545 | (/ (+ (min (length uprefix) (length ustring)) | |
546 | (max (- (length ustring) (length usuffix)) 0)) | |
547 | 2)))))) | |
548 | (list ustring table uqpos | |
ef24141c SM |
549 | (lambda (unquoted-result op) |
550 | (pcase op | |
f58e0fd5 | 551 | (1 ;;try |
ef24141c SM |
552 | (if (not (stringp (car-safe unquoted-result))) |
553 | unquoted-result | |
554 | (completion--twq-try | |
555 | string ustring | |
556 | (car unquoted-result) (cdr unquoted-result) | |
557 | unquote requote))) | |
f58e0fd5 | 558 | (2 ;;all |
ef24141c SM |
559 | (let* ((last (last unquoted-result)) |
560 | (base (or (cdr last) 0))) | |
561 | (when last | |
562 | (setcdr last nil) | |
563 | (completion--twq-all string ustring | |
564 | unquoted-result base | |
565 | unquote requote)))))))))))) | |
566 | ||
567 | (defun completion--twq-try (string ustring completion point | |
568 | unquote requote) | |
e33c6771 | 569 | ;; Basically two cases: either the new result is |
ef24141c SM |
570 | ;; - commonprefix1 <point> morecommonprefix <qpos> suffix |
571 | ;; - commonprefix <qpos> newprefix <point> suffix | |
572 | (pcase-let* | |
573 | ((prefix (fill-common-string-prefix ustring completion)) | |
574 | (suffix (substring completion (max point (length prefix)))) | |
575 | (`(,qpos . ,qfun) (funcall requote (length prefix) string)) | |
576 | (qstr1 (if (> point (length prefix)) | |
577 | (funcall qfun (substring completion (length prefix) point)))) | |
578 | (qsuffix (funcall qfun suffix)) | |
579 | (qstring (concat (substring string 0 qpos) qstr1 qsuffix)) | |
580 | (qpoint | |
581 | (cond | |
582 | ((zerop point) 0) | |
583 | ((> point (length prefix)) (+ qpos (length qstr1))) | |
584 | (t (car (funcall requote point string)))))) | |
585 | ;; Make sure `requote' worked. | |
e33c6771 SM |
586 | (if (equal (funcall unquote qstring) completion) |
587 | (cons qstring qpoint) | |
588 | ;; If requote failed (e.g. because sifn-requote did not handle | |
589 | ;; Tramp's "/foo:/bar//baz -> /foo:/baz" truncation), then at least | |
590 | ;; try requote properly. | |
591 | (let ((qstr (funcall qfun completion))) | |
592 | (cons qstr (length qstr)))))) | |
ef24141c | 593 | |
036dfb8b SM |
594 | (defun completion--string-equal-p (s1 s2) |
595 | (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case))) | |
596 | ||
ef24141c | 597 | (defun completion--twq-all (string ustring completions boundary |
51646b62 | 598 | _unquote requote) |
ef24141c SM |
599 | (when completions |
600 | (pcase-let* | |
601 | ((prefix | |
602 | (let ((completion-regexp-list nil)) | |
603 | (try-completion "" (cons (substring ustring boundary) | |
604 | completions)))) | |
605 | (`(,qfullpos . ,qfun) | |
606 | (funcall requote (+ boundary (length prefix)) string)) | |
607 | (qfullprefix (substring string 0 qfullpos)) | |
b9383404 SM |
608 | ;; FIXME: This assertion can be wrong, e.g. in Cygwin, where |
609 | ;; (unquote "c:\bin") => "/usr/bin" but (unquote "c:\") => "/". | |
610 | ;;(cl-assert (completion--string-equal-p | |
611 | ;; (funcall unquote qfullprefix) | |
612 | ;; (concat (substring ustring 0 boundary) prefix)) | |
613 | ;; t)) | |
ef24141c | 614 | (qboundary (car (funcall requote boundary string))) |
f58e0fd5 | 615 | (_ (cl-assert (<= qboundary qfullpos))) |
ef24141c SM |
616 | ;; FIXME: this split/quote/concat business messes up the carefully |
617 | ;; placed completions-common-part and completions-first-difference | |
618 | ;; faces. We could try within the mapcar loop to search for the | |
619 | ;; boundaries of those faces, pass them to `requote' to find their | |
620 | ;; equivalent positions in the quoted output and re-add the faces: | |
621 | ;; this might actually lead to correct results but would be | |
622 | ;; pretty expensive. | |
623 | ;; The better solution is to not quote the *Completions* display, | |
624 | ;; which nicely circumvents the problem. The solution I used here | |
625 | ;; instead is to hope that `qfun' preserves the text-properties and | |
626 | ;; presume that the `first-difference' is not within the `prefix'; | |
627 | ;; this presumption is not always true, but at least in practice it is | |
628 | ;; true in most cases. | |
629 | (qprefix (propertize (substring qfullprefix qboundary) | |
630 | 'face 'completions-common-part))) | |
631 | ||
632 | ;; Here we choose to quote all elements returned, but a better option | |
633 | ;; would be to return unquoted elements together with a function to | |
634 | ;; requote them, so that *Completions* can show nicer unquoted values | |
635 | ;; which only get quoted when needed by choose-completion. | |
636 | (nconc | |
637 | (mapcar (lambda (completion) | |
f58e0fd5 | 638 | (cl-assert (string-prefix-p prefix completion 'ignore-case) t) |
ef24141c SM |
639 | (let* ((new (substring completion (length prefix))) |
640 | (qnew (funcall qfun new)) | |
158bc55c SB |
641 | (qprefix |
642 | (if (not completion-ignore-case) | |
643 | qprefix | |
644 | ;; Make qprefix inherit the case from `completion'. | |
645 | (let* ((rest (substring completion | |
646 | 0 (length prefix))) | |
647 | (qrest (funcall qfun rest))) | |
648 | (if (completion--string-equal-p qprefix qrest) | |
649 | (propertize qrest 'face | |
650 | 'completions-common-part) | |
651 | qprefix)))) | |
ef24141c | 652 | (qcompletion (concat qprefix qnew))) |
b9383404 SM |
653 | ;; FIXME: Similarly here, Cygwin's mapping trips this |
654 | ;; assertion. | |
655 | ;;(cl-assert | |
656 | ;; (completion--string-equal-p | |
657 | ;; (funcall unquote | |
658 | ;; (concat (substring string 0 qboundary) | |
659 | ;; qcompletion)) | |
660 | ;; (concat (substring ustring 0 boundary) | |
661 | ;; completion)) | |
662 | ;; t) | |
ef24141c SM |
663 | qcompletion)) |
664 | completions) | |
665 | qboundary)))) | |
666 | ||
25c0d999 SM |
667 | ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) |
668 | ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) | |
e2947429 SM |
669 | (define-obsolete-function-alias |
670 | 'complete-in-turn 'completion-table-in-turn "23.1") | |
25c0d999 SM |
671 | (define-obsolete-function-alias |
672 | 'dynamic-completion-table 'completion-table-dynamic "23.1") | |
21622c6d SM |
673 | |
674 | ;;; Minibuffer completion | |
675 | ||
ba5ff07b SM |
676 | (defgroup minibuffer nil |
677 | "Controlling the behavior of the minibuffer." | |
678 | :link '(custom-manual "(emacs)Minibuffer") | |
679 | :group 'environment) | |
680 | ||
32bae13c SM |
681 | (defun minibuffer-message (message &rest args) |
682 | "Temporarily display MESSAGE at the end of the minibuffer. | |
683 | The text is displayed for `minibuffer-message-timeout' seconds, | |
684 | or until the next input event arrives, whichever comes first. | |
685 | Enclose MESSAGE in [...] if this is not yet the case. | |
686 | If ARGS are provided, then pass MESSAGE through `format'." | |
ab22be48 SM |
687 | (if (not (minibufferp (current-buffer))) |
688 | (progn | |
689 | (if args | |
690 | (apply 'message message args) | |
691 | (message "%s" message)) | |
692 | (prog1 (sit-for (or minibuffer-message-timeout 1000000)) | |
693 | (message nil))) | |
694 | ;; Clear out any old echo-area message to make way for our new thing. | |
695 | (message nil) | |
67982e2b SM |
696 | (setq message (if (and (null args) |
697 | (string-match-p "\\` *\\[.+\\]\\'" message)) | |
ab22be48 SM |
698 | ;; Make sure we can put-text-property. |
699 | (copy-sequence message) | |
700 | (concat " [" message "]"))) | |
701 | (when args (setq message (apply 'format message args))) | |
702 | (let ((ol (make-overlay (point-max) (point-max) nil t t)) | |
703 | ;; A quit during sit-for normally only interrupts the sit-for, | |
704 | ;; but since minibuffer-message is used at the end of a command, | |
705 | ;; at a time when the command has virtually finished already, a C-g | |
706 | ;; should really cause an abort-recursive-edit instead (i.e. as if | |
707 | ;; the C-g had been typed at top-level). Binding inhibit-quit here | |
708 | ;; is an attempt to get that behavior. | |
709 | (inhibit-quit t)) | |
710 | (unwind-protect | |
711 | (progn | |
712 | (unless (zerop (length message)) | |
713 | ;; The current C cursor code doesn't know to use the overlay's | |
714 | ;; marker's stickiness to figure out whether to place the cursor | |
715 | ;; before or after the string, so let's spoon-feed it the pos. | |
716 | (put-text-property 0 1 'cursor t message)) | |
717 | (overlay-put ol 'after-string message) | |
718 | (sit-for (or minibuffer-message-timeout 1000000))) | |
719 | (delete-overlay ol))))) | |
32bae13c SM |
720 | |
721 | (defun minibuffer-completion-contents () | |
722 | "Return the user input in a minibuffer before point as a string. | |
1d829c64 SM |
723 | In Emacs-22, that was what completion commands operated on." |
724 | (declare (obsolete nil "24.4")) | |
67982e2b | 725 | (buffer-substring (minibuffer-prompt-end) (point))) |
32bae13c SM |
726 | |
727 | (defun delete-minibuffer-contents () | |
728 | "Delete all user input in a minibuffer. | |
729 | If the current buffer is not a minibuffer, erase its entire contents." | |
d39109c3 | 730 | (interactive) |
8c9f211f CY |
731 | ;; We used to do `delete-field' here, but when file name shadowing |
732 | ;; is on, the field doesn't cover the entire minibuffer contents. | |
733 | (delete-region (minibuffer-prompt-end) (point-max))) | |
32bae13c | 734 | |
369e974d CY |
735 | (defvar completion-show-inline-help t |
736 | "If non-nil, print helpful inline messages during completion.") | |
737 | ||
ba5ff07b SM |
738 | (defcustom completion-auto-help t |
739 | "Non-nil means automatically provide help for invalid completion input. | |
740 | If the value is t the *Completion* buffer is displayed whenever completion | |
741 | is requested but cannot be done. | |
742 | If the value is `lazy', the *Completions* buffer is only displayed after | |
743 | the second failed attempt to complete." | |
67982e2b | 744 | :type '(choice (const nil) (const t) (const lazy))) |
ba5ff07b | 745 | |
2f7f4bee | 746 | (defconst completion-styles-alist |
fcb68f70 SM |
747 | '((emacs21 |
748 | completion-emacs21-try-completion completion-emacs21-all-completions | |
79d74ac5 SM |
749 | "Simple prefix-based completion. |
750 | I.e. when completing \"foo_bar\" (where _ is the position of point), | |
751 | it will consider all completions candidates matching the glob | |
752 | pattern \"foobar*\".") | |
fcb68f70 SM |
753 | (emacs22 |
754 | completion-emacs22-try-completion completion-emacs22-all-completions | |
79d74ac5 SM |
755 | "Prefix completion that only operates on the text before point. |
756 | I.e. when completing \"foo_bar\" (where _ is the position of point), | |
757 | it will consider all completions candidates matching the glob | |
758 | pattern \"foo*\" and will add back \"bar\" to the end of it.") | |
fcb68f70 SM |
759 | (basic |
760 | completion-basic-try-completion completion-basic-all-completions | |
79d74ac5 SM |
761 | "Completion of the prefix before point and the suffix after point. |
762 | I.e. when completing \"foo_bar\" (where _ is the position of point), | |
763 | it will consider all completions candidates matching the glob | |
764 | pattern \"foo*bar*\".") | |
34200787 | 765 | (partial-completion |
fcb68f70 SM |
766 | completion-pcm-try-completion completion-pcm-all-completions |
767 | "Completion of multiple words, each one taken as a prefix. | |
79d74ac5 SM |
768 | I.e. when completing \"l-co_h\" (where _ is the position of point), |
769 | it will consider all completions candidates matching the glob | |
770 | pattern \"l*-co*h*\". | |
771 | Furthermore, for completions that are done step by step in subfields, | |
772 | the method is applied to all the preceding fields that do not yet match. | |
773 | E.g. C-x C-f /u/mo/s TAB could complete to /usr/monnier/src. | |
774 | Additionally the user can use the char \"*\" as a glob pattern.") | |
56d365a9 SM |
775 | (substring |
776 | completion-substring-try-completion completion-substring-all-completions | |
777 | "Completion of the string taken as a substring. | |
778 | I.e. when completing \"foo_bar\" (where _ is the position of point), | |
779 | it will consider all completions candidates matching the glob | |
780 | pattern \"*foo*bar*\".") | |
fcb68f70 SM |
781 | (initials |
782 | completion-initials-try-completion completion-initials-all-completions | |
783 | "Completion of acronyms and initialisms. | |
784 | E.g. can complete M-x lch to list-command-history | |
785 | and C-x C-f ~/sew to ~/src/emacs/work.")) | |
e2947429 | 786 | "List of available completion styles. |
fcb68f70 | 787 | Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS DOC): |
26c548b0 | 788 | where NAME is the name that should be used in `completion-styles', |
fcb68f70 SM |
789 | TRY-COMPLETION is the function that does the completion (it should |
790 | follow the same calling convention as `completion-try-completion'), | |
791 | ALL-COMPLETIONS is the function that lists the completions (it should | |
792 | follow the calling convention of `completion-all-completions'), | |
793 | and DOC describes the way this style of completion works.") | |
e2947429 | 794 | |
3dc61a09 SM |
795 | (defconst completion--styles-type |
796 | `(repeat :tag "insert a new menu to add more styles" | |
797 | (choice ,@(mapcar (lambda (x) (list 'const (car x))) | |
798 | completion-styles-alist)))) | |
799 | (defconst completion--cycling-threshold-type | |
800 | '(choice (const :tag "No cycling" nil) | |
801 | (const :tag "Always cycle" t) | |
802 | (integer :tag "Threshold"))) | |
803 | ||
79d74ac5 SM |
804 | (defcustom completion-styles |
805 | ;; First, use `basic' because prefix completion has been the standard | |
806 | ;; for "ever" and works well in most cases, so using it first | |
807 | ;; ensures that we obey previous behavior in most cases. | |
808 | '(basic | |
809 | ;; Then use `partial-completion' because it has proven to | |
810 | ;; be a very convenient extension. | |
811 | partial-completion | |
812 | ;; Finally use `emacs22' so as to maintain (in many/most cases) | |
813 | ;; the previous behavior that when completing "foobar" with point | |
814 | ;; between "foo" and "bar" the completion try to complete "foo" | |
815 | ;; and simply add "bar" to the end of the result. | |
816 | emacs22) | |
265d4549 | 817 | "List of completion styles to use. |
693fbdb6 EZ |
818 | The available styles are listed in `completion-styles-alist'. |
819 | ||
820 | Note that `completion-category-overrides' may override these | |
821 | styles for specific categories, such as files, buffers, etc." | |
3dc61a09 | 822 | :type completion--styles-type |
e2947429 SM |
823 | :version "23.1") |
824 | ||
620c53a6 SM |
825 | (defcustom completion-category-overrides |
826 | '((buffer (styles . (basic substring)))) | |
693fbdb6 | 827 | "List of `completion-styles' overrides for specific categories. |
620c53a6 SM |
828 | Each override has the shape (CATEGORY . ALIST) where ALIST is |
829 | an association list that can specify properties such as: | |
830 | - `styles': the list of `completion-styles' to use for that category. | |
49fe4321 GM |
831 | - `cycle': the `completion-cycle-threshold' to use for that category. |
832 | Categories are symbols such as `buffer' and `file', used when | |
833 | completing buffer and file names, respectively." | |
2bed3f04 | 834 | :version "24.1" |
8ea0a993 SB |
835 | :type `(alist :key-type (choice :tag "Category" |
836 | (const buffer) | |
620c53a6 | 837 | (const file) |
3dc61a09 | 838 | (const unicode-name) |
55f197b2 | 839 | (const bookmark) |
620c53a6 SM |
840 | symbol) |
841 | :value-type | |
8ea0a993 SB |
842 | (set :tag "Properties to override" |
843 | (cons :tag "Completion Styles" | |
844 | (const :tag "Select a style from the menu;" styles) | |
3dc61a09 | 845 | ,completion--styles-type) |
8ea0a993 SB |
846 | (cons :tag "Completion Cycling" |
847 | (const :tag "Select one value from the menu." cycle) | |
3dc61a09 | 848 | ,completion--cycling-threshold-type)))) |
620c53a6 SM |
849 | |
850 | (defun completion--styles (metadata) | |
851 | (let* ((cat (completion-metadata-get metadata 'category)) | |
852 | (over (assq 'styles (cdr (assq cat completion-category-overrides))))) | |
853 | (if over | |
854 | (delete-dups (append (cdr over) (copy-sequence completion-styles))) | |
855 | completion-styles))) | |
856 | ||
ef24141c SM |
857 | (defun completion--nth-completion (n string table pred point metadata) |
858 | "Call the Nth method of completion styles." | |
859 | (unless metadata | |
860 | (setq metadata | |
861 | (completion-metadata (substring string 0 point) table pred))) | |
862 | ;; We provide special support for quoting/unquoting here because it cannot | |
863 | ;; reliably be done within the normal completion-table routines: Completion | |
864 | ;; styles such as `substring' or `partial-completion' need to match the | |
865 | ;; output of all-completions with the user's input, and since most/all | |
866 | ;; quoting mechanisms allow several equivalent quoted forms, the | |
867 | ;; completion-style can't do this matching (e.g. `substring' doesn't know | |
868 | ;; that "\a\b\e" is a valid (quoted) substring of "label"). | |
869 | ;; The quote/unquote function needs to come from the completion table (rather | |
870 | ;; than from completion-extra-properties) because it may apply only to some | |
871 | ;; part of the string (e.g. substitute-in-file-name). | |
872 | (let ((requote | |
873 | (when (completion-metadata-get metadata 'completion--unquote-requote) | |
e4829cb8 | 874 | (cl-assert (functionp table)) |
ef24141c SM |
875 | (let ((new (funcall table string point 'completion--unquote))) |
876 | (setq string (pop new)) | |
877 | (setq table (pop new)) | |
878 | (setq point (pop new)) | |
dccb0688 | 879 | (cl-assert (<= point (length string))) |
ef24141c | 880 | (pop new)))) |
675cab2c DC |
881 | (result |
882 | (completion--some (lambda (style) | |
883 | (funcall (nth n (assq style | |
884 | completion-styles-alist)) | |
885 | string table pred point)) | |
886 | (completion--styles metadata)))) | |
ef24141c SM |
887 | (if requote |
888 | (funcall requote result n) | |
889 | result))) | |
890 | ||
4cb3bfa0 | 891 | (defun completion-try-completion (string table pred point &optional metadata) |
19c04f39 SM |
892 | "Try to complete STRING using completion table TABLE. |
893 | Only the elements of table that satisfy predicate PRED are considered. | |
894 | POINT is the position of point within STRING. | |
895 | The return value can be either nil to indicate that there is no completion, | |
896 | t to indicate that STRING is the only possible completion, | |
ef24141c | 897 | or a pair (NEWSTRING . NEWPOINT) of the completed result string together with |
19c04f39 | 898 | a new position for point." |
ef24141c | 899 | (completion--nth-completion 1 string table pred point metadata)) |
e2947429 | 900 | |
4cb3bfa0 | 901 | (defun completion-all-completions (string table pred point &optional metadata) |
19c04f39 SM |
902 | "List the possible completions of STRING in completion table TABLE. |
903 | Only the elements of table that satisfy predicate PRED are considered. | |
904 | POINT is the position of point within STRING. | |
26c548b0 | 905 | The return value is a list of completions and may contain the base-size |
19c04f39 | 906 | in the last `cdr'." |
365b9a62 SM |
907 | ;; FIXME: We need to additionally return the info needed for the |
908 | ;; second part of completion-base-position. | |
ef24141c | 909 | (completion--nth-completion 2 string table pred point metadata)) |
e2947429 | 910 | |
ba5ff07b SM |
911 | (defun minibuffer--bitset (modified completions exact) |
912 | (logior (if modified 4 0) | |
913 | (if completions 2 0) | |
914 | (if exact 1 0))) | |
915 | ||
c53b9c3b SM |
916 | (defun completion--replace (beg end newtext) |
917 | "Replace the buffer text between BEG and END with NEWTEXT. | |
918 | Moves point to the end of the new text." | |
1d00653d SM |
919 | ;; The properties on `newtext' include things like |
920 | ;; completions-first-difference, which we don't want to include | |
921 | ;; upon insertion. | |
922 | (set-text-properties 0 (length newtext) nil newtext) | |
55586d2a | 923 | ;; Maybe this should be in subr.el. |
c53b9c3b SM |
924 | ;; You'd think this is trivial to do, but details matter if you want |
925 | ;; to keep markers "at the right place" and be robust in the face of | |
926 | ;; after-change-functions that may themselves modify the buffer. | |
55586d2a SM |
927 | (let ((prefix-len 0)) |
928 | ;; Don't touch markers in the shared prefix (if any). | |
929 | (while (and (< prefix-len (length newtext)) | |
930 | (< (+ beg prefix-len) end) | |
931 | (eq (char-after (+ beg prefix-len)) | |
932 | (aref newtext prefix-len))) | |
933 | (setq prefix-len (1+ prefix-len))) | |
934 | (unless (zerop prefix-len) | |
935 | (setq beg (+ beg prefix-len)) | |
936 | (setq newtext (substring newtext prefix-len)))) | |
937 | (let ((suffix-len 0)) | |
938 | ;; Don't touch markers in the shared suffix (if any). | |
939 | (while (and (< suffix-len (length newtext)) | |
940 | (< beg (- end suffix-len)) | |
941 | (eq (char-before (- end suffix-len)) | |
942 | (aref newtext (- (length newtext) suffix-len 1)))) | |
943 | (setq suffix-len (1+ suffix-len))) | |
944 | (unless (zerop suffix-len) | |
945 | (setq end (- end suffix-len)) | |
8348910a SM |
946 | (setq newtext (substring newtext 0 (- suffix-len)))) |
947 | (goto-char beg) | |
6cad7ba3 JS |
948 | (let ((length (- end beg))) ;Read `end' before we insert the text. |
949 | (insert-and-inherit newtext) | |
950 | (delete-region (point) (+ (point) length))) | |
8348910a | 951 | (forward-char suffix-len))) |
c53b9c3b | 952 | |
902a6d8d SM |
953 | (defcustom completion-cycle-threshold nil |
954 | "Number of completion candidates below which cycling is used. | |
67982e2b | 955 | Depending on this setting `completion-in-region' may use cycling, |
902a6d8d SM |
956 | like `minibuffer-force-complete'. |
957 | If nil, cycling is never used. | |
958 | If t, cycling is always used. | |
281c9d2b GM |
959 | If an integer, cycling is used so long as there are not more |
960 | completion candidates than this number." | |
2bed3f04 | 961 | :version "24.1" |
3dc61a09 | 962 | :type completion--cycling-threshold-type) |
902a6d8d | 963 | |
620c53a6 SM |
964 | (defun completion--cycle-threshold (metadata) |
965 | (let* ((cat (completion-metadata-get metadata 'category)) | |
966 | (over (assq 'cycle (cdr (assq cat completion-category-overrides))))) | |
967 | (if over (cdr over) completion-cycle-threshold))) | |
968 | ||
67982e2b | 969 | (defvar-local completion-all-sorted-completions nil) |
d92df117 | 970 | (defvar-local completion--all-sorted-completions-location nil) |
6175cd08 SM |
971 | (defvar completion-cycling nil) |
972 | ||
b7e270a2 SM |
973 | (defvar completion-fail-discreetly nil |
974 | "If non-nil, stay quiet when there is no match.") | |
975 | ||
ef80fc09 SM |
976 | (defun completion--message (msg) |
977 | (if completion-show-inline-help | |
978 | (minibuffer-message msg))) | |
979 | ||
67982e2b SM |
980 | (defun completion--do-completion (beg end &optional |
981 | try-completion-function expect-exact) | |
32bae13c | 982 | "Do the completion and return a summary of what happened. |
ba5ff07b SM |
983 | M = completion was performed, the text was Modified. |
984 | C = there were available Completions. | |
985 | E = after completion we now have an Exact match. | |
986 | ||
987 | MCE | |
988 | 000 0 no possible completion | |
989 | 001 1 was already an exact and unique completion | |
990 | 010 2 no completion happened | |
991 | 011 3 was already an exact completion | |
992 | 100 4 ??? impossible | |
993 | 101 5 ??? impossible | |
994 | 110 6 some completion happened | |
a2a25d24 SM |
995 | 111 7 completed to an exact completion |
996 | ||
997 | TRY-COMPLETION-FUNCTION is a function to use in place of `try-completion'. | |
998 | EXPECT-EXACT, if non-nil, means that there is no need to tell the user | |
999 | when the buffer's text is already an exact match." | |
67982e2b | 1000 | (let* ((string (buffer-substring beg end)) |
620c53a6 | 1001 | (md (completion--field-metadata beg)) |
a647cb26 SM |
1002 | (comp (funcall (or try-completion-function |
1003 | 'completion-try-completion) | |
1004 | string | |
1005 | minibuffer-completion-table | |
1006 | minibuffer-completion-predicate | |
620c53a6 SM |
1007 | (- (point) beg) |
1008 | md))) | |
32bae13c | 1009 | (cond |
19c04f39 | 1010 | ((null comp) |
890429cc | 1011 | (minibuffer-hide-completions) |
ef80fc09 | 1012 | (unless completion-fail-discreetly |
369e974d | 1013 | (ding) |
ef80fc09 | 1014 | (completion--message "No match")) |
b7e270a2 | 1015 | (minibuffer--bitset nil nil nil)) |
265d4549 | 1016 | ((eq t comp) |
890429cc | 1017 | (minibuffer-hide-completions) |
a2a25d24 SM |
1018 | (goto-char end) |
1019 | (completion--done string 'finished | |
1020 | (unless expect-exact "Sole completion")) | |
6175cd08 | 1021 | (minibuffer--bitset nil nil t)) ;Exact and unique match. |
32bae13c SM |
1022 | (t |
1023 | ;; `completed' should be t if some completion was done, which doesn't | |
1024 | ;; include simply changing the case of the entered string. However, | |
1025 | ;; for appearance, the string is rewritten if the case changes. | |
a647cb26 SM |
1026 | (let* ((comp-pos (cdr comp)) |
1027 | (completion (car comp)) | |
1028 | (completed (not (eq t (compare-strings completion nil nil | |
1029 | string nil nil t)))) | |
1030 | (unchanged (eq t (compare-strings completion nil nil | |
1031 | string nil nil nil)))) | |
c53b9c3b | 1032 | (if unchanged |
397ae226 | 1033 | (goto-char end) |
c53b9c3b | 1034 | ;; Insert in minibuffer the chars we got. |
67982e2b SM |
1035 | (completion--replace beg end completion) |
1036 | (setq end (+ beg (length completion)))) | |
c53b9c3b SM |
1037 | ;; Move point to its completion-mandated destination. |
1038 | (forward-char (- comp-pos (length completion))) | |
ba5ff07b | 1039 | |
32bae13c | 1040 | (if (not (or unchanged completed)) |
6175cd08 SM |
1041 | ;; The case of the string changed, but that's all. We're not sure |
1042 | ;; whether this is a unique completion or not, so try again using | |
1043 | ;; the real case (this shouldn't recurse again, because the next | |
1044 | ;; time try-completion will return either t or the exact string). | |
67982e2b SM |
1045 | (completion--do-completion beg end |
1046 | try-completion-function expect-exact) | |
32bae13c SM |
1047 | |
1048 | ;; It did find a match. Do we match some possibility exactly now? | |
620c53a6 | 1049 | (let* ((exact (test-completion completion |
3e88618b SM |
1050 | minibuffer-completion-table |
1051 | minibuffer-completion-predicate)) | |
620c53a6 | 1052 | (threshold (completion--cycle-threshold md)) |
3e88618b SM |
1053 | (comps |
1054 | ;; Check to see if we want to do cycling. We do it | |
1055 | ;; here, after having performed the normal completion, | |
1056 | ;; so as to take advantage of the difference between | |
1057 | ;; try-completion and all-completions, for things | |
1058 | ;; like completion-ignored-extensions. | |
620c53a6 | 1059 | (when (and threshold |
3e88618b SM |
1060 | ;; Check that the completion didn't make |
1061 | ;; us jump to a different boundary. | |
1062 | (or (not completed) | |
1063 | (< (car (completion-boundaries | |
1064 | (substring completion 0 comp-pos) | |
1065 | minibuffer-completion-table | |
1066 | minibuffer-completion-predicate | |
902a6d8d SM |
1067 | "")) |
1068 | comp-pos))) | |
67982e2b | 1069 | (completion-all-sorted-completions beg end)))) |
6175cd08 | 1070 | (completion--flush-all-sorted-completions) |
902a6d8d | 1071 | (cond |
6175cd08 SM |
1072 | ((and (consp (cdr comps)) ;; There's something to cycle. |
1073 | (not (ignore-errors | |
902a6d8d SM |
1074 | ;; This signal an (intended) error if comps is too |
1075 | ;; short or if completion-cycle-threshold is t. | |
620c53a6 | 1076 | (consp (nthcdr threshold comps))))) |
281c9d2b | 1077 | ;; Not more than completion-cycle-threshold remaining |
902a6d8d SM |
1078 | ;; completions: let's cycle. |
1079 | (setq completed t exact t) | |
67982e2b SM |
1080 | (completion--cache-all-sorted-completions beg end comps) |
1081 | (minibuffer-force-complete beg end)) | |
902a6d8d | 1082 | (completed |
6175cd08 SM |
1083 | ;; We could also decide to refresh the completions, |
1084 | ;; if they're displayed (and assuming there are | |
1085 | ;; completions left). | |
a2a25d24 SM |
1086 | (minibuffer-hide-completions) |
1087 | (if exact | |
1088 | ;; If completion did not put point at end of field, | |
1089 | ;; it's a sign that completion is not finished. | |
1090 | (completion--done completion | |
1091 | (if (< comp-pos (length completion)) | |
1092 | 'exact 'unknown)))) | |
6175cd08 SM |
1093 | ;; Show the completion table, if requested. |
1094 | ((not exact) | |
f58e0fd5 SM |
1095 | (if (pcase completion-auto-help |
1096 | (`lazy (eq this-command last-command)) | |
1097 | (_ completion-auto-help)) | |
67982e2b | 1098 | (minibuffer-completion-help beg end) |
ef80fc09 | 1099 | (completion--message "Next char not unique"))) |
6175cd08 | 1100 | ;; If the last exact completion and this one were the same, it |
ef80fc09 | 1101 | ;; means we've already given a "Complete, but not unique" message |
6175cd08 | 1102 | ;; and the user's hit TAB again, so now we give him help. |
a2a25d24 SM |
1103 | (t |
1104 | (if (and (eq this-command last-command) completion-auto-help) | |
67982e2b | 1105 | (minibuffer-completion-help beg end)) |
a2a25d24 SM |
1106 | (completion--done completion 'exact |
1107 | (unless expect-exact | |
1108 | "Complete, but not unique")))) | |
ba5ff07b SM |
1109 | |
1110 | (minibuffer--bitset completed t exact)))))))) | |
32bae13c SM |
1111 | |
1112 | (defun minibuffer-complete () | |
1113 | "Complete the minibuffer contents as far as possible. | |
1114 | Return nil if there is no valid completion, else t. | |
1115 | If no characters can be completed, display a list of possible completions. | |
1116 | If you repeat this command after it displayed such a list, | |
1117 | scroll the window of possible completions." | |
1118 | (interactive) | |
2395f2b9 DC |
1119 | (when (<= (minibuffer-prompt-end) (point)) |
1120 | (completion-in-region (minibuffer-prompt-end) (point-max) | |
1121 | minibuffer-completion-table | |
1122 | minibuffer-completion-predicate))) | |
67982e2b SM |
1123 | |
1124 | (defun completion--in-region-1 (beg end) | |
32bae13c SM |
1125 | ;; If the previous command was not this, |
1126 | ;; mark the completion buffer obsolete. | |
dbbc2e69 SM |
1127 | (setq this-command 'completion-at-point) |
1128 | (unless (eq 'completion-at-point last-command) | |
6175cd08 | 1129 | (completion--flush-all-sorted-completions) |
32bae13c SM |
1130 | (setq minibuffer-scroll-window nil)) |
1131 | ||
902a6d8d | 1132 | (cond |
03408648 SM |
1133 | ;; If there's a fresh completion window with a live buffer, |
1134 | ;; and this command is repeated, scroll that window. | |
21e8fe2f SM |
1135 | ((and (window-live-p minibuffer-scroll-window) |
1136 | (eq t (frame-visible-p (window-frame minibuffer-scroll-window)))) | |
902a6d8d | 1137 | (let ((window minibuffer-scroll-window)) |
03408648 SM |
1138 | (with-current-buffer (window-buffer window) |
1139 | (if (pos-visible-in-window-p (point-max) window) | |
1140 | ;; If end is in view, scroll up to the beginning. | |
1141 | (set-window-start window (point-min) nil) | |
1142 | ;; Else scroll down one screen. | |
c484f866 JS |
1143 | (with-selected-window window |
1144 | (scroll-up))) | |
902a6d8d SM |
1145 | nil))) |
1146 | ;; If we're cycling, keep on cycling. | |
6175cd08 | 1147 | ((and completion-cycling completion-all-sorted-completions) |
67982e2b | 1148 | (minibuffer-force-complete beg end) |
902a6d8d | 1149 | t) |
67982e2b | 1150 | (t (pcase (completion--do-completion beg end) |
a38313e1 | 1151 | (#b000 nil) |
f58e0fd5 | 1152 | (_ t))))) |
32bae13c | 1153 | |
67982e2b | 1154 | (defun completion--cache-all-sorted-completions (beg end comps) |
3e88618b | 1155 | (add-hook 'after-change-functions |
d92df117 SM |
1156 | 'completion--flush-all-sorted-completions nil t) |
1157 | (setq completion--all-sorted-completions-location | |
67982e2b | 1158 | (cons (copy-marker beg) (copy-marker end))) |
3e88618b SM |
1159 | (setq completion-all-sorted-completions comps)) |
1160 | ||
5c788776 | 1161 | (defun completion--flush-all-sorted-completions (&optional start end _len) |
d92df117 SM |
1162 | (unless (and start end |
1163 | (or (> start (cdr completion--all-sorted-completions-location)) | |
1164 | (< end (car completion--all-sorted-completions-location)))) | |
1165 | (remove-hook 'after-change-functions | |
1166 | 'completion--flush-all-sorted-completions t) | |
1167 | (setq completion-cycling nil) | |
1168 | (setq completion-all-sorted-completions nil))) | |
14c24780 | 1169 | |
30a23501 SM |
1170 | (defun completion--metadata (string base md-at-point table pred) |
1171 | ;; Like completion-metadata, but for the specific case of getting the | |
1172 | ;; metadata at `base', which tends to trigger pathological behavior for old | |
1173 | ;; completion tables which don't understand `metadata'. | |
1174 | (let ((bounds (completion-boundaries string table pred ""))) | |
1175 | (if (eq (car bounds) base) md-at-point | |
1176 | (completion-metadata (substring string 0 base) table pred)))) | |
1177 | ||
39587580 | 1178 | (defun completion-all-sorted-completions (&optional start end) |
14c24780 | 1179 | (or completion-all-sorted-completions |
67982e2b SM |
1180 | (let* ((start (or start (minibuffer-prompt-end))) |
1181 | (end (or end (point-max))) | |
620c53a6 | 1182 | (string (buffer-substring start end)) |
30a23501 | 1183 | (md (completion--field-metadata start)) |
620c53a6 SM |
1184 | (all (completion-all-completions |
1185 | string | |
1186 | minibuffer-completion-table | |
1187 | minibuffer-completion-predicate | |
1188 | (- (point) start) | |
30a23501 | 1189 | md)) |
14c24780 | 1190 | (last (last all)) |
620c53a6 | 1191 | (base-size (or (cdr last) 0)) |
30a23501 SM |
1192 | (all-md (completion--metadata (buffer-substring-no-properties |
1193 | start (point)) | |
1194 | base-size md | |
1195 | minibuffer-completion-table | |
1196 | minibuffer-completion-predicate)) | |
620c53a6 | 1197 | (sort-fun (completion-metadata-get all-md 'cycle-sort-function))) |
14c24780 SM |
1198 | (when last |
1199 | (setcdr last nil) | |
cc37e70f J |
1200 | |
1201 | ;; Delete duplicates: do it after setting last's cdr to nil (so | |
1202 | ;; it's a proper list), and be careful to reset `last' since it | |
1203 | ;; may be a different cons-cell. | |
1204 | (setq all (delete-dups all)) | |
1205 | (setq last (last all)) | |
1206 | ||
620c53a6 SM |
1207 | (setq all (if sort-fun (funcall sort-fun all) |
1208 | ;; Prefer shorter completions, by default. | |
1209 | (sort all (lambda (c1 c2) (< (length c1) (length c2)))))) | |
14c24780 | 1210 | ;; Prefer recently used completions. |
a2a25d24 SM |
1211 | (when (minibufferp) |
1212 | (let ((hist (symbol-value minibuffer-history-variable))) | |
1213 | (setq all (sort all (lambda (c1 c2) | |
1214 | (> (length (member c1 hist)) | |
1215 | (length (member c2 hist)))))))) | |
14c24780 SM |
1216 | ;; Cache the result. This is not just for speed, but also so that |
1217 | ;; repeated calls to minibuffer-force-complete can cycle through | |
1218 | ;; all possibilities. | |
67982e2b SM |
1219 | (completion--cache-all-sorted-completions |
1220 | start end (nconc all base-size)))))) | |
14c24780 | 1221 | |
cc37e70f J |
1222 | (defun minibuffer-force-complete-and-exit () |
1223 | "Complete the minibuffer with first of the matches and exit." | |
1224 | (interactive) | |
08c0f626 SM |
1225 | (if (and (eq (minibuffer-prompt-end) (point-max)) |
1226 | minibuffer-default) | |
1227 | ;; Use the provided default if there's one (bug#17545). | |
1228 | (minibuffer-complete-and-exit) | |
1229 | (minibuffer-force-complete) | |
1230 | (completion--complete-and-exit | |
1231 | (minibuffer-prompt-end) (point-max) #'exit-minibuffer | |
1232 | ;; If the previous completion completed to an element which fails | |
1233 | ;; test-completion, then we shouldn't exit, but that should be rare. | |
1234 | (lambda () (minibuffer-message "Incomplete"))))) | |
cc37e70f | 1235 | |
67982e2b | 1236 | (defun minibuffer-force-complete (&optional start end) |
14c24780 SM |
1237 | "Complete the minibuffer to an exact match. |
1238 | Repeated uses step through the possible completions." | |
1239 | (interactive) | |
21e8fe2f | 1240 | (setq minibuffer-scroll-window nil) |
14c24780 | 1241 | ;; FIXME: Need to deal with the extra-size issue here as well. |
528c56e2 SM |
1242 | ;; FIXME: ~/src/emacs/t<M-TAB>/lisp/minibuffer.el completes to |
1243 | ;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el. | |
67982e2b SM |
1244 | (let* ((start (copy-marker (or start (minibuffer-prompt-end)))) |
1245 | (end (or end (point-max))) | |
620c53a6 | 1246 | ;; (md (completion--field-metadata start)) |
67982e2b | 1247 | (all (completion-all-sorted-completions start end)) |
a2a25d24 SM |
1248 | (base (+ start (or (cdr (last all)) 0)))) |
1249 | (cond | |
1250 | ((not (consp all)) | |
ef80fc09 | 1251 | (completion--message |
a2a25d24 SM |
1252 | (if all "No more completions" "No completions"))) |
1253 | ((not (consp (cdr all))) | |
414a8595 SM |
1254 | (let ((done (equal (car all) (buffer-substring-no-properties base end)))) |
1255 | (unless done (completion--replace base end (car all))) | |
a2a25d24 | 1256 | (completion--done (buffer-substring-no-properties start (point)) |
414a8595 | 1257 | 'finished (when done "Sole completion")))) |
a2a25d24 | 1258 | (t |
a2a25d24 | 1259 | (completion--replace base end (car all)) |
67982e2b | 1260 | (setq end (+ base (length (car all)))) |
a2a25d24 | 1261 | (completion--done (buffer-substring-no-properties start (point)) 'sole) |
3e88618b SM |
1262 | ;; Set cycling after modifying the buffer since the flush hook resets it. |
1263 | (setq completion-cycling t) | |
67982e2b | 1264 | (setq this-command 'completion-at-point) ;For completion-in-region. |
14c24780 SM |
1265 | ;; If completing file names, (car all) may be a directory, so we'd now |
1266 | ;; have a new set of possible completions and might want to reset | |
1267 | ;; completion-all-sorted-completions to nil, but we prefer not to, | |
1268 | ;; so that repeated calls minibuffer-force-complete still cycle | |
1269 | ;; through the previous possible completions. | |
075518b5 SM |
1270 | (let ((last (last all))) |
1271 | (setcdr last (cons (car all) (cdr last))) | |
67982e2b | 1272 | (completion--cache-all-sorted-completions start end (cdr all))) |
8e808318 SM |
1273 | ;; Make sure repeated uses cycle, even though completion--done might |
1274 | ;; have added a space or something that moved us outside of the field. | |
1275 | ;; (bug#12221). | |
1276 | (let* ((table minibuffer-completion-table) | |
1277 | (pred minibuffer-completion-predicate) | |
1278 | (extra-prop completion-extra-properties) | |
1279 | (cmd | |
1280 | (lambda () "Cycle through the possible completions." | |
1281 | (interactive) | |
1282 | (let ((completion-extra-properties extra-prop)) | |
1283 | (completion-in-region start (point) table pred))))) | |
8cd22a08 | 1284 | (set-transient-map |
8e808318 SM |
1285 | (let ((map (make-sparse-keymap))) |
1286 | (define-key map [remap completion-at-point] cmd) | |
1287 | (define-key map (vector last-command-event) cmd) | |
1288 | map))))))) | |
14c24780 | 1289 | |
d1826585 | 1290 | (defvar minibuffer-confirm-exit-commands |
ec55c5e0 SM |
1291 | '(completion-at-point minibuffer-complete |
1292 | minibuffer-complete-word PC-complete PC-complete-word) | |
d1826585 MB |
1293 | "A list of commands which cause an immediately following |
1294 | `minibuffer-complete-and-exit' to ask for extra confirmation.") | |
1295 | ||
32bae13c | 1296 | (defun minibuffer-complete-and-exit () |
bec1e8a5 CY |
1297 | "Exit if the minibuffer contains a valid completion. |
1298 | Otherwise, try to complete the minibuffer contents. If | |
1299 | completion leads to a valid completion, a repetition of this | |
1300 | command will exit. | |
1301 | ||
1302 | If `minibuffer-completion-confirm' is `confirm', do not try to | |
1303 | complete; instead, ask for confirmation and accept any input if | |
1304 | confirmed. | |
1305 | If `minibuffer-completion-confirm' is `confirm-after-completion', | |
1306 | do not try to complete; instead, ask for confirmation if the | |
90810a8e CY |
1307 | preceding minibuffer command was a member of |
1308 | `minibuffer-confirm-exit-commands', and accept the input | |
1309 | otherwise." | |
32bae13c | 1310 | (interactive) |
67982e2b SM |
1311 | (completion-complete-and-exit (minibuffer-prompt-end) (point-max) |
1312 | #'exit-minibuffer)) | |
1313 | ||
1314 | (defun completion-complete-and-exit (beg end exit-function) | |
1315 | (completion--complete-and-exit | |
1316 | beg end exit-function | |
cc37e70f J |
1317 | (lambda () |
1318 | (pcase (condition-case nil | |
67982e2b SM |
1319 | (completion--do-completion beg end |
1320 | nil 'expect-exact) | |
cc37e70f | 1321 | (error 1)) |
67982e2b | 1322 | ((or #b001 #b011) (funcall exit-function)) |
cc37e70f | 1323 | (#b111 (if (not minibuffer-completion-confirm) |
67982e2b | 1324 | (funcall exit-function) |
cc37e70f J |
1325 | (minibuffer-message "Confirm") |
1326 | nil)) | |
1327 | (_ nil))))) | |
1328 | ||
67982e2b SM |
1329 | (defun completion--complete-and-exit (beg end |
1330 | exit-function completion-function) | |
cc37e70f J |
1331 | "Exit from `require-match' minibuffer. |
1332 | COMPLETION-FUNCTION is called if the current buffer's content does not | |
1333 | appear to be a match." | |
3911966b SM |
1334 | (cond |
1335 | ;; Allow user to specify null string | |
67982e2b | 1336 | ((= beg end) (funcall exit-function)) |
3911966b SM |
1337 | ((test-completion (buffer-substring beg end) |
1338 | minibuffer-completion-table | |
1339 | minibuffer-completion-predicate) | |
365b9a62 SM |
1340 | ;; FIXME: completion-ignore-case has various slightly |
1341 | ;; incompatible meanings. E.g. it can reflect whether the user | |
1342 | ;; wants completion to pay attention to case, or whether the | |
1343 | ;; string will be used in a context where case is significant. | |
1344 | ;; E.g. usually try-completion should obey the first, whereas | |
1345 | ;; test-completion should obey the second. | |
3911966b SM |
1346 | (when completion-ignore-case |
1347 | ;; Fixup case of the field, if necessary. | |
b0a5a021 | 1348 | (let* ((string (buffer-substring beg end)) |
3911966b SM |
1349 | (compl (try-completion |
1350 | string | |
1351 | minibuffer-completion-table | |
1352 | minibuffer-completion-predicate))) | |
365b9a62 | 1353 | (when (and (stringp compl) (not (equal string compl)) |
3911966b SM |
1354 | ;; If it weren't for this piece of paranoia, I'd replace |
1355 | ;; the whole thing with a call to do-completion. | |
eee6de73 SM |
1356 | ;; This is important, e.g. when the current minibuffer's |
1357 | ;; content is a directory which only contains a single | |
1358 | ;; file, so `try-completion' actually completes to | |
1359 | ;; that file. | |
3911966b | 1360 | (= (length string) (length compl))) |
96a8a0df | 1361 | (completion--replace beg end compl)))) |
67982e2b | 1362 | (funcall exit-function)) |
32bae13c | 1363 | |
365b9a62 | 1364 | ((memq minibuffer-completion-confirm '(confirm confirm-after-completion)) |
3911966b | 1365 | ;; The user is permitted to exit with an input that's rejected |
bec1e8a5 | 1366 | ;; by test-completion, after confirming her choice. |
365b9a62 SM |
1367 | (if (or (eq last-command this-command) |
1368 | ;; For `confirm-after-completion' we only ask for confirmation | |
1369 | ;; if trying to exit immediately after typing TAB (this | |
1370 | ;; catches most minibuffer typos). | |
1371 | (and (eq minibuffer-completion-confirm 'confirm-after-completion) | |
1372 | (not (memq last-command minibuffer-confirm-exit-commands)))) | |
67982e2b | 1373 | (funcall exit-function) |
3911966b SM |
1374 | (minibuffer-message "Confirm") |
1375 | nil)) | |
32bae13c | 1376 | |
3911966b SM |
1377 | (t |
1378 | ;; Call do-completion, but ignore errors. | |
67982e2b | 1379 | (funcall completion-function)))) |
3911966b | 1380 | |
620c53a6 SM |
1381 | (defun completion--try-word-completion (string table predicate point md) |
1382 | (let ((comp (completion-try-completion string table predicate point md))) | |
19c04f39 SM |
1383 | (if (not (consp comp)) |
1384 | comp | |
32bae13c | 1385 | |
3911966b SM |
1386 | ;; If completion finds next char not unique, |
1387 | ;; consider adding a space or a hyphen. | |
19c04f39 | 1388 | (when (= (length string) (length (car comp))) |
1afbbf85 SM |
1389 | ;; Mark the added char with the `completion-word' property, so it |
1390 | ;; can be handled specially by completion styles such as | |
1391 | ;; partial-completion. | |
1392 | ;; We used to remove `partial-completion' from completion-styles | |
1393 | ;; instead, but it was too blunt, leading to situations where SPC | |
1394 | ;; was the only insertable char at point but minibuffer-complete-word | |
1395 | ;; refused inserting it. | |
bf67c3f7 SM |
1396 | (let ((exts (mapcar (lambda (str) (propertize str 'completion-try-word t)) |
1397 | '(" " "-"))) | |
1398 | (before (substring string 0 point)) | |
1399 | (after (substring string point)) | |
1400 | tem) | |
1401 | ;; If both " " and "-" lead to completions, prefer " " so SPC behaves | |
1402 | ;; a bit more like a self-inserting key (bug#17375). | |
1403 | (while (and exts (not (consp tem))) | |
1404 | (setq tem (completion-try-completion | |
1405 | (concat before (pop exts) after) | |
1406 | table predicate (1+ point) md))) | |
1407 | (if (consp tem) (setq comp tem)))) | |
3911966b | 1408 | |
32bae13c SM |
1409 | ;; Completing a single word is actually more difficult than completing |
1410 | ;; as much as possible, because we first have to find the "current | |
1411 | ;; position" in `completion' in order to find the end of the word | |
1412 | ;; we're completing. Normally, `string' is a prefix of `completion', | |
1413 | ;; which makes it trivial to find the position, but with fancier | |
1414 | ;; completion (plus env-var expansion, ...) `completion' might not | |
1415 | ;; look anything like `string' at all. | |
19c04f39 SM |
1416 | (let* ((comppoint (cdr comp)) |
1417 | (completion (car comp)) | |
1418 | (before (substring string 0 point)) | |
1419 | (combined (concat before "\n" completion))) | |
1420 | ;; Find in completion the longest text that was right before point. | |
1421 | (when (string-match "\\(.+\\)\n.*?\\1" combined) | |
1422 | (let* ((prefix (match-string 1 before)) | |
1423 | ;; We used non-greedy match to make `rem' as long as possible. | |
1424 | (rem (substring combined (match-end 0))) | |
1425 | ;; Find in the remainder of completion the longest text | |
1426 | ;; that was right after point. | |
1427 | (after (substring string point)) | |
1428 | (suffix (if (string-match "\\`\\(.+\\).*\n.*\\1" | |
1429 | (concat after "\n" rem)) | |
1430 | (match-string 1 after)))) | |
1431 | ;; The general idea is to try and guess what text was inserted | |
1432 | ;; at point by the completion. Problem is: if we guess wrong, | |
1433 | ;; we may end up treating as "added by completion" text that was | |
1434 | ;; actually painfully typed by the user. So if we then cut | |
1435 | ;; after the first word, we may throw away things the | |
1436 | ;; user wrote. So let's try to be as conservative as possible: | |
1437 | ;; only cut after the first word, if we're reasonably sure that | |
1438 | ;; our guess is correct. | |
1439 | ;; Note: a quick survey on emacs-devel seemed to indicate that | |
1440 | ;; nobody actually cares about the "word-at-a-time" feature of | |
1441 | ;; minibuffer-complete-word, whose real raison-d'être is that it | |
1442 | ;; tries to add "-" or " ". One more reason to only cut after | |
1443 | ;; the first word, if we're really sure we're right. | |
1444 | (when (and (or suffix (zerop (length after))) | |
1445 | (string-match (concat | |
1446 | ;; Make submatch 1 as small as possible | |
1447 | ;; to reduce the risk of cutting | |
1448 | ;; valuable text. | |
1449 | ".*" (regexp-quote prefix) "\\(.*?\\)" | |
1450 | (if suffix (regexp-quote suffix) "\\'")) | |
1451 | completion) | |
1452 | ;; The new point in `completion' should also be just | |
1453 | ;; before the suffix, otherwise something more complex | |
1454 | ;; is going on, and we're not sure where we are. | |
1455 | (eq (match-end 1) comppoint) | |
1456 | ;; (match-beginning 1)..comppoint is now the stretch | |
1457 | ;; of text in `completion' that was completed at point. | |
1458 | (string-match "\\W" completion (match-beginning 1)) | |
1459 | ;; Is there really something to cut? | |
1460 | (> comppoint (match-end 0))) | |
1461 | ;; Cut after the first word. | |
1462 | (let ((cutpos (match-end 0))) | |
1463 | (setq completion (concat (substring completion 0 cutpos) | |
1464 | (substring completion comppoint))) | |
1465 | (setq comppoint cutpos))))) | |
1466 | ||
1467 | (cons completion comppoint))))) | |
ba5ff07b SM |
1468 | |
1469 | ||
1470 | (defun minibuffer-complete-word () | |
1471 | "Complete the minibuffer contents at most a single word. | |
1472 | After one word is completed as much as possible, a space or hyphen | |
1473 | is added, provided that matches some possible completion. | |
1474 | Return nil if there is no valid completion, else t." | |
1475 | (interactive) | |
67982e2b SM |
1476 | (completion-in-region--single-word |
1477 | (minibuffer-prompt-end) (point-max) | |
1478 | minibuffer-completion-table minibuffer-completion-predicate)) | |
1479 | ||
1480 | (defun completion-in-region--single-word (beg end collection | |
1481 | &optional predicate) | |
1482 | (let ((minibuffer-completion-table collection) | |
1483 | (minibuffer-completion-predicate predicate)) | |
1484 | (pcase (completion--do-completion beg end | |
1485 | #'completion--try-word-completion) | |
a38313e1 | 1486 | (#b000 nil) |
67982e2b | 1487 | (_ t)))) |
ba5ff07b | 1488 | |
890429cc SM |
1489 | (defface completions-annotations '((t :inherit italic)) |
1490 | "Face to use for annotations in the *Completions* buffer.") | |
1491 | ||
8f3b8a5f | 1492 | (defcustom completions-format 'horizontal |
3a9f97fa JL |
1493 | "Define the appearance and sorting of completions. |
1494 | If the value is `vertical', display completions sorted vertically | |
1495 | in columns in the *Completions* buffer. | |
8f3b8a5f | 1496 | If the value is `horizontal', display completions sorted |
3a9f97fa | 1497 | horizontally in alphabetical order, rather than down the screen." |
8f3b8a5f | 1498 | :type '(choice (const horizontal) (const vertical)) |
3a9f97fa JL |
1499 | :version "23.2") |
1500 | ||
3911966b | 1501 | (defun completion--insert-strings (strings) |
32bae13c SM |
1502 | "Insert a list of STRINGS into the current buffer. |
1503 | Uses columns to keep the listing readable but compact. | |
1504 | It also eliminates runs of equal strings." | |
1505 | (when (consp strings) | |
1506 | (let* ((length (apply 'max | |
1507 | (mapcar (lambda (s) | |
1508 | (if (consp s) | |
e5b5b82d SM |
1509 | (+ (string-width (car s)) |
1510 | (string-width (cadr s))) | |
1511 | (string-width s))) | |
32bae13c SM |
1512 | strings))) |
1513 | (window (get-buffer-window (current-buffer) 0)) | |
1514 | (wwidth (if window (1- (window-width window)) 79)) | |
1515 | (columns (min | |
1516 | ;; At least 2 columns; at least 2 spaces between columns. | |
1517 | (max 2 (/ wwidth (+ 2 length))) | |
1518 | ;; Don't allocate more columns than we can fill. | |
1519 | ;; Windows can't show less than 3 lines anyway. | |
1520 | (max 1 (/ (length strings) 2)))) | |
1521 | (colwidth (/ wwidth columns)) | |
1522 | (column 0) | |
3a9f97fa JL |
1523 | (rows (/ (length strings) columns)) |
1524 | (row 0) | |
ae0bc9fb | 1525 | (first t) |
32bae13c SM |
1526 | (laststring nil)) |
1527 | ;; The insertion should be "sensible" no matter what choices were made | |
1528 | ;; for the parameters above. | |
1529 | (dolist (str strings) | |
f87ff539 | 1530 | (unless (equal laststring str) ; Remove (consecutive) duplicates. |
32bae13c | 1531 | (setq laststring str) |
ae0bc9fb SM |
1532 | ;; FIXME: `string-width' doesn't pay attention to |
1533 | ;; `display' properties. | |
f87ff539 SM |
1534 | (let ((length (if (consp str) |
1535 | (+ (string-width (car str)) | |
1536 | (string-width (cadr str))) | |
1537 | (string-width str)))) | |
3a9f97fa JL |
1538 | (cond |
1539 | ((eq completions-format 'vertical) | |
1540 | ;; Vertical format | |
1541 | (when (> row rows) | |
1542 | (forward-line (- -1 rows)) | |
1543 | (setq row 0 column (+ column colwidth))) | |
1544 | (when (> column 0) | |
1545 | (end-of-line) | |
1546 | (while (> (current-column) column) | |
1547 | (if (eobp) | |
1548 | (insert "\n") | |
1549 | (forward-line 1) | |
1550 | (end-of-line))) | |
1551 | (insert " \t") | |
ae0bc9fb | 1552 | (set-text-properties (1- (point)) (point) |
3a9f97fa JL |
1553 | `(display (space :align-to ,column))))) |
1554 | (t | |
1555 | ;; Horizontal format | |
ae0bc9fb | 1556 | (unless first |
3a9f97fa JL |
1557 | (if (< wwidth (+ (max colwidth length) column)) |
1558 | ;; No space for `str' at point, move to next line. | |
1559 | (progn (insert "\n") (setq column 0)) | |
1560 | (insert " \t") | |
1561 | ;; Leave the space unpropertized so that in the case we're | |
1562 | ;; already past the goal column, there is still | |
1563 | ;; a space displayed. | |
ae0bc9fb | 1564 | (set-text-properties (1- (point)) (point) |
3a9f97fa | 1565 | ;; We can't just set tab-width, because |
3e2d70fd SM |
1566 | ;; completion-setup-function will kill |
1567 | ;; all local variables :-( | |
3a9f97fa JL |
1568 | `(display (space :align-to ,column))) |
1569 | nil)))) | |
ae0bc9fb | 1570 | (setq first nil) |
f87ff539 | 1571 | (if (not (consp str)) |
e59e73d8 | 1572 | (put-text-property (point) (progn (insert str) (point)) |
f87ff539 | 1573 | 'mouse-face 'highlight) |
e59e73d8 | 1574 | (put-text-property (point) (progn (insert (car str)) (point)) |
f87ff539 | 1575 | 'mouse-face 'highlight) |
c7a409b6 DG |
1576 | (let ((beg (point)) |
1577 | (end (progn (insert (cadr str)) (point)))) | |
1578 | (put-text-property beg end 'mouse-face nil) | |
1579 | (font-lock-prepend-text-property beg end 'face | |
1580 | 'completions-annotations))) | |
3a9f97fa JL |
1581 | (cond |
1582 | ((eq completions-format 'vertical) | |
1583 | ;; Vertical format | |
1584 | (if (> column 0) | |
1585 | (forward-line) | |
1586 | (insert "\n")) | |
1587 | (setq row (1+ row))) | |
1588 | (t | |
1589 | ;; Horizontal format | |
1590 | ;; Next column to align to. | |
1591 | (setq column (+ column | |
1592 | ;; Round up to a whole number of columns. | |
1593 | (* colwidth (ceiling length colwidth)))))))))))) | |
32bae13c | 1594 | |
6138158d SM |
1595 | (defvar completion-common-substring nil) |
1596 | (make-obsolete-variable 'completion-common-substring nil "23.1") | |
32bae13c | 1597 | |
21622c6d SM |
1598 | (defvar completion-setup-hook nil |
1599 | "Normal hook run at the end of setting up a completion list buffer. | |
1600 | When this hook is run, the current buffer is the one in which the | |
1601 | command to display the completion list buffer was run. | |
1602 | The completion list buffer is available as the value of `standard-output'. | |
6138158d SM |
1603 | See also `display-completion-list'.") |
1604 | ||
1605 | (defface completions-first-difference | |
1606 | '((t (:inherit bold))) | |
5e618aba GM |
1607 | "Face for the first uncommon character in completions. |
1608 | See also the face `completions-common-part'.") | |
6138158d | 1609 | |
c7a409b6 | 1610 | (defface completions-common-part '((t nil)) |
5e618aba GM |
1611 | "Face for the common prefix substring in completions. |
1612 | The idea of this face is that you can use it to make the common parts | |
1613 | less visible than normal, so that the differing parts are emphasized | |
1614 | by contrast. | |
1615 | See also the face `completions-first-difference'.") | |
6138158d | 1616 | |
b829360f | 1617 | (defun completion-hilit-commonality (completions prefix-len &optional base-size) |
5e618aba GM |
1618 | "Apply font-lock highlighting to a list of completions, COMPLETIONS. |
1619 | PREFIX-LEN is an integer. BASE-SIZE is an integer or nil (meaning zero). | |
1620 | ||
1621 | This adds the face `completions-common-part' to the first | |
1622 | \(PREFIX-LEN - BASE-SIZE) characters of each completion, and the face | |
1623 | `completions-first-difference' to the first character after that. | |
1624 | ||
1625 | It returns a list with font-lock properties applied to each element, | |
1626 | and with BASE-SIZE appended as the last element." | |
6138158d | 1627 | (when completions |
3106d59b GM |
1628 | (let ((com-str-len (- prefix-len (or base-size 0)))) |
1629 | (nconc | |
1630 | (mapcar | |
1631 | (lambda (elem) | |
1632 | (let ((str | |
1633 | ;; Don't modify the string itself, but a copy, since the | |
1634 | ;; the string may be read-only or used for other purposes. | |
1635 | ;; Furthermore, since `completions' may come from | |
1636 | ;; display-completion-list, `elem' may be a list. | |
1637 | (if (consp elem) | |
1638 | (car (setq elem (cons (copy-sequence (car elem)) | |
1639 | (cdr elem)))) | |
1640 | (setq elem (copy-sequence elem))))) | |
1641 | (font-lock-prepend-text-property | |
1642 | 0 | |
1643 | ;; If completion-boundaries returns incorrect | |
1644 | ;; values, all-completions may return strings | |
1645 | ;; that don't contain the prefix. | |
1646 | (min com-str-len (length str)) | |
1647 | 'face 'completions-common-part str) | |
1648 | (if (> (length str) com-str-len) | |
1649 | (font-lock-prepend-text-property com-str-len (1+ com-str-len) | |
1650 | 'face | |
1651 | 'completions-first-difference | |
1652 | str))) | |
1653 | elem) | |
1654 | completions) | |
1655 | base-size)))) | |
21622c6d | 1656 | |
7bc7f64d | 1657 | (defun display-completion-list (completions &optional common-substring) |
32bae13c SM |
1658 | "Display the list of completions, COMPLETIONS, using `standard-output'. |
1659 | Each element may be just a symbol or string | |
1660 | or may be a list of two strings to be printed as if concatenated. | |
1661 | If it is a list of two strings, the first is the actual completion | |
1662 | alternative, the second serves as annotation. | |
1663 | `standard-output' must be a buffer. | |
1664 | The actual completion alternatives, as inserted, are given `mouse-face' | |
1665 | properties of `highlight'. | |
1666 | At the end, this runs the normal hook `completion-setup-hook'. | |
67982e2b SM |
1667 | It can find the completion buffer in `standard-output'." |
1668 | (declare (advertised-calling-convention (completions) "24.4")) | |
6138158d SM |
1669 | (if common-substring |
1670 | (setq completions (completion-hilit-commonality | |
125f7951 SM |
1671 | completions (length common-substring) |
1672 | ;; We don't know the base-size. | |
1673 | nil))) | |
32bae13c SM |
1674 | (if (not (bufferp standard-output)) |
1675 | ;; This *never* (ever) happens, so there's no point trying to be clever. | |
1676 | (with-temp-buffer | |
1677 | (let ((standard-output (current-buffer)) | |
1678 | (completion-setup-hook nil)) | |
7bc7f64d | 1679 | (display-completion-list completions common-substring)) |
32bae13c SM |
1680 | (princ (buffer-string))) |
1681 | ||
d5e63715 SM |
1682 | (with-current-buffer standard-output |
1683 | (goto-char (point-max)) | |
1684 | (if (null completions) | |
1685 | (insert "There are no possible completions of what you have typed.") | |
1686 | (insert "Possible completions are:\n") | |
1687 | (completion--insert-strings completions)))) | |
e2947429 | 1688 | |
6138158d SM |
1689 | ;; The hilit used to be applied via completion-setup-hook, so there |
1690 | ;; may still be some code that uses completion-common-substring. | |
7ce8dff2 CY |
1691 | (with-no-warnings |
1692 | (let ((completion-common-substring common-substring)) | |
1693 | (run-hooks 'completion-setup-hook))) | |
32bae13c SM |
1694 | nil) |
1695 | ||
a2a25d24 SM |
1696 | (defvar completion-extra-properties nil |
1697 | "Property list of extra properties of the current completion job. | |
1698 | These include: | |
321cc491 CY |
1699 | |
1700 | `:annotation-function': Function to annotate the completions buffer. | |
1701 | The function must accept one argument, a completion string, | |
1702 | and return either nil or a string which is to be displayed | |
1703 | next to the completion (but which is not part of the | |
1704 | completion). The function can access the completion data via | |
1705 | `minibuffer-completion-table' and related variables. | |
1706 | ||
a2a25d24 | 1707 | `:exit-function': Function to run after completion is performed. |
321cc491 CY |
1708 | |
1709 | The function must accept two arguments, STRING and STATUS. | |
1710 | STRING is the text to which the field was completed, and | |
1711 | STATUS indicates what kind of operation happened: | |
1712 | `finished' - text is now complete | |
1713 | `sole' - text cannot be further completed but | |
1714 | completion is not finished | |
1715 | `exact' - text is a valid completion but may be further | |
1716 | completed.") | |
a2a25d24 | 1717 | |
ab22be48 SM |
1718 | (defvar completion-annotate-function |
1719 | nil | |
1720 | ;; Note: there's a lot of scope as for when to add annotations and | |
1721 | ;; what annotations to add. E.g. completing-help.el allowed adding | |
1722 | ;; the first line of docstrings to M-x completion. But there's | |
1723 | ;; a tension, since such annotations, while useful at times, can | |
1724 | ;; actually drown the useful information. | |
1725 | ;; So completion-annotate-function should be used parsimoniously, or | |
1726 | ;; else only used upon a user's request (e.g. we could add a command | |
1727 | ;; to completion-list-mode to add annotations to the current | |
1728 | ;; completions). | |
1729 | "Function to add annotations in the *Completions* buffer. | |
1730 | The function takes a completion and should either return nil, or a string that | |
1731 | will be displayed next to the completion. The function can access the | |
1732 | completion table and predicates via `minibuffer-completion-table' and related | |
1733 | variables.") | |
a2a25d24 SM |
1734 | (make-obsolete-variable 'completion-annotate-function |
1735 | 'completion-extra-properties "24.1") | |
1736 | ||
1737 | (defun completion--done (string &optional finished message) | |
1738 | (let* ((exit-fun (plist-get completion-extra-properties :exit-function)) | |
1739 | (pre-msg (and exit-fun (current-message)))) | |
f58e0fd5 | 1740 | (cl-assert (memq finished '(exact sole finished unknown))) |
a2a25d24 SM |
1741 | (when exit-fun |
1742 | (when (eq finished 'unknown) | |
1743 | (setq finished | |
1744 | (if (eq (try-completion string | |
1745 | minibuffer-completion-table | |
1746 | minibuffer-completion-predicate) | |
1747 | t) | |
1748 | 'finished 'exact))) | |
1749 | (funcall exit-fun string finished)) | |
1750 | (when (and message | |
1751 | ;; Don't output any message if the exit-fun already did so. | |
1752 | (equal pre-msg (and exit-fun (current-message)))) | |
1753 | (completion--message message)))) | |
ab22be48 | 1754 | |
67982e2b | 1755 | (defun minibuffer-completion-help (&optional start end) |
32bae13c SM |
1756 | "Display a list of possible completions of the current minibuffer contents." |
1757 | (interactive) | |
1758 | (message "Making completion list...") | |
67982e2b SM |
1759 | (let* ((start (or start (minibuffer-prompt-end))) |
1760 | (end (or end (point-max))) | |
1761 | (string (buffer-substring start end)) | |
30a23501 | 1762 | (md (completion--field-metadata start)) |
a647cb26 SM |
1763 | (completions (completion-all-completions |
1764 | string | |
1765 | minibuffer-completion-table | |
1766 | minibuffer-completion-predicate | |
67982e2b | 1767 | (- (point) start) |
30a23501 | 1768 | md))) |
32bae13c | 1769 | (message nil) |
a2a25d24 SM |
1770 | (if (or (null completions) |
1771 | (and (not (consp (cdr completions))) | |
1772 | (equal (car completions) string))) | |
1773 | (progn | |
1774 | ;; If there are no completions, or if the current input is already | |
1775 | ;; the sole completion, then hide (previous&stale) completions. | |
1776 | (minibuffer-hide-completions) | |
1777 | (ding) | |
1778 | (minibuffer-message | |
1779 | (if completions "Sole completion" "No completions"))) | |
1780 | ||
1781 | (let* ((last (last completions)) | |
65cdacb5 | 1782 | (base-size (cdr last)) |
a2a25d24 | 1783 | (prefix (unless (zerop base-size) (substring string 0 base-size))) |
30a23501 SM |
1784 | (all-md (completion--metadata (buffer-substring-no-properties |
1785 | start (point)) | |
1786 | base-size md | |
1787 | minibuffer-completion-table | |
1788 | minibuffer-completion-predicate)) | |
620c53a6 SM |
1789 | (afun (or (completion-metadata-get all-md 'annotation-function) |
1790 | (plist-get completion-extra-properties | |
1791 | :annotation-function) | |
1792 | completion-annotate-function)) | |
a2a25d24 SM |
1793 | ;; If the *Completions* buffer is shown in a new |
1794 | ;; window, mark it as softly-dedicated, so bury-buffer in | |
1795 | ;; minibuffer-hide-completions will know whether to | |
1796 | ;; delete the window or not. | |
1797 | (display-buffer-mark-dedicated 'soft)) | |
1798 | (with-output-to-temp-buffer "*Completions*" | |
1799 | ;; Remove the base-size tail because `sort' requires a properly | |
1800 | ;; nil-terminated list. | |
1801 | (when last (setcdr last nil)) | |
a2a25d24 | 1802 | (setq completions |
620c53a6 SM |
1803 | ;; FIXME: This function is for the output of all-completions, |
1804 | ;; not completion-all-completions. Often it's the same, but | |
1805 | ;; not always. | |
1806 | (let ((sort-fun (completion-metadata-get | |
1807 | all-md 'display-sort-function))) | |
1808 | (if sort-fun | |
1809 | (funcall sort-fun completions) | |
1810 | (sort completions 'string-lessp)))) | |
1811 | (when afun | |
1812 | (setq completions | |
a2a25d24 | 1813 | (mapcar (lambda (s) |
620c53a6 | 1814 | (let ((ann (funcall afun s))) |
a2a25d24 | 1815 | (if ann (list s ann) s))) |
620c53a6 | 1816 | completions))) |
a2a25d24 SM |
1817 | |
1818 | (with-current-buffer standard-output | |
1819 | (set (make-local-variable 'completion-base-position) | |
1820 | (list (+ start base-size) | |
1821 | ;; FIXME: We should pay attention to completion | |
1822 | ;; boundaries here, but currently | |
1823 | ;; completion-all-completions does not give us the | |
1824 | ;; necessary information. | |
1825 | end)) | |
1826 | (set (make-local-variable 'completion-list-insert-choice-function) | |
1827 | (let ((ctable minibuffer-completion-table) | |
1828 | (cpred minibuffer-completion-predicate) | |
1829 | (cprops completion-extra-properties)) | |
1830 | (lambda (start end choice) | |
620c53a6 SM |
1831 | (unless (or (zerop (length prefix)) |
1832 | (equal prefix | |
1833 | (buffer-substring-no-properties | |
1834 | (max (point-min) | |
1835 | (- start (length prefix))) | |
1836 | start))) | |
a2a25d24 SM |
1837 | (message "*Completions* out of date")) |
1838 | ;; FIXME: Use `md' to do quoting&terminator here. | |
1839 | (completion--replace start end choice) | |
1840 | (let* ((minibuffer-completion-table ctable) | |
1841 | (minibuffer-completion-predicate cpred) | |
1842 | (completion-extra-properties cprops) | |
1843 | (result (concat prefix choice)) | |
1844 | (bounds (completion-boundaries | |
1845 | result ctable cpred ""))) | |
1846 | ;; If the completion introduces a new field, then | |
1847 | ;; completion is not finished. | |
1848 | (completion--done result | |
1849 | (if (eq (car bounds) (length result)) | |
1850 | 'exact 'finished))))))) | |
1851 | ||
1852 | (display-completion-list completions)))) | |
32bae13c SM |
1853 | nil)) |
1854 | ||
890429cc SM |
1855 | (defun minibuffer-hide-completions () |
1856 | "Get rid of an out-of-date *Completions* buffer." | |
1857 | ;; FIXME: We could/should use minibuffer-scroll-window here, but it | |
1858 | ;; can also point to the minibuffer-parent-window, so it's a bit tricky. | |
1859 | (let ((win (get-buffer-window "*Completions*" 0))) | |
1860 | (if win (with-selected-window win (bury-buffer))))) | |
1861 | ||
32bae13c SM |
1862 | (defun exit-minibuffer () |
1863 | "Terminate this minibuffer argument." | |
1864 | (interactive) | |
1865 | ;; If the command that uses this has made modifications in the minibuffer, | |
1866 | ;; we don't want them to cause deactivation of the mark in the original | |
1867 | ;; buffer. | |
1868 | ;; A better solution would be to make deactivate-mark buffer-local | |
1869 | ;; (or to turn it into a list of buffers, ...), but in the mean time, | |
1870 | ;; this should do the trick in most cases. | |
ba5ff07b | 1871 | (setq deactivate-mark nil) |
32bae13c SM |
1872 | (throw 'exit nil)) |
1873 | ||
1874 | (defun self-insert-and-exit () | |
1875 | "Terminate minibuffer input." | |
1876 | (interactive) | |
8989a920 | 1877 | (if (characterp last-command-event) |
32bae13c SM |
1878 | (call-interactively 'self-insert-command) |
1879 | (ding)) | |
1880 | (exit-minibuffer)) | |
1881 | ||
a185548b | 1882 | (defvar completion-in-region-functions nil |
4a12fa5c | 1883 | "Wrapper hook around `completion--in-region'.") |
d36ed1c8 SM |
1884 | (make-obsolete-variable 'completion-in-region-functions |
1885 | 'completion-in-region-function "24.4") | |
1886 | ||
1887 | (defvar completion-in-region-function #'completion--in-region | |
1888 | "Function to perform the job of `completion-in-region'. | |
1889 | The function is called with 4 arguments: START END COLLECTION PREDICATE. | |
4a12fa5c | 1890 | The arguments and expected return value are as specified for |
d36ed1c8 | 1891 | `completion-in-region'.") |
a185548b | 1892 | |
3e2d70fd SM |
1893 | (defvar completion-in-region--data nil) |
1894 | ||
e240cc21 SM |
1895 | (defvar completion-in-region-mode-predicate nil |
1896 | "Predicate to tell `completion-in-region-mode' when to exit. | |
1897 | It is called with no argument and should return nil when | |
1898 | `completion-in-region-mode' should exit (and hence pop down | |
1899 | the *Completions* buffer).") | |
1900 | ||
1901 | (defvar completion-in-region-mode--predicate nil | |
1902 | "Copy of the value of `completion-in-region-mode-predicate'. | |
1903 | This holds the value `completion-in-region-mode-predicate' had when | |
1904 | we entered `completion-in-region-mode'.") | |
1905 | ||
a185548b SM |
1906 | (defun completion-in-region (start end collection &optional predicate) |
1907 | "Complete the text between START and END using COLLECTION. | |
08549772 | 1908 | Point needs to be somewhere between START and END. |
4a12fa5c GM |
1909 | PREDICATE (a function called with no arguments) says when to exit. |
1910 | This calls the function that `completion-in-region-function' specifies | |
1911 | \(passing the same four arguments that it received) to do the work, | |
1912 | and returns whatever it does. The return value should be nil | |
1913 | if there was no valid completion, else t." | |
f58e0fd5 | 1914 | (cl-assert (<= start (point)) (<= (point) end)) |
d36ed1c8 SM |
1915 | (funcall completion-in-region-function start end collection predicate)) |
1916 | ||
02d844b5 GM |
1917 | (defcustom read-file-name-completion-ignore-case |
1918 | (if (memq system-type '(ms-dos windows-nt darwin cygwin)) | |
1919 | t nil) | |
1920 | "Non-nil means when reading a file name completion ignores case." | |
02d844b5 GM |
1921 | :type 'boolean |
1922 | :version "22.1") | |
1923 | ||
d36ed1c8 | 1924 | (defun completion--in-region (start end collection &optional predicate) |
4a12fa5c GM |
1925 | "Default function to use for `completion-in-region-function'. |
1926 | Its arguments and return value are as specified for `completion-in-region'. | |
1927 | This respects the wrapper hook `completion-in-region-functions'." | |
a185548b | 1928 | (with-wrapper-hook |
d86d2721 SM |
1929 | ;; FIXME: Maybe we should use this hook to provide a "display |
1930 | ;; completions" operation as well. | |
a185548b SM |
1931 | completion-in-region-functions (start end collection predicate) |
1932 | (let ((minibuffer-completion-table collection) | |
67982e2b | 1933 | (minibuffer-completion-predicate predicate)) |
7a2c7ca7 CY |
1934 | ;; HACK: if the text we are completing is already in a field, we |
1935 | ;; want the completion field to take priority (e.g. Bug#6830). | |
e240cc21 | 1936 | (when completion-in-region-mode-predicate |
e240cc21 | 1937 | (setq completion-in-region--data |
504a0381 SM |
1938 | `(,(if (markerp start) start (copy-marker start)) |
1939 | ,(copy-marker end t) ,collection ,predicate)) | |
1940 | (completion-in-region-mode 1)) | |
67982e2b | 1941 | (completion--in-region-1 start end)))) |
8ba31f36 | 1942 | |
3e2d70fd SM |
1943 | (defvar completion-in-region-mode-map |
1944 | (let ((map (make-sparse-keymap))) | |
c0a193ea SM |
1945 | ;; FIXME: Only works if completion-in-region-mode was activated via |
1946 | ;; completion-at-point called directly. | |
82b24fb2 | 1947 | (define-key map "\M-?" 'completion-help-at-point) |
3e2d70fd SM |
1948 | (define-key map "\t" 'completion-at-point) |
1949 | map) | |
1950 | "Keymap activated during `completion-in-region'.") | |
1951 | ||
1952 | ;; It is difficult to know when to exit completion-in-region-mode (i.e. hide | |
08c0f626 | 1953 | ;; the *Completions*). Here's how previous packages did it: |
3e2d70fd SM |
1954 | ;; - lisp-mode: never. |
1955 | ;; - comint: only do it if you hit SPC at the right time. | |
1956 | ;; - pcomplete: pop it down on SPC or after some time-delay. | |
1957 | ;; - semantic: use a post-command-hook check similar to this one. | |
1958 | (defun completion-in-region--postch () | |
3e2d70fd SM |
1959 | (or unread-command-events ;Don't pop down the completions in the middle of |
1960 | ;mouse-drag-region/mouse-set-point. | |
1961 | (and completion-in-region--data | |
d92df117 | 1962 | (and (eq (marker-buffer (nth 0 completion-in-region--data)) |
3e2d70fd | 1963 | (current-buffer)) |
d92df117 | 1964 | (>= (point) (nth 0 completion-in-region--data)) |
3e2d70fd SM |
1965 | (<= (point) |
1966 | (save-excursion | |
d92df117 | 1967 | (goto-char (nth 1 completion-in-region--data)) |
3e2d70fd | 1968 | (line-end-position))) |
2dbaa080 | 1969 | (funcall completion-in-region-mode--predicate))) |
3e2d70fd SM |
1970 | (completion-in-region-mode -1))) |
1971 | ||
1972 | ;; (defalias 'completion-in-region--prech 'completion-in-region--postch) | |
1973 | ||
504a0381 SM |
1974 | (defvar completion-in-region-mode nil) ;Explicit defvar, i.s.o defcustom. |
1975 | ||
3e2d70fd | 1976 | (define-minor-mode completion-in-region-mode |
504a0381 | 1977 | "Transient minor mode used during `completion-in-region'." |
3e2d70fd | 1978 | :global t |
ed8be7ff | 1979 | :group 'minibuffer |
504a0381 SM |
1980 | ;; Prevent definition of a custom-variable since it makes no sense to |
1981 | ;; customize this variable. | |
1982 | :variable completion-in-region-mode | |
3e2d70fd SM |
1983 | ;; (remove-hook 'pre-command-hook #'completion-in-region--prech) |
1984 | (remove-hook 'post-command-hook #'completion-in-region--postch) | |
1985 | (setq minor-mode-overriding-map-alist | |
1986 | (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist) | |
1987 | minor-mode-overriding-map-alist)) | |
1988 | (if (null completion-in-region-mode) | |
504a0381 SM |
1989 | (progn |
1990 | (setq completion-in-region--data nil) | |
1991 | (unless (equal "*Completions*" (buffer-name (window-buffer))) | |
1992 | (minibuffer-hide-completions))) | |
3e2d70fd | 1993 | ;; (add-hook 'pre-command-hook #'completion-in-region--prech) |
f58e0fd5 | 1994 | (cl-assert completion-in-region-mode-predicate) |
2dbaa080 SM |
1995 | (setq completion-in-region-mode--predicate |
1996 | completion-in-region-mode-predicate) | |
3e2d70fd SM |
1997 | (add-hook 'post-command-hook #'completion-in-region--postch) |
1998 | (push `(completion-in-region-mode . ,completion-in-region-mode-map) | |
1999 | minor-mode-overriding-map-alist))) | |
2000 | ||
2001 | ;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it | |
2002 | ;; on minor-mode-overriding-map-alist instead. | |
2003 | (setq minor-mode-map-alist | |
2004 | (delq (assq 'completion-in-region-mode minor-mode-map-alist) | |
2005 | minor-mode-map-alist)) | |
2006 | ||
3a07ffce | 2007 | (defvar completion-at-point-functions '(tags-completion-at-point-function) |
51ef56c4 | 2008 | "Special hook to find the completion table for the thing at point. |
d86d2721 SM |
2009 | Each function on this hook is called in turns without any argument and should |
2010 | return either nil to mean that it is not applicable at point, | |
51ef56c4 | 2011 | or a function of no argument to perform completion (discouraged), |
60236b0d | 2012 | or a list of the form (START END COLLECTION . PROPS) where |
51ef56c4 SM |
2013 | START and END delimit the entity to complete and should include point, |
2014 | COLLECTION is the completion table to use to complete it, and | |
2015 | PROPS is a property list for additional information. | |
a2a25d24 SM |
2016 | Currently supported properties are all the properties that can appear in |
2017 | `completion-extra-properties' plus: | |
0ff8e1ba | 2018 | `:predicate' a predicate that completion candidates need to satisfy. |
60236b0d CY |
2019 | `:exclusive' If `no', means that if the completion table fails to |
2020 | match the text at point, then instead of reporting a completion | |
3d10e134 SM |
2021 | failure, the completion should try the next completion function. |
2022 | As is the case with most hooks, the functions are responsible to preserve | |
2023 | things like point and current buffer.") | |
51ef56c4 | 2024 | |
3e2d70fd | 2025 | (defvar completion--capf-misbehave-funs nil |
0ff8e1ba SM |
2026 | "List of functions found on `completion-at-point-functions' that misbehave. |
2027 | These are functions that neither return completion data nor a completion | |
2028 | function but instead perform completion right away.") | |
3e2d70fd | 2029 | (defvar completion--capf-safe-funs nil |
0ff8e1ba SM |
2030 | "List of well-behaved functions found on `completion-at-point-functions'. |
2031 | These are functions which return proper completion data rather than | |
2032 | a completion function or god knows what else.") | |
3e2d70fd SM |
2033 | |
2034 | (defun completion--capf-wrapper (fun which) | |
d1bb6623 SM |
2035 | ;; FIXME: The safe/misbehave handling assumes that a given function will |
2036 | ;; always return the same kind of data, but this breaks down with functions | |
2037 | ;; like comint-completion-at-point or mh-letter-completion-at-point, which | |
2038 | ;; could be sometimes safe and sometimes misbehaving (and sometimes neither). | |
f58e0fd5 SM |
2039 | (if (pcase which |
2040 | (`all t) | |
2041 | (`safe (member fun completion--capf-safe-funs)) | |
2042 | (`optimist (not (member fun completion--capf-misbehave-funs)))) | |
3e2d70fd SM |
2043 | (let ((res (funcall fun))) |
2044 | (cond | |
0ff8e1ba | 2045 | ((and (consp res) (not (functionp res))) |
3e2d70fd | 2046 | (unless (member fun completion--capf-safe-funs) |
0ff8e1ba SM |
2047 | (push fun completion--capf-safe-funs)) |
2048 | (and (eq 'no (plist-get (nthcdr 3 res) :exclusive)) | |
2049 | ;; FIXME: Here we'd need to decide whether there are | |
2050 | ;; valid completions against the current text. But this depends | |
2051 | ;; on the actual completion UI (e.g. with the default completion | |
2052 | ;; it depends on completion-style) ;-( | |
2053 | ;; We approximate this result by checking whether prefix | |
2054 | ;; completion might work, which means that non-prefix completion | |
2055 | ;; will not work (or not right) for completion functions that | |
2056 | ;; are non-exclusive. | |
2057 | (null (try-completion (buffer-substring-no-properties | |
2058 | (car res) (point)) | |
2059 | (nth 2 res) | |
2060 | (plist-get (nthcdr 3 res) :predicate))) | |
2061 | (setq res nil))) | |
3e2d70fd SM |
2062 | ((not (or (listp res) (functionp res))) |
2063 | (unless (member fun completion--capf-misbehave-funs) | |
2064 | (message | |
2065 | "Completion function %S uses a deprecated calling convention" fun) | |
2066 | (push fun completion--capf-misbehave-funs)))) | |
e240cc21 | 2067 | (if res (cons fun res))))) |
3e2d70fd | 2068 | |
67027b49 | 2069 | (defun completion-at-point () |
48111a85 | 2070 | "Perform completion on the text around point. |
67027b49 SM |
2071 | The completion method is determined by `completion-at-point-functions'." |
2072 | (interactive) | |
3e2d70fd SM |
2073 | (let ((res (run-hook-wrapped 'completion-at-point-functions |
2074 | #'completion--capf-wrapper 'all))) | |
e240cc21 | 2075 | (pcase res |
d92df117 SM |
2076 | (`(,_ . ,(and (pred functionp) f)) (funcall f)) |
2077 | (`(,hookfun . (,start ,end ,collection . ,plist)) | |
2078 | (unless (markerp start) (setq start (copy-marker start))) | |
2079 | (let* ((completion-extra-properties plist) | |
2080 | (completion-in-region-mode-predicate | |
2081 | (lambda () | |
2082 | ;; We're still in the same completion field. | |
2083 | (let ((newstart (car-safe (funcall hookfun)))) | |
2084 | (and newstart (= newstart start)))))) | |
2085 | (completion-in-region start end collection | |
2086 | (plist-get plist :predicate)))) | |
2087 | ;; Maybe completion already happened and the function returned t. | |
2088 | (_ (cdr res))))) | |
51ef56c4 | 2089 | |
3e2d70fd SM |
2090 | (defun completion-help-at-point () |
2091 | "Display the completions on the text around point. | |
2092 | The completion method is determined by `completion-at-point-functions'." | |
2093 | (interactive) | |
2094 | (let ((res (run-hook-wrapped 'completion-at-point-functions | |
2095 | ;; Ignore misbehaving functions. | |
2096 | #'completion--capf-wrapper 'optimist))) | |
e240cc21 SM |
2097 | (pcase res |
2098 | (`(,_ . ,(and (pred functionp) f)) | |
2099 | (message "Don't know how to show completions for %S" f)) | |
d92df117 SM |
2100 | (`(,hookfun . (,start ,end ,collection . ,plist)) |
2101 | (unless (markerp start) (setq start (copy-marker start))) | |
2102 | (let* ((minibuffer-completion-table collection) | |
2103 | (minibuffer-completion-predicate (plist-get plist :predicate)) | |
2104 | (completion-extra-properties plist) | |
2105 | (completion-in-region-mode-predicate | |
2106 | (lambda () | |
2107 | ;; We're still in the same completion field. | |
2108 | (let ((newstart (car-safe (funcall hookfun)))) | |
67982e2b | 2109 | (and newstart (= newstart start)))))) |
d92df117 SM |
2110 | ;; FIXME: We should somehow (ab)use completion-in-region-function or |
2111 | ;; introduce a corresponding hook (plus another for word-completion, | |
2112 | ;; and another for force-completion, maybe?). | |
d92df117 | 2113 | (setq completion-in-region--data |
504a0381 SM |
2114 | `(,start ,(copy-marker end t) ,collection |
2115 | ,(plist-get plist :predicate))) | |
2116 | (completion-in-region-mode 1) | |
67982e2b | 2117 | (minibuffer-completion-help start end))) |
d92df117 SM |
2118 | (`(,hookfun . ,_) |
2119 | ;; The hook function already performed completion :-( | |
2120 | ;; Not much we can do at this point. | |
2121 | (message "%s already performed completion!" hookfun) | |
2122 | nil) | |
2123 | (_ (message "Nothing to complete at point"))))) | |
3e2d70fd | 2124 | |
1d4adede SM |
2125 | ;;; Key bindings. |
2126 | ||
a38313e1 SM |
2127 | (let ((map minibuffer-local-map)) |
2128 | (define-key map "\C-g" 'abort-recursive-edit) | |
2129 | (define-key map "\r" 'exit-minibuffer) | |
2130 | (define-key map "\n" 'exit-minibuffer)) | |
2131 | ||
3349e122 SM |
2132 | (defvar minibuffer-local-completion-map |
2133 | (let ((map (make-sparse-keymap))) | |
2134 | (set-keymap-parent map minibuffer-local-map) | |
2135 | (define-key map "\t" 'minibuffer-complete) | |
2136 | ;; M-TAB is already abused for many other purposes, so we should find | |
2137 | ;; another binding for it. | |
2138 | ;; (define-key map "\e\t" 'minibuffer-force-complete) | |
2139 | (define-key map " " 'minibuffer-complete-word) | |
2140 | (define-key map "?" 'minibuffer-completion-help) | |
2141 | map) | |
2142 | "Local keymap for minibuffer input with completion.") | |
2143 | ||
2144 | (defvar minibuffer-local-must-match-map | |
2145 | (let ((map (make-sparse-keymap))) | |
2146 | (set-keymap-parent map minibuffer-local-completion-map) | |
2147 | (define-key map "\r" 'minibuffer-complete-and-exit) | |
2148 | (define-key map "\n" 'minibuffer-complete-and-exit) | |
2149 | map) | |
2150 | "Local keymap for minibuffer input with completion, for exact match.") | |
a38313e1 | 2151 | |
3349e122 SM |
2152 | (defvar minibuffer-local-filename-completion-map |
2153 | (let ((map (make-sparse-keymap))) | |
2154 | (define-key map " " nil) | |
2155 | map) | |
2156 | "Local keymap for minibuffer input with completion for filenames. | |
2157 | Gets combined either with `minibuffer-local-completion-map' or | |
2158 | with `minibuffer-local-must-match-map'.") | |
a38313e1 | 2159 | |
3349e122 SM |
2160 | (define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map |
2161 | 'minibuffer-local-filename-must-match-map "23.1") | |
1a72a195 SM |
2162 | (defvar minibuffer-local-filename-must-match-map (make-sparse-keymap)) |
2163 | (make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1") | |
a38313e1 SM |
2164 | |
2165 | (let ((map minibuffer-local-ns-map)) | |
2166 | (define-key map " " 'exit-minibuffer) | |
2167 | (define-key map "\t" 'exit-minibuffer) | |
2168 | (define-key map "?" 'self-insert-and-exit)) | |
2169 | ||
fd6fa53f SM |
2170 | (defvar minibuffer-inactive-mode-map |
2171 | (let ((map (make-keymap))) | |
2172 | (suppress-keymap map) | |
2173 | (define-key map "e" 'find-file-other-frame) | |
2174 | (define-key map "f" 'find-file-other-frame) | |
2175 | (define-key map "b" 'switch-to-buffer-other-frame) | |
2176 | (define-key map "i" 'info) | |
2177 | (define-key map "m" 'mail) | |
2178 | (define-key map "n" 'make-frame) | |
123ecb68 | 2179 | (define-key map [mouse-1] 'view-echo-area-messages) |
fd6fa53f SM |
2180 | ;; So the global down-mouse-1 binding doesn't clutter the execution of the |
2181 | ;; above mouse-1 binding. | |
2182 | (define-key map [down-mouse-1] #'ignore) | |
2183 | map) | |
2184 | "Keymap for use in the minibuffer when it is not active. | |
2185 | The non-mouse bindings in this keymap can only be used in minibuffer-only | |
2186 | frames, since the minibuffer can normally not be selected when it is | |
2187 | not active.") | |
2188 | ||
2189 | (define-derived-mode minibuffer-inactive-mode nil "InactiveMinibuffer" | |
2190 | :abbrev-table nil ;abbrev.el is not loaded yet during dump. | |
2191 | ;; Note: this major mode is called from minibuf.c. | |
2192 | "Major mode to use in the minibuffer when it is not active. | |
2193 | This is only used when the minibuffer area has no active minibuffer.") | |
2194 | ||
a38313e1 SM |
2195 | ;;; Completion tables. |
2196 | ||
34b67b0f | 2197 | (defun minibuffer--double-dollars (str) |
79c4eeb4 SM |
2198 | ;; Reuse the actual "$" from the string to preserve any text-property it |
2199 | ;; might have, such as `face'. | |
2200 | (replace-regexp-in-string "\\$" (lambda (dollar) (concat dollar dollar)) | |
2201 | str)) | |
34b67b0f | 2202 | |
21622c6d SM |
2203 | (defun completion--make-envvar-table () |
2204 | (mapcar (lambda (enventry) | |
9f3618b5 | 2205 | (substring enventry 0 (string-match-p "=" enventry))) |
21622c6d SM |
2206 | process-environment)) |
2207 | ||
a38313e1 | 2208 | (defconst completion--embedded-envvar-re |
3b11e6ac SM |
2209 | ;; We can't reuse env--substitute-vars-regexp because we need to match only |
2210 | ;; potentially-unfinished envvars at end of string. | |
a38313e1 SM |
2211 | (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" |
2212 | "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) | |
2213 | ||
d032d5e7 | 2214 | (defun completion--embedded-envvar-table (string _pred action) |
c6432f1e SM |
2215 | "Completion table for envvars embedded in a string. |
2216 | The envvar syntax (and escaping) rules followed by this table are the | |
2217 | same as `substitute-in-file-name'." | |
2218 | ;; We ignore `pred', because the predicates passed to us via | |
2219 | ;; read-file-name-internal are not 100% correct and fail here: | |
2220 | ;; e.g. we get predicates like file-directory-p there, whereas the filename | |
2221 | ;; completed needs to be passed through substitute-in-file-name before it | |
2222 | ;; can be passed to file-directory-p. | |
528c56e2 SM |
2223 | (when (string-match completion--embedded-envvar-re string) |
2224 | (let* ((beg (or (match-beginning 2) (match-beginning 1))) | |
2225 | (table (completion--make-envvar-table)) | |
2226 | (prefix (substring string 0 beg))) | |
c6432f1e SM |
2227 | (cond |
2228 | ((eq action 'lambda) | |
2229 | ;; This table is expected to be used in conjunction with some | |
2230 | ;; other table that provides the "main" completion. Let the | |
2231 | ;; other table handle the test-completion case. | |
2232 | nil) | |
30a23501 SM |
2233 | ((or (eq (car-safe action) 'boundaries) (eq action 'metadata)) |
2234 | ;; Only return boundaries/metadata if there's something to complete, | |
03408648 SM |
2235 | ;; since otherwise when we're used in |
2236 | ;; completion-table-in-turn, we could return boundaries and | |
2237 | ;; let some subsequent table return a list of completions. | |
2238 | ;; FIXME: Maybe it should rather be fixed in | |
2239 | ;; completion-table-in-turn instead, but it's difficult to | |
2240 | ;; do it efficiently there. | |
c6432f1e | 2241 | (when (try-completion (substring string beg) table nil) |
03408648 SM |
2242 | ;; Compute the boundaries of the subfield to which this |
2243 | ;; completion applies. | |
30a23501 SM |
2244 | (if (eq action 'metadata) |
2245 | '(metadata (category . environment-variable)) | |
2246 | (let ((suffix (cdr action))) | |
f58e0fd5 SM |
2247 | `(boundaries |
2248 | ,(or (match-beginning 2) (match-beginning 1)) | |
2249 | . ,(when (string-match "[^[:alnum:]_]" suffix) | |
2250 | (match-beginning 0))))))) | |
c6432f1e | 2251 | (t |
a38313e1 SM |
2252 | (if (eq (aref string (1- beg)) ?{) |
2253 | (setq table (apply-partially 'completion-table-with-terminator | |
2254 | "}" table))) | |
ab22be48 SM |
2255 | ;; Even if file-name completion is case-insensitive, we want |
2256 | ;; envvar completion to be case-sensitive. | |
2257 | (let ((completion-ignore-case nil)) | |
2258 | (completion-table-with-context | |
c6432f1e | 2259 | prefix table (substring string beg) nil action))))))) |
017c22fe | 2260 | |
528c56e2 SM |
2261 | (defun completion-file-name-table (string pred action) |
2262 | "Completion table for file names." | |
af7b6078 SM |
2263 | (condition-case nil |
2264 | (cond | |
2265 | ((eq action 'metadata) '(metadata (category . file))) | |
ed571ccb SM |
2266 | ((string-match-p "\\`~[^/\\]*\\'" string) |
2267 | (completion-table-with-context "~" | |
2268 | (mapcar (lambda (u) (concat u "/")) | |
2269 | (system-users)) | |
2270 | (substring string 1) | |
2271 | pred action)) | |
af7b6078 SM |
2272 | ((eq (car-safe action) 'boundaries) |
2273 | (let ((start (length (file-name-directory string))) | |
2274 | (end (string-match-p "/" (cdr action)))) | |
f58e0fd5 SM |
2275 | `(boundaries |
2276 | ;; if `string' is "C:" in w32, (file-name-directory string) | |
2277 | ;; returns "C:/", so `start' is 3 rather than 2. | |
2278 | ;; Not quite sure what is The Right Fix, but clipping it | |
2279 | ;; back to 2 will work for this particular case. We'll | |
2280 | ;; see if we can come up with a better fix when we bump | |
2281 | ;; into more such problematic cases. | |
2282 | ,(min start (length string)) . ,end))) | |
528c56e2 | 2283 | |
af7b6078 SM |
2284 | ((eq action 'lambda) |
2285 | (if (zerop (length string)) | |
2286 | nil ;Not sure why it's here, but it probably doesn't harm. | |
2287 | (funcall (or pred 'file-exists-p) string))) | |
017c22fe | 2288 | |
af7b6078 SM |
2289 | (t |
2290 | (let* ((name (file-name-nondirectory string)) | |
2291 | (specdir (file-name-directory string)) | |
2292 | (realdir (or specdir default-directory))) | |
2293 | ||
2294 | (cond | |
2295 | ((null action) | |
2296 | (let ((comp (file-name-completion name realdir pred))) | |
2297 | (if (stringp comp) | |
2298 | (concat specdir comp) | |
2299 | comp))) | |
2300 | ||
2301 | ((eq action t) | |
2302 | (let ((all (file-name-all-completions name realdir))) | |
2303 | ||
2304 | ;; Check the predicate, if necessary. | |
2305 | (unless (memq pred '(nil file-exists-p)) | |
2306 | (let ((comp ()) | |
2307 | (pred | |
2308 | (if (eq pred 'file-directory-p) | |
2309 | ;; Brute-force speed up for directory checking: | |
2310 | ;; Discard strings which don't end in a slash. | |
2311 | (lambda (s) | |
2312 | (let ((len (length s))) | |
2313 | (and (> len 0) (eq (aref s (1- len)) ?/)))) | |
2314 | ;; Must do it the hard (and slow) way. | |
2315 | pred))) | |
2316 | (let ((default-directory (expand-file-name realdir))) | |
2317 | (dolist (tem all) | |
2318 | (if (funcall pred tem) (push tem comp)))) | |
2319 | (setq all (nreverse comp)))) | |
2320 | ||
2321 | all)))))) | |
2322 | (file-error nil))) ;PCM often calls with invalid directories. | |
528c56e2 SM |
2323 | |
2324 | (defvar read-file-name-predicate nil | |
2325 | "Current predicate used by `read-file-name-internal'.") | |
2326 | (make-obsolete-variable 'read-file-name-predicate | |
2327 | "use the regular PRED argument" "23.2") | |
2328 | ||
79c4eeb4 | 2329 | (defun completion--sifn-requote (upos qstr) |
86957a0c | 2330 | ;; We're looking for `qpos' such that: |
036dfb8b | 2331 | ;; (equal (substring (substitute-in-file-name qstr) 0 upos) |
86957a0c | 2332 | ;; (substitute-in-file-name (substring qstr 0 qpos))) |
036dfb8b SM |
2333 | ;; Big problem here: we have to reverse engineer substitute-in-file-name to |
2334 | ;; find the position corresponding to UPOS in QSTR, but | |
2335 | ;; substitute-in-file-name can do anything, depending on file-name-handlers. | |
86957a0c SM |
2336 | ;; substitute-in-file-name does the following kind of things: |
2337 | ;; - expand env-var references. | |
2338 | ;; - turn backslashes into slashes. | |
2339 | ;; - truncate some prefix of the input. | |
2340 | ;; - rewrite some prefix. | |
2341 | ;; Some of these operations are written in external libraries and we'd rather | |
2342 | ;; not hard code any assumptions here about what they actually do. IOW, we | |
2343 | ;; want to treat substitute-in-file-name as a black box, as much as possible. | |
036dfb8b | 2344 | ;; Kind of like in rfn-eshadow-update-overlay, only worse. |
86957a0c SM |
2345 | ;; Example of things we need to handle: |
2346 | ;; - Tramp (substitute-in-file-name "/foo:~/bar//baz") => "/scpc:foo:/baz". | |
2347 | ;; - Cygwin (substitute-in-file-name "C:\bin") => "/usr/bin" | |
2348 | ;; (substitute-in-file-name "C:\") => "/" | |
2349 | ;; (substitute-in-file-name "C:\bi") => "/bi" | |
2350 | (let* ((ustr (substitute-in-file-name qstr)) | |
2351 | (uprefix (substring ustr 0 upos)) | |
2352 | qprefix) | |
2353 | ;; Main assumption: nothing after qpos should affect the text before upos, | |
2354 | ;; so we can work our way backward from the end of qstr, one character | |
2355 | ;; at a time. | |
2356 | ;; Second assumptions: If qpos is far from the end this can be a bit slow, | |
2357 | ;; so we speed it up by doing a first loop that skips a word at a time. | |
2358 | ;; This word-sized loop is careful not to cut in the middle of env-vars. | |
2359 | (while (let ((boundary (string-match "\\(\\$+{?\\)?\\w+\\W*\\'" qstr))) | |
2360 | (and boundary | |
1a72a195 | 2361 | (progn |
86957a0c SM |
2362 | (setq qprefix (substring qstr 0 boundary)) |
2363 | (string-prefix-p uprefix | |
2364 | (substitute-in-file-name qprefix))))) | |
2365 | (setq qstr qprefix)) | |
2366 | (let ((qpos (length qstr))) | |
2367 | (while (and (> qpos 0) | |
2368 | (string-prefix-p uprefix | |
2369 | (substitute-in-file-name | |
2370 | (substring qstr 0 (1- qpos))))) | |
2371 | (setq qpos (1- qpos))) | |
2372 | (cons qpos #'minibuffer--double-dollars)))) | |
79c4eeb4 SM |
2373 | |
2374 | (defalias 'completion--file-name-table | |
2375 | (completion-table-with-quoting #'completion-file-name-table | |
2376 | #'substitute-in-file-name | |
2377 | #'completion--sifn-requote) | |
528c56e2 SM |
2378 | "Internal subroutine for `read-file-name'. Do not call this. |
2379 | This is a completion table for file names, like `completion-file-name-table' | |
79c4eeb4 | 2380 | except that it passes the file name through `substitute-in-file-name'.") |
34b67b0f | 2381 | |
21622c6d | 2382 | (defalias 'read-file-name-internal |
79c4eeb4 SM |
2383 | (completion-table-in-turn #'completion--embedded-envvar-table |
2384 | #'completion--file-name-table) | |
21622c6d | 2385 | "Internal subroutine for `read-file-name'. Do not call this.") |
34b67b0f | 2386 | |
b16ac1ec LL |
2387 | (defvar read-file-name-function 'read-file-name-default |
2388 | "The function called by `read-file-name' to do its work. | |
2389 | It should accept the same arguments as `read-file-name'.") | |
dbd50d4b | 2390 | |
dbd50d4b SM |
2391 | (defcustom insert-default-directory t |
2392 | "Non-nil means when reading a filename start with default dir in minibuffer. | |
2393 | ||
2394 | When the initial minibuffer contents show a name of a file or a directory, | |
2395 | typing RETURN without editing the initial contents is equivalent to typing | |
2396 | the default file name. | |
2397 | ||
2398 | If this variable is non-nil, the minibuffer contents are always | |
2399 | initially non-empty, and typing RETURN without editing will fetch the | |
2400 | default name, if one is provided. Note however that this default name | |
2401 | is not necessarily the same as initial contents inserted in the minibuffer, | |
2402 | if the initial contents is just the default directory. | |
2403 | ||
2404 | If this variable is nil, the minibuffer often starts out empty. In | |
2405 | that case you may have to explicitly fetch the next history element to | |
2406 | request the default name; typing RETURN without editing will leave | |
2407 | the minibuffer empty. | |
2408 | ||
2409 | For some commands, exiting with an empty minibuffer has a special meaning, | |
2410 | such as making the current buffer visit no file in the case of | |
2411 | `set-visited-file-name'." | |
dbd50d4b SM |
2412 | :type 'boolean) |
2413 | ||
4e3870f5 GM |
2414 | ;; Not always defined, but only called if next-read-file-uses-dialog-p says so. |
2415 | (declare-function x-file-dialog "xfns.c" | |
2416 | (prompt dir &optional default-filename mustmatch only-dir-p)) | |
2417 | ||
b16ac1ec | 2418 | (defun read-file-name--defaults (&optional dir initial) |
7d371eac JL |
2419 | (let ((default |
2420 | (cond | |
2421 | ;; With non-nil `initial', use `dir' as the first default. | |
2422 | ;; Essentially, this mean reversing the normal order of the | |
2423 | ;; current directory name and the current file name, i.e. | |
2424 | ;; 1. with normal file reading: | |
2425 | ;; 1.1. initial input is the current directory | |
2426 | ;; 1.2. the first default is the current file name | |
2427 | ;; 2. with non-nil `initial' (e.g. for `find-alternate-file'): | |
2428 | ;; 2.2. initial input is the current file name | |
2429 | ;; 2.1. the first default is the current directory | |
2430 | (initial (abbreviate-file-name dir)) | |
2431 | ;; In file buffers, try to get the current file name | |
2432 | (buffer-file-name | |
2433 | (abbreviate-file-name buffer-file-name)))) | |
2434 | (file-name-at-point | |
2435 | (run-hook-with-args-until-success 'file-name-at-point-functions))) | |
2436 | (when file-name-at-point | |
2437 | (setq default (delete-dups | |
2438 | (delete "" (delq nil (list file-name-at-point default)))))) | |
2439 | ;; Append new defaults to the end of existing `minibuffer-default'. | |
2440 | (append | |
2441 | (if (listp minibuffer-default) minibuffer-default (list minibuffer-default)) | |
2442 | (if (listp default) default (list default))))) | |
2443 | ||
dbd50d4b SM |
2444 | (defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate) |
2445 | "Read file name, prompting with PROMPT and completing in directory DIR. | |
dd7aafbb | 2446 | The return value is not expanded---you must call `expand-file-name' yourself. |
4abcdac8 CY |
2447 | |
2448 | DIR is the directory to use for completing relative file names. | |
2449 | It should be an absolute directory name, or nil (which means the | |
2450 | current buffer's value of `default-directory'). | |
2451 | ||
2452 | DEFAULT-FILENAME specifies the default file name to return if the | |
2453 | user exits the minibuffer with the same non-empty string inserted | |
2454 | by this function. If DEFAULT-FILENAME is a string, that serves | |
2455 | as the default. If DEFAULT-FILENAME is a list of strings, the | |
2456 | first string is the default. If DEFAULT-FILENAME is omitted or | |
2457 | nil, then if INITIAL is non-nil, the default is DIR combined with | |
2458 | INITIAL; otherwise, if the current buffer is visiting a file, | |
2459 | that file serves as the default; otherwise, the default is simply | |
2460 | the string inserted into the minibuffer. | |
2461 | ||
2462 | If the user exits with an empty minibuffer, return an empty | |
2463 | string. (This happens only if the user erases the pre-inserted | |
2464 | contents, or if `insert-default-directory' is nil.) | |
846b6eba CY |
2465 | |
2466 | Fourth arg MUSTMATCH can take the following values: | |
2467 | - nil means that the user can exit with any input. | |
2468 | - t means that the user is not allowed to exit unless | |
2469 | the input is (or completes to) an existing file. | |
2470 | - `confirm' means that the user can exit with any input, but she needs | |
2471 | to confirm her choice if the input is not an existing file. | |
2472 | - `confirm-after-completion' means that the user can exit with any | |
2473 | input, but she needs to confirm her choice if she called | |
2474 | `minibuffer-complete' right before `minibuffer-complete-and-exit' | |
2475 | and the input is not an existing file. | |
2476 | - anything else behaves like t except that typing RET does not exit if it | |
2477 | does non-null completion. | |
2478 | ||
dbd50d4b | 2479 | Fifth arg INITIAL specifies text to start with. |
846b6eba | 2480 | |
4abcdac8 CY |
2481 | Sixth arg PREDICATE, if non-nil, should be a function of one |
2482 | argument; then a file name is considered an acceptable completion | |
2483 | alternative only if PREDICATE returns non-nil with the file name | |
2484 | as its argument. | |
dbd50d4b | 2485 | |
846b6eba CY |
2486 | If this command was invoked with the mouse, use a graphical file |
2487 | dialog if `use-dialog-box' is non-nil, and the window system or X | |
8368c14e | 2488 | toolkit in use provides a file dialog box, and DIR is not a |
2605051a GM |
2489 | remote file. For graphical file dialogs, any of the special values |
2490 | of MUSTMATCH `confirm' and `confirm-after-completion' are | |
2491 | treated as equivalent to nil. Some graphical file dialogs respect | |
2492 | a MUSTMATCH value of t, and some do not (or it only has a cosmetic | |
fba9b8b6 | 2493 | effect, and does not actually prevent the user from entering a |
2605051a | 2494 | non-existent file). |
dbd50d4b SM |
2495 | |
2496 | See also `read-file-name-completion-ignore-case' | |
2497 | and `read-file-name-function'." | |
2605051a GM |
2498 | ;; If x-gtk-use-old-file-dialog = t (xg_get_file_with_selection), |
2499 | ;; then MUSTMATCH is enforced. But with newer Gtk | |
2500 | ;; (xg_get_file_with_chooser), it only has a cosmetic effect. | |
2501 | ;; The user can still type a non-existent file name. | |
b16ac1ec LL |
2502 | (funcall (or read-file-name-function #'read-file-name-default) |
2503 | prompt dir default-filename mustmatch initial predicate)) | |
2504 | ||
09b95ce3 MY |
2505 | (defvar minibuffer-local-filename-syntax |
2506 | (let ((table (make-syntax-table)) | |
2507 | (punctuation (car (string-to-syntax ".")))) | |
2508 | ;; Convert all punctuation entries to symbol. | |
2509 | (map-char-table (lambda (c syntax) | |
2510 | (when (eq (car syntax) punctuation) | |
2511 | (modify-syntax-entry c "_" table))) | |
2512 | table) | |
2513 | (mapc | |
2514 | (lambda (c) | |
2515 | (modify-syntax-entry c "." table)) | |
2516 | '(?/ ?: ?\\)) | |
2517 | table) | |
48de8b12 | 2518 | "Syntax table used when reading a file name in the minibuffer.") |
09b95ce3 | 2519 | |
620c53a6 SM |
2520 | ;; minibuffer-completing-file-name is a variable used internally in minibuf.c |
2521 | ;; to determine whether to use minibuffer-local-filename-completion-map or | |
2522 | ;; minibuffer-local-completion-map. It shouldn't be exported to Elisp. | |
2403c841 SM |
2523 | ;; FIXME: Actually, it is also used in rfn-eshadow.el we'd otherwise have to |
2524 | ;; use (eq minibuffer-completion-table #'read-file-name-internal), which is | |
2525 | ;; probably even worse. Maybe We should add some read-file-name-setup-hook | |
2526 | ;; instead, but for now, let's keep this non-obsolete. | |
cc356a5d | 2527 | ;;(make-obsolete-variable 'minibuffer-completing-file-name nil "future" 'get) |
620c53a6 | 2528 | |
b16ac1ec LL |
2529 | (defun read-file-name-default (prompt &optional dir default-filename mustmatch initial predicate) |
2530 | "Default method for reading file names. | |
2531 | See `read-file-name' for the meaning of the arguments." | |
dbd50d4b SM |
2532 | (unless dir (setq dir default-directory)) |
2533 | (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir))) | |
2534 | (unless default-filename | |
2535 | (setq default-filename (if initial (expand-file-name initial dir) | |
2536 | buffer-file-name))) | |
2537 | ;; If dir starts with user's homedir, change that to ~. | |
2538 | (setq dir (abbreviate-file-name dir)) | |
2539 | ;; Likewise for default-filename. | |
e8a5fe3e | 2540 | (if default-filename |
032c3399 JL |
2541 | (setq default-filename |
2542 | (if (consp default-filename) | |
2543 | (mapcar 'abbreviate-file-name default-filename) | |
2544 | (abbreviate-file-name default-filename)))) | |
6b11952a | 2545 | (let ((insdef (cond |
dbd50d4b SM |
2546 | ((and insert-default-directory (stringp dir)) |
2547 | (if initial | |
2548 | (cons (minibuffer--double-dollars (concat dir initial)) | |
2549 | (length (minibuffer--double-dollars dir))) | |
2550 | (minibuffer--double-dollars dir))) | |
2551 | (initial (cons (minibuffer--double-dollars initial) 0))))) | |
2552 | ||
03408648 SM |
2553 | (let ((completion-ignore-case read-file-name-completion-ignore-case) |
2554 | (minibuffer-completing-file-name t) | |
2555 | (pred (or predicate 'file-exists-p)) | |
2556 | (add-to-history nil)) | |
2557 | ||
2558 | (let* ((val | |
2559 | (if (or (not (next-read-file-uses-dialog-p)) | |
2560 | ;; Graphical file dialogs can't handle remote | |
2561 | ;; files (Bug#99). | |
2562 | (file-remote-p dir)) | |
2563 | ;; We used to pass `dir' to `read-file-name-internal' by | |
2564 | ;; abusing the `predicate' argument. It's better to | |
2565 | ;; just use `default-directory', but in order to avoid | |
2566 | ;; changing `default-directory' in the current buffer, | |
2567 | ;; we don't let-bind it. | |
2568 | (let ((dir (file-name-as-directory | |
2569 | (expand-file-name dir)))) | |
2570 | (minibuffer-with-setup-hook | |
2571 | (lambda () | |
2572 | (setq default-directory dir) | |
2573 | ;; When the first default in `minibuffer-default' | |
2574 | ;; duplicates initial input `insdef', | |
2575 | ;; reset `minibuffer-default' to nil. | |
2576 | (when (equal (or (car-safe insdef) insdef) | |
2577 | (or (car-safe minibuffer-default) | |
2578 | minibuffer-default)) | |
2579 | (setq minibuffer-default | |
2580 | (cdr-safe minibuffer-default))) | |
2581 | ;; On the first request on `M-n' fill | |
2582 | ;; `minibuffer-default' with a list of defaults | |
2583 | ;; relevant for file-name reading. | |
2584 | (set (make-local-variable 'minibuffer-default-add-function) | |
2585 | (lambda () | |
2586 | (with-current-buffer | |
2587 | (window-buffer (minibuffer-selected-window)) | |
09b95ce3 MY |
2588 | (read-file-name--defaults dir initial)))) |
2589 | (set-syntax-table minibuffer-local-filename-syntax)) | |
03408648 SM |
2590 | (completing-read prompt 'read-file-name-internal |
2591 | pred mustmatch insdef | |
2592 | 'file-name-history default-filename))) | |
2593 | ;; If DEFAULT-FILENAME not supplied and DIR contains | |
2594 | ;; a file name, split it. | |
2595 | (let ((file (file-name-nondirectory dir)) | |
2596 | ;; When using a dialog, revert to nil and non-nil | |
2597 | ;; interpretation of mustmatch. confirm options | |
2598 | ;; need to be interpreted as nil, otherwise | |
2599 | ;; it is impossible to create new files using | |
2600 | ;; dialogs with the default settings. | |
2601 | (dialog-mustmatch | |
2602 | (not (memq mustmatch | |
2603 | '(nil confirm confirm-after-completion))))) | |
2604 | (when (and (not default-filename) | |
2605 | (not (zerop (length file)))) | |
2606 | (setq default-filename file) | |
2607 | (setq dir (file-name-directory dir))) | |
2608 | (when default-filename | |
2609 | (setq default-filename | |
2610 | (expand-file-name (if (consp default-filename) | |
2611 | (car default-filename) | |
2612 | default-filename) | |
2613 | dir))) | |
2614 | (setq add-to-history t) | |
2615 | (x-file-dialog prompt dir default-filename | |
2616 | dialog-mustmatch | |
2617 | (eq predicate 'file-directory-p))))) | |
2618 | ||
2619 | (replace-in-history (eq (car-safe file-name-history) val))) | |
2620 | ;; If completing-read returned the inserted default string itself | |
2621 | ;; (rather than a new string with the same contents), | |
2622 | ;; it has to mean that the user typed RET with the minibuffer empty. | |
2623 | ;; In that case, we really want to return "" | |
2624 | ;; so that commands such as set-visited-file-name can distinguish. | |
2625 | (when (consp default-filename) | |
2626 | (setq default-filename (car default-filename))) | |
2627 | (when (eq val default-filename) | |
2628 | ;; In this case, completing-read has not added an element | |
2629 | ;; to the history. Maybe we should. | |
2630 | (if (not replace-in-history) | |
2631 | (setq add-to-history t)) | |
2632 | (setq val "")) | |
2633 | (unless val (error "No file name specified")) | |
2634 | ||
2635 | (if (and default-filename | |
2636 | (string-equal val (if (consp insdef) (car insdef) insdef))) | |
2637 | (setq val default-filename)) | |
2638 | (setq val (substitute-in-file-name val)) | |
2639 | ||
2640 | (if replace-in-history | |
2641 | ;; Replace what Fcompleting_read added to the history | |
2642 | ;; with what we will actually return. As an exception, | |
2643 | ;; if that's the same as the second item in | |
2644 | ;; file-name-history, it's really a repeat (Bug#4657). | |
2645 | (let ((val1 (minibuffer--double-dollars val))) | |
2646 | (if history-delete-duplicates | |
2647 | (setcdr file-name-history | |
2648 | (delete val1 (cdr file-name-history)))) | |
2649 | (if (string= val1 (cadr file-name-history)) | |
2650 | (pop file-name-history) | |
2651 | (setcar file-name-history val1))) | |
2652 | (if add-to-history | |
2653 | ;; Add the value to the history--but not if it matches | |
2654 | ;; the last value already there. | |
dbd50d4b | 2655 | (let ((val1 (minibuffer--double-dollars val))) |
03408648 SM |
2656 | (unless (and (consp file-name-history) |
2657 | (equal (car file-name-history) val1)) | |
2658 | (setq file-name-history | |
2659 | (cons val1 | |
2660 | (if history-delete-duplicates | |
2661 | (delete val1 file-name-history) | |
2662 | file-name-history))))))) | |
b16ac1ec | 2663 | val)))) |
dbd50d4b | 2664 | |
8b04c0ae JL |
2665 | (defun internal-complete-buffer-except (&optional buffer) |
2666 | "Perform completion on all buffers excluding BUFFER. | |
e35b3063 | 2667 | BUFFER nil or omitted means use the current buffer. |
8b04c0ae | 2668 | Like `internal-complete-buffer', but removes BUFFER from the completion list." |
a647cb26 | 2669 | (let ((except (if (stringp buffer) buffer (buffer-name buffer)))) |
8b04c0ae JL |
2670 | (apply-partially 'completion-table-with-predicate |
2671 | 'internal-complete-buffer | |
2672 | (lambda (name) | |
2673 | (not (equal (if (consp name) (car name) name) except))) | |
2674 | nil))) | |
2675 | ||
eee6de73 | 2676 | ;;; Old-style completion, used in Emacs-21 and Emacs-22. |
19c04f39 | 2677 | |
d032d5e7 | 2678 | (defun completion-emacs21-try-completion (string table pred _point) |
19c04f39 SM |
2679 | (let ((completion (try-completion string table pred))) |
2680 | (if (stringp completion) | |
2681 | (cons completion (length completion)) | |
2682 | completion))) | |
2683 | ||
d032d5e7 | 2684 | (defun completion-emacs21-all-completions (string table pred _point) |
6138158d | 2685 | (completion-hilit-commonality |
eee6de73 | 2686 | (all-completions string table pred) |
125f7951 SM |
2687 | (length string) |
2688 | (car (completion-boundaries string table pred "")))) | |
19c04f39 | 2689 | |
19c04f39 SM |
2690 | (defun completion-emacs22-try-completion (string table pred point) |
2691 | (let ((suffix (substring string point)) | |
2692 | (completion (try-completion (substring string 0 point) table pred))) | |
2693 | (if (not (stringp completion)) | |
2694 | completion | |
2695 | ;; Merge a trailing / in completion with a / after point. | |
2696 | ;; We used to only do it for word completion, but it seems to make | |
2697 | ;; sense for all completions. | |
34200787 SM |
2698 | ;; Actually, claiming this feature was part of Emacs-22 completion |
2699 | ;; is pushing it a bit: it was only done in minibuffer-completion-word, | |
2700 | ;; which was (by default) not bound during file completion, where such | |
2701 | ;; slashes are most likely to occur. | |
2702 | (if (and (not (zerop (length completion))) | |
2703 | (eq ?/ (aref completion (1- (length completion)))) | |
19c04f39 SM |
2704 | (not (zerop (length suffix))) |
2705 | (eq ?/ (aref suffix 0))) | |
34200787 SM |
2706 | ;; This leaves point after the / . |
2707 | (setq suffix (substring suffix 1))) | |
19c04f39 SM |
2708 | (cons (concat completion suffix) (length completion))))) |
2709 | ||
2710 | (defun completion-emacs22-all-completions (string table pred point) | |
125f7951 SM |
2711 | (let ((beforepoint (substring string 0 point))) |
2712 | (completion-hilit-commonality | |
2713 | (all-completions beforepoint table pred) | |
2714 | point | |
2715 | (car (completion-boundaries beforepoint table pred ""))))) | |
19c04f39 | 2716 | |
eee6de73 SM |
2717 | ;;; Basic completion. |
2718 | ||
2719 | (defun completion--merge-suffix (completion point suffix) | |
2720 | "Merge end of COMPLETION with beginning of SUFFIX. | |
2721 | Simple generalization of the \"merge trailing /\" done in Emacs-22. | |
2722 | Return the new suffix." | |
2723 | (if (and (not (zerop (length suffix))) | |
2724 | (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix) | |
2725 | ;; Make sure we don't compress things to less | |
2726 | ;; than we started with. | |
2727 | point) | |
2728 | ;; Just make sure we didn't match some other \n. | |
2729 | (eq (match-end 1) (length completion))) | |
2730 | (substring suffix (- (match-end 1) (match-beginning 1))) | |
2731 | ;; Nothing to merge. | |
2732 | suffix)) | |
2733 | ||
00278747 SM |
2734 | (defun completion-basic--pattern (beforepoint afterpoint bounds) |
2735 | (delete | |
2736 | "" (list (substring beforepoint (car bounds)) | |
2737 | 'point | |
2738 | (substring afterpoint 0 (cdr bounds))))) | |
2739 | ||
34200787 | 2740 | (defun completion-basic-try-completion (string table pred point) |
a647cb26 SM |
2741 | (let* ((beforepoint (substring string 0 point)) |
2742 | (afterpoint (substring string point)) | |
2743 | (bounds (completion-boundaries beforepoint table pred afterpoint))) | |
86011bf2 SM |
2744 | (if (zerop (cdr bounds)) |
2745 | ;; `try-completion' may return a subtly different result | |
2746 | ;; than `all+merge', so try to use it whenever possible. | |
2747 | (let ((completion (try-completion beforepoint table pred))) | |
2748 | (if (not (stringp completion)) | |
2749 | completion | |
2750 | (cons | |
2751 | (concat completion | |
2752 | (completion--merge-suffix completion point afterpoint)) | |
2753 | (length completion)))) | |
a647cb26 SM |
2754 | (let* ((suffix (substring afterpoint (cdr bounds))) |
2755 | (prefix (substring beforepoint 0 (car bounds))) | |
2756 | (pattern (delete | |
2757 | "" (list (substring beforepoint (car bounds)) | |
2758 | 'point | |
2759 | (substring afterpoint 0 (cdr bounds))))) | |
2760 | (all (completion-pcm--all-completions prefix pattern table pred))) | |
86011bf2 SM |
2761 | (if minibuffer-completing-file-name |
2762 | (setq all (completion-pcm--filename-try-filter all))) | |
2763 | (completion-pcm--merge-try pattern all prefix suffix))))) | |
2764 | ||
2765 | (defun completion-basic-all-completions (string table pred point) | |
a647cb26 SM |
2766 | (let* ((beforepoint (substring string 0 point)) |
2767 | (afterpoint (substring string point)) | |
2768 | (bounds (completion-boundaries beforepoint table pred afterpoint)) | |
d032d5e7 | 2769 | ;; (suffix (substring afterpoint (cdr bounds))) |
a647cb26 SM |
2770 | (prefix (substring beforepoint 0 (car bounds))) |
2771 | (pattern (delete | |
2772 | "" (list (substring beforepoint (car bounds)) | |
2773 | 'point | |
2774 | (substring afterpoint 0 (cdr bounds))))) | |
2775 | (all (completion-pcm--all-completions prefix pattern table pred))) | |
125f7951 | 2776 | (completion-hilit-commonality all point (car bounds)))) |
19c04f39 | 2777 | |
34200787 SM |
2778 | ;;; Partial-completion-mode style completion. |
2779 | ||
890429cc SM |
2780 | (defvar completion-pcm--delim-wild-regex nil |
2781 | "Regular expression matching delimiters controlling the partial-completion. | |
2782 | Typically, this regular expression simply matches a delimiter, meaning | |
2783 | that completion can add something at (match-beginning 0), but if it has | |
2784 | a submatch 1, then completion can add something at (match-end 1). | |
2785 | This is used when the delimiter needs to be of size zero (e.g. the transition | |
2786 | from lowercase to uppercase characters).") | |
34200787 SM |
2787 | |
2788 | (defun completion-pcm--prepare-delim-re (delims) | |
2789 | (setq completion-pcm--delim-wild-regex (concat "[" delims "*]"))) | |
2790 | ||
a2a25d24 | 2791 | (defcustom completion-pcm-word-delimiters "-_./:| " |
34200787 SM |
2792 | "A string of characters treated as word delimiters for completion. |
2793 | Some arcane rules: | |
2794 | If `]' is in this string, it must come first. | |
2795 | If `^' is in this string, it must not come first. | |
2796 | If `-' is in this string, it must come first or right after `]'. | |
2797 | In other words, if S is this string, then `[S]' must be a valid Emacs regular | |
2798 | expression (not containing character ranges like `a-z')." | |
2799 | :set (lambda (symbol value) | |
2800 | (set-default symbol value) | |
2801 | ;; Refresh other vars. | |
2802 | (completion-pcm--prepare-delim-re value)) | |
2803 | :initialize 'custom-initialize-reset | |
2804 | :type 'string) | |
2805 | ||
79ccd68f SM |
2806 | (defcustom completion-pcm-complete-word-inserts-delimiters nil |
2807 | "Treat the SPC or - inserted by `minibuffer-complete-word' as delimiters. | |
d136f184 | 2808 | Those chars are treated as delimiters if this variable is non-nil. |
79ccd68f SM |
2809 | I.e. if non-nil, M-x SPC will just insert a \"-\" in the minibuffer, whereas |
2810 | if nil, it will list all possible commands in *Completions* because none of | |
2811 | the commands start with a \"-\" or a SPC." | |
2bed3f04 | 2812 | :version "24.1" |
79ccd68f SM |
2813 | :type 'boolean) |
2814 | ||
34200787 | 2815 | (defun completion-pcm--pattern-trivial-p (pattern) |
1bba1cfc SM |
2816 | (and (stringp (car pattern)) |
2817 | ;; It can be followed by `point' and "" and still be trivial. | |
2818 | (let ((trivial t)) | |
2819 | (dolist (elem (cdr pattern)) | |
2820 | (unless (member elem '(point "")) | |
2821 | (setq trivial nil))) | |
2822 | trivial))) | |
34200787 | 2823 | |
a38313e1 SM |
2824 | (defun completion-pcm--string->pattern (string &optional point) |
2825 | "Split STRING into a pattern. | |
34200787 | 2826 | A pattern is a list where each element is either a string |
934eacb9 | 2827 | or a symbol, see `completion-pcm--merge-completions'." |
a38313e1 SM |
2828 | (if (and point (< point (length string))) |
2829 | (let ((prefix (substring string 0 point)) | |
2830 | (suffix (substring string point))) | |
34200787 SM |
2831 | (append (completion-pcm--string->pattern prefix) |
2832 | '(point) | |
2833 | (completion-pcm--string->pattern suffix))) | |
3e2d70fd SM |
2834 | (let* ((pattern nil) |
2835 | (p 0) | |
67982e2b SM |
2836 | (p0 p) |
2837 | (pending nil)) | |
26c548b0 | 2838 | |
890429cc SM |
2839 | (while (and (setq p (string-match completion-pcm--delim-wild-regex |
2840 | string p)) | |
79ccd68f SM |
2841 | (or completion-pcm-complete-word-inserts-delimiters |
2842 | ;; If the char was added by minibuffer-complete-word, | |
2843 | ;; then don't treat it as a delimiter, otherwise | |
2844 | ;; "M-x SPC" ends up inserting a "-" rather than listing | |
2845 | ;; all completions. | |
2846 | (not (get-text-property p 'completion-try-word string)))) | |
890429cc SM |
2847 | ;; Usually, completion-pcm--delim-wild-regex matches a delimiter, |
2848 | ;; meaning that something can be added *before* it, but it can also | |
2849 | ;; match a prefix and postfix, in which case something can be added | |
2850 | ;; in-between (e.g. match [[:lower:]][[:upper:]]). | |
2851 | ;; This is determined by the presence of a submatch-1 which delimits | |
2852 | ;; the prefix. | |
2853 | (if (match-end 1) (setq p (match-end 1))) | |
67982e2b SM |
2854 | (unless (= p0 p) |
2855 | (if pending (push pending pattern)) | |
2856 | (push (substring string p0 p) pattern)) | |
2857 | (setq pending nil) | |
a38313e1 | 2858 | (if (eq (aref string p) ?*) |
34200787 SM |
2859 | (progn |
2860 | (push 'star pattern) | |
2861 | (setq p0 (1+ p))) | |
2862 | (push 'any pattern) | |
67982e2b SM |
2863 | (if (match-end 1) |
2864 | (setq p0 p) | |
2865 | (push (substring string p (match-end 0)) pattern) | |
2866 | ;; `any-delim' is used so that "a-b" also finds "array->beginning". | |
2867 | (setq pending 'any-delim) | |
2868 | (setq p0 (match-end 0)))) | |
2869 | (setq p p0)) | |
2870 | ||
2871 | (when (> (length string) p0) | |
2872 | (if pending (push pending pattern)) | |
2873 | (push (substring string p0) pattern)) | |
34200787 SM |
2874 | ;; An empty string might be erroneously added at the beginning. |
2875 | ;; It should be avoided properly, but it's so easy to remove it here. | |
67982e2b SM |
2876 | (delete "" (nreverse pattern))))) |
2877 | ||
2878 | (defun completion-pcm--optimize-pattern (p) | |
2879 | ;; Remove empty strings in a separate phase since otherwise a "" | |
2880 | ;; might prevent some other optimization, as in '(any "" any). | |
2881 | (setq p (delete "" p)) | |
2882 | (let ((n '())) | |
2883 | (while p | |
2884 | (pcase p | |
2885 | (`(,(and s1 (pred stringp)) ,(and s2 (pred stringp)) . ,rest) | |
2886 | (setq p (cons (concat s1 s2) rest))) | |
2887 | (`(,(and p1 (pred symbolp)) ,(and p2 (guard (eq p1 p2))) . ,_) | |
2888 | (setq p (cdr p))) | |
2889 | (`(star ,(pred symbolp) . ,rest) (setq p `(star . ,rest))) | |
2890 | (`(,(pred symbolp) star . ,rest) (setq p `(star . ,rest))) | |
2891 | (`(point ,(or `any `any-delim) . ,rest) (setq p `(point . ,rest))) | |
2892 | (`(,(or `any `any-delim) point . ,rest) (setq p `(point . ,rest))) | |
2893 | (`(any ,(or `any `any-delim) . ,rest) (setq p `(any . ,rest))) | |
2894 | (`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'. | |
2895 | (_ (push (pop p) n)))) | |
2896 | (nreverse n))) | |
34200787 SM |
2897 | |
2898 | (defun completion-pcm--pattern->regex (pattern &optional group) | |
a38313e1 | 2899 | (let ((re |
ab22be48 SM |
2900 | (concat "\\`" |
2901 | (mapconcat | |
2902 | (lambda (x) | |
79ccd68f SM |
2903 | (cond |
2904 | ((stringp x) (regexp-quote x)) | |
67982e2b SM |
2905 | (t |
2906 | (let ((re (if (eq x 'any-delim) | |
2907 | (concat completion-pcm--delim-wild-regex "*?") | |
2908 | ".*?"))) | |
2909 | (if (if (consp group) (memq x group) group) | |
2910 | (concat "\\(" re "\\)") | |
2911 | re))))) | |
ab22be48 | 2912 | pattern |
15c72e1d | 2913 | "")))) |
a38313e1 SM |
2914 | ;; Avoid pathological backtracking. |
2915 | (while (string-match "\\.\\*\\?\\(?:\\\\[()]\\)*\\(\\.\\*\\?\\)" re) | |
2916 | (setq re (replace-match "" t t re 1))) | |
2917 | re)) | |
34200787 | 2918 | |
a38313e1 | 2919 | (defun completion-pcm--all-completions (prefix pattern table pred) |
34200787 | 2920 | "Find all completions for PATTERN in TABLE obeying PRED. |
26c548b0 | 2921 | PATTERN is as returned by `completion-pcm--string->pattern'." |
f58e0fd5 | 2922 | ;; (cl-assert (= (car (completion-boundaries prefix table pred "")) |
125f7951 | 2923 | ;; (length prefix))) |
34200787 SM |
2924 | ;; Find an initial list of possible completions. |
2925 | (if (completion-pcm--pattern-trivial-p pattern) | |
2926 | ||
2927 | ;; Minibuffer contains no delimiters -- simple case! | |
125f7951 | 2928 | (all-completions (concat prefix (car pattern)) table pred) |
26c548b0 | 2929 | |
34200787 SM |
2930 | ;; Use all-completions to do an initial cull. This is a big win, |
2931 | ;; since all-completions is written in C! | |
2932 | (let* (;; Convert search pattern to a standard regular expression. | |
2933 | (regex (completion-pcm--pattern->regex pattern)) | |
15c72e1d SM |
2934 | (case-fold-search completion-ignore-case) |
2935 | (completion-regexp-list (cons regex completion-regexp-list)) | |
34200787 | 2936 | (compl (all-completions |
30a23501 SM |
2937 | (concat prefix |
2938 | (if (stringp (car pattern)) (car pattern) "")) | |
125f7951 | 2939 | table pred))) |
34200787 SM |
2940 | (if (not (functionp table)) |
2941 | ;; The internal functions already obeyed completion-regexp-list. | |
2942 | compl | |
15c72e1d | 2943 | (let ((poss ())) |
34200787 | 2944 | (dolist (c compl) |
9f3618b5 | 2945 | (when (string-match-p regex c) (push c poss))) |
34200787 SM |
2946 | poss))))) |
2947 | ||
7372b09c SM |
2948 | (defun completion-pcm--hilit-commonality (pattern completions) |
2949 | (when completions | |
2950 | (let* ((re (completion-pcm--pattern->regex pattern '(point))) | |
1bba1cfc | 2951 | (case-fold-search completion-ignore-case)) |
1bba1cfc SM |
2952 | (mapcar |
2953 | (lambda (str) | |
2954 | ;; Don't modify the string itself. | |
2955 | (setq str (copy-sequence str)) | |
2956 | (unless (string-match re str) | |
2957 | (error "Internal error: %s does not match %s" re str)) | |
2958 | (let ((pos (or (match-beginning 1) (match-end 0)))) | |
2959 | (put-text-property 0 pos | |
2960 | 'font-lock-face 'completions-common-part | |
2961 | str) | |
2962 | (if (> (length str) pos) | |
2963 | (put-text-property pos (1+ pos) | |
2964 | 'font-lock-face 'completions-first-difference | |
2965 | str))) | |
2966 | str) | |
2967 | completions)))) | |
7372b09c | 2968 | |
eee6de73 SM |
2969 | (defun completion-pcm--find-all-completions (string table pred point |
2970 | &optional filter) | |
2971 | "Find all completions for STRING at POINT in TABLE, satisfying PRED. | |
2972 | POINT is a position inside STRING. | |
2973 | FILTER is a function applied to the return value, that can be used, e.g. to | |
53964682 | 2974 | filter out additional entries (because TABLE might not obey PRED)." |
eee6de73 | 2975 | (unless filter (setq filter 'identity)) |
a647cb26 SM |
2976 | (let* ((beforepoint (substring string 0 point)) |
2977 | (afterpoint (substring string point)) | |
2978 | (bounds (completion-boundaries beforepoint table pred afterpoint)) | |
2979 | (prefix (substring beforepoint 0 (car bounds))) | |
2980 | (suffix (substring afterpoint (cdr bounds))) | |
2981 | firsterror) | |
f8381803 SM |
2982 | (setq string (substring string (car bounds) (+ point (cdr bounds)))) |
2983 | (let* ((relpoint (- point (car bounds))) | |
2984 | (pattern (completion-pcm--string->pattern string relpoint)) | |
67982e2b | 2985 | (all (condition-case-unless-debug err |
eee6de73 SM |
2986 | (funcall filter |
2987 | (completion-pcm--all-completions | |
2988 | prefix pattern table pred)) | |
67982e2b | 2989 | (error (setq firsterror err) nil)))) |
a38313e1 SM |
2990 | (when (and (null all) |
2991 | (> (car bounds) 0) | |
2992 | (null (ignore-errors (try-completion prefix table pred)))) | |
2993 | ;; The prefix has no completions at all, so we should try and fix | |
2994 | ;; that first. | |
2995 | (let ((substring (substring prefix 0 -1))) | |
f58e0fd5 SM |
2996 | (pcase-let ((`(,subpat ,suball ,subprefix ,_subsuffix) |
2997 | (completion-pcm--find-all-completions | |
2998 | substring table pred (length substring) filter))) | |
a38313e1 SM |
2999 | (let ((sep (aref prefix (1- (length prefix)))) |
3000 | ;; Text that goes between the new submatches and the | |
3001 | ;; completion substring. | |
3002 | (between nil)) | |
3003 | ;; Eliminate submatches that don't end with the separator. | |
3004 | (dolist (submatch (prog1 suball (setq suball ()))) | |
3005 | (when (eq sep (aref submatch (1- (length submatch)))) | |
3006 | (push submatch suball))) | |
3007 | (when suball | |
3008 | ;; Update the boundaries and corresponding pattern. | |
3009 | ;; We assume that all submatches result in the same boundaries | |
3010 | ;; since we wouldn't know how to merge them otherwise anyway. | |
f8381803 SM |
3011 | ;; FIXME: COMPLETE REWRITE!!! |
3012 | (let* ((newbeforepoint | |
3013 | (concat subprefix (car suball) | |
3014 | (substring string 0 relpoint))) | |
3015 | (leftbound (+ (length subprefix) (length (car suball)))) | |
a38313e1 | 3016 | (newbounds (completion-boundaries |
f8381803 SM |
3017 | newbeforepoint table pred afterpoint))) |
3018 | (unless (or (and (eq (cdr bounds) (cdr newbounds)) | |
3019 | (eq (car newbounds) leftbound)) | |
a38313e1 SM |
3020 | ;; Refuse new boundaries if they step over |
3021 | ;; the submatch. | |
f8381803 | 3022 | (< (car newbounds) leftbound)) |
a38313e1 SM |
3023 | ;; The new completed prefix does change the boundaries |
3024 | ;; of the completed substring. | |
f8381803 SM |
3025 | (setq suffix (substring afterpoint (cdr newbounds))) |
3026 | (setq string | |
3027 | (concat (substring newbeforepoint (car newbounds)) | |
3028 | (substring afterpoint 0 (cdr newbounds)))) | |
3029 | (setq between (substring newbeforepoint leftbound | |
a38313e1 SM |
3030 | (car newbounds))) |
3031 | (setq pattern (completion-pcm--string->pattern | |
f8381803 SM |
3032 | string |
3033 | (- (length newbeforepoint) | |
3034 | (car newbounds))))) | |
a38313e1 | 3035 | (dolist (submatch suball) |
30a23501 SM |
3036 | (setq all (nconc |
3037 | (mapcar | |
3038 | (lambda (s) (concat submatch between s)) | |
3039 | (funcall filter | |
3040 | (completion-pcm--all-completions | |
3041 | (concat subprefix submatch between) | |
3042 | pattern table pred))) | |
3043 | all))) | |
c63028e1 SM |
3044 | ;; FIXME: This can come in handy for try-completion, |
3045 | ;; but isn't right for all-completions, since it lists | |
3046 | ;; invalid completions. | |
3047 | ;; (unless all | |
3048 | ;; ;; Even though we found expansions in the prefix, none | |
3049 | ;; ;; leads to a valid completion. | |
3050 | ;; ;; Let's keep the expansions, tho. | |
3051 | ;; (dolist (submatch suball) | |
3052 | ;; (push (concat submatch between newsubstring) all))) | |
3053 | )) | |
a38313e1 SM |
3054 | (setq pattern (append subpat (list 'any (string sep)) |
3055 | (if between (list between)) pattern)) | |
3056 | (setq prefix subprefix))))) | |
3057 | (if (and (null all) firsterror) | |
3058 | (signal (car firsterror) (cdr firsterror)) | |
3059 | (list pattern all prefix suffix))))) | |
3060 | ||
34200787 | 3061 | (defun completion-pcm-all-completions (string table pred point) |
f58e0fd5 SM |
3062 | (pcase-let ((`(,pattern ,all ,prefix ,_suffix) |
3063 | (completion-pcm--find-all-completions string table pred point))) | |
d4e88786 SM |
3064 | (when all |
3065 | (nconc (completion-pcm--hilit-commonality pattern all) | |
3066 | (length prefix))))) | |
34200787 | 3067 | |
1493963b SM |
3068 | (defun completion--common-suffix (strs) |
3069 | "Return the common suffix of the strings STRS." | |
e4829cb8 | 3070 | (nreverse (try-completion "" (mapcar #'reverse strs)))) |
1493963b | 3071 | |
34200787 | 3072 | (defun completion-pcm--merge-completions (strs pattern) |
934eacb9 SM |
3073 | "Extract the commonality in STRS, with the help of PATTERN. |
3074 | PATTERN can contain strings and symbols chosen among `star', `any', `point', | |
3075 | and `prefix'. They all match anything (aka \".*\") but are merged differently: | |
3076 | `any' only grows from the left (when matching \"a1b\" and \"a2b\" it gets | |
3077 | completed to just \"a\"). | |
3078 | `prefix' only grows from the right (when matching \"a1b\" and \"a2b\" it gets | |
3079 | completed to just \"b\"). | |
3080 | `star' grows from both ends and is reified into a \"*\" (when matching \"a1b\" | |
3081 | and \"a2b\" it gets completed to \"a*b\"). | |
3082 | `point' is like `star' except that it gets reified as the position of point | |
3083 | instead of being reified as a \"*\" character. | |
3084 | The underlying idea is that we should return a string which still matches | |
3085 | the same set of elements." | |
681e0e7c SM |
3086 | ;; When completing while ignoring case, we want to try and avoid |
3087 | ;; completing "fo" to "foO" when completing against "FOO" (bug#4219). | |
3088 | ;; So we try and make sure that the string we return is all made up | |
3089 | ;; of text from the completions rather than part from the | |
3090 | ;; completions and part from the input. | |
3091 | ;; FIXME: This reduces the problems of inconsistent capitalization | |
3092 | ;; but it doesn't fully fix it: we may still end up completing | |
3093 | ;; "fo-ba" to "foo-BAR" or "FOO-bar" when completing against | |
3094 | ;; '("foo-barr" "FOO-BARD"). | |
34200787 SM |
3095 | (cond |
3096 | ((null (cdr strs)) (list (car strs))) | |
3097 | (t | |
3098 | (let ((re (completion-pcm--pattern->regex pattern 'group)) | |
3099 | (ccs ())) ;Chopped completions. | |
3100 | ||
3101 | ;; First chop each string into the parts corresponding to each | |
3102 | ;; non-constant element of `pattern', using regexp-matching. | |
3103 | (let ((case-fold-search completion-ignore-case)) | |
3104 | (dolist (str strs) | |
3105 | (unless (string-match re str) | |
3106 | (error "Internal error: %s doesn't match %s" str re)) | |
3107 | (let ((chopped ()) | |
681e0e7c SM |
3108 | (last 0) |
3109 | (i 1) | |
3110 | next) | |
3111 | (while (setq next (match-end i)) | |
3112 | (push (substring str last next) chopped) | |
3113 | (setq last next) | |
34200787 SM |
3114 | (setq i (1+ i))) |
3115 | ;; Add the text corresponding to the implicit trailing `any'. | |
681e0e7c | 3116 | (push (substring str last) chopped) |
34200787 SM |
3117 | (push (nreverse chopped) ccs)))) |
3118 | ||
3119 | ;; Then for each of those non-constant elements, extract the | |
3120 | ;; commonality between them. | |
681e0e7c SM |
3121 | (let ((res ()) |
3122 | (fixed "")) | |
3123 | ;; Make the implicit trailing `any' explicit. | |
34200787 SM |
3124 | (dolist (elem (append pattern '(any))) |
3125 | (if (stringp elem) | |
681e0e7c | 3126 | (setq fixed (concat fixed elem)) |
34200787 SM |
3127 | (let ((comps ())) |
3128 | (dolist (cc (prog1 ccs (setq ccs nil))) | |
3129 | (push (car cc) comps) | |
3130 | (push (cdr cc) ccs)) | |
681e0e7c SM |
3131 | ;; Might improve the likelihood to avoid choosing |
3132 | ;; different capitalizations in different parts. | |
3133 | ;; In practice, it doesn't seem to make any difference. | |
3134 | (setq ccs (nreverse ccs)) | |
3135 | (let* ((prefix (try-completion fixed comps)) | |
3136 | (unique (or (and (eq prefix t) (setq prefix fixed)) | |
34200787 | 3137 | (eq t (try-completion prefix comps))))) |
934eacb9 SM |
3138 | (unless (or (eq elem 'prefix) |
3139 | (equal prefix "")) | |
3140 | (push prefix res)) | |
34200787 SM |
3141 | ;; If there's only one completion, `elem' is not useful |
3142 | ;; any more: it can only match the empty string. | |
3143 | ;; FIXME: in some cases, it may be necessary to turn an | |
3144 | ;; `any' into a `star' because the surrounding context has | |
3145 | ;; changed such that string->pattern wouldn't add an `any' | |
3146 | ;; here any more. | |
1493963b SM |
3147 | (unless unique |
3148 | (push elem res) | |
b1da2957 SM |
3149 | ;; Extract common suffix additionally to common prefix. |
3150 | ;; Don't do it for `any' since it could lead to a merged | |
3151 | ;; completion that doesn't itself match the candidates. | |
3152 | (when (and (memq elem '(star point prefix)) | |
3153 | ;; If prefix is one of the completions, there's no | |
3154 | ;; suffix left to find. | |
3155 | (not (assoc-string prefix comps t))) | |
3156 | (let ((suffix | |
3157 | (completion--common-suffix | |
3158 | (if (zerop (length prefix)) comps | |
3159 | ;; Ignore the chars in the common prefix, so we | |
3160 | ;; don't merge '("abc" "abbc") as "ab*bc". | |
3161 | (let ((skip (length prefix))) | |
3162 | (mapcar (lambda (str) (substring str skip)) | |
3163 | comps)))))) | |
f58e0fd5 | 3164 | (cl-assert (stringp suffix)) |
1493963b SM |
3165 | (unless (equal suffix "") |
3166 | (push suffix res))))) | |
681e0e7c | 3167 | (setq fixed ""))))) |
34200787 SM |
3168 | ;; We return it in reverse order. |
3169 | res))))) | |
3170 | ||
3171 | (defun completion-pcm--pattern->string (pattern) | |
3172 | (mapconcat (lambda (x) (cond | |
03408648 SM |
3173 | ((stringp x) x) |
3174 | ((eq x 'star) "*") | |
3175 | (t ""))) ;any, point, prefix. | |
34200787 SM |
3176 | pattern |
3177 | "")) | |
3178 | ||
eee6de73 SM |
3179 | ;; We want to provide the functionality of `try', but we use `all' |
3180 | ;; and then merge it. In most cases, this works perfectly, but | |
3181 | ;; if the completion table doesn't consider the same completions in | |
3182 | ;; `try' as in `all', then we have a problem. The most common such | |
3183 | ;; case is for filename completion where completion-ignored-extensions | |
3184 | ;; is only obeyed by the `try' code. We paper over the difference | |
3185 | ;; here. Note that it is not quite right either: if the completion | |
3186 | ;; table uses completion-table-in-turn, this filtering may take place | |
3187 | ;; too late to correctly fallback from the first to the | |
3188 | ;; second alternative. | |
3189 | (defun completion-pcm--filename-try-filter (all) | |
3190 | "Filter to adjust `all' file completion to the behavior of `try'." | |
03408648 | 3191 | (when all |
eee6de73 SM |
3192 | (let ((try ()) |
3193 | (re (concat "\\(?:\\`\\.\\.?/\\|" | |
3194 | (regexp-opt completion-ignored-extensions) | |
3195 | "\\)\\'"))) | |
3196 | (dolist (f all) | |
9f3618b5 | 3197 | (unless (string-match-p re f) (push f try))) |
eee6de73 | 3198 | (or try all)))) |
9f3618b5 | 3199 | |
eee6de73 SM |
3200 | |
3201 | (defun completion-pcm--merge-try (pattern all prefix suffix) | |
3202 | (cond | |
3203 | ((not (consp all)) all) | |
3204 | ((and (not (consp (cdr all))) ;Only one completion. | |
3205 | ;; Ignore completion-ignore-case here. | |
3206 | (equal (completion-pcm--pattern->string pattern) (car all))) | |
3207 | t) | |
3208 | (t | |
03408648 SM |
3209 | (let* ((mergedpat (completion-pcm--merge-completions all pattern)) |
3210 | ;; `mergedpat' is in reverse order. Place new point (by | |
3211 | ;; order of preference) either at the old point, or at | |
3212 | ;; the last place where there's something to choose, or | |
3213 | ;; at the very end. | |
3214 | (pointpat (or (memq 'point mergedpat) | |
3215 | (memq 'any mergedpat) | |
3216 | (memq 'star mergedpat) | |
3217 | ;; Not `prefix'. | |
3218 | mergedpat)) | |
3219 | ;; New pos from the start. | |
34cba8e8 | 3220 | (newpos (length (completion-pcm--pattern->string pointpat))) |
9858f6c3 | 3221 | ;; Do it afterwards because it changes `pointpat' by side effect. |
03408648 | 3222 | (merged (completion-pcm--pattern->string (nreverse mergedpat)))) |
eee6de73 | 3223 | |
34cba8e8 SB |
3224 | (setq suffix (completion--merge-suffix |
3225 | ;; The second arg should ideally be "the position right | |
3226 | ;; after the last char of `merged' that comes from the text | |
3227 | ;; to be completed". But completion-pcm--merge-completions | |
3228 | ;; currently doesn't give us that info. So instead we just | |
3229 | ;; use the "last but one" position, which tends to work | |
3230 | ;; well in practice since `suffix' always starts | |
3231 | ;; with a boundary and we hence mostly/only care about | |
3232 | ;; merging this boundary (bug#15419). | |
3233 | merged (max 0 (1- (length merged))) suffix)) | |
03408648 | 3234 | (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) |
34200787 | 3235 | |
eee6de73 | 3236 | (defun completion-pcm-try-completion (string table pred point) |
f58e0fd5 SM |
3237 | (pcase-let ((`(,pattern ,all ,prefix ,suffix) |
3238 | (completion-pcm--find-all-completions | |
3239 | string table pred point | |
3240 | (if minibuffer-completing-file-name | |
3241 | 'completion-pcm--filename-try-filter)))) | |
eee6de73 SM |
3242 | (completion-pcm--merge-try pattern all prefix suffix))) |
3243 | ||
00278747 SM |
3244 | ;;; Substring completion |
3245 | ;; Mostly derived from the code of `basic' completion. | |
3246 | ||
3247 | (defun completion-substring--all-completions (string table pred point) | |
3248 | (let* ((beforepoint (substring string 0 point)) | |
3249 | (afterpoint (substring string point)) | |
3250 | (bounds (completion-boundaries beforepoint table pred afterpoint)) | |
3251 | (suffix (substring afterpoint (cdr bounds))) | |
3252 | (prefix (substring beforepoint 0 (car bounds))) | |
3253 | (basic-pattern (completion-basic--pattern | |
3254 | beforepoint afterpoint bounds)) | |
3255 | (pattern (if (not (stringp (car basic-pattern))) | |
3256 | basic-pattern | |
79ccd68f | 3257 | (cons 'prefix basic-pattern))) |
00278747 SM |
3258 | (all (completion-pcm--all-completions prefix pattern table pred))) |
3259 | (list all pattern prefix suffix (car bounds)))) | |
3260 | ||
3261 | (defun completion-substring-try-completion (string table pred point) | |
f58e0fd5 SM |
3262 | (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds) |
3263 | (completion-substring--all-completions | |
3264 | string table pred point))) | |
00278747 SM |
3265 | (if minibuffer-completing-file-name |
3266 | (setq all (completion-pcm--filename-try-filter all))) | |
3267 | (completion-pcm--merge-try pattern all prefix suffix))) | |
3268 | ||
3269 | (defun completion-substring-all-completions (string table pred point) | |
f58e0fd5 SM |
3270 | (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds) |
3271 | (completion-substring--all-completions | |
3272 | string table pred point))) | |
00278747 SM |
3273 | (when all |
3274 | (nconc (completion-pcm--hilit-commonality pattern all) | |
3275 | (length prefix))))) | |
3276 | ||
3277 | ;; Initials completion | |
fcb68f70 SM |
3278 | ;; Complete /ums to /usr/monnier/src or lch to list-command-history. |
3279 | ||
3280 | (defun completion-initials-expand (str table pred) | |
51b23c44 SM |
3281 | (let ((bounds (completion-boundaries str table pred ""))) |
3282 | (unless (or (zerop (length str)) | |
3283 | ;; Only check within the boundaries, since the | |
3284 | ;; boundary char (e.g. /) might be in delim-regexp. | |
3285 | (string-match completion-pcm--delim-wild-regex str | |
3286 | (car bounds))) | |
fcb68f70 SM |
3287 | (if (zerop (car bounds)) |
3288 | (mapconcat 'string str "-") | |
3289 | ;; If there's a boundary, it's trickier. The main use-case | |
3290 | ;; we consider here is file-name completion. We'd like | |
3291 | ;; to expand ~/eee to ~/e/e/e and /eee to /e/e/e. | |
3292 | ;; But at the same time, we don't want /usr/share/ae to expand | |
3293 | ;; to /usr/share/a/e just because we mistyped "ae" for "ar", | |
3294 | ;; so we probably don't want initials to touch anything that | |
3295 | ;; looks like /usr/share/foo. As a heuristic, we just check that | |
3296 | ;; the text before the boundary char is at most 1 char. | |
3297 | ;; This allows both ~/eee and /eee and not much more. | |
3298 | ;; FIXME: It sadly also disallows the use of ~/eee when that's | |
3299 | ;; embedded within something else (e.g. "(~/eee" in Info node | |
3300 | ;; completion or "ancestor:/eee" in bzr-revision completion). | |
3301 | (when (< (car bounds) 3) | |
3302 | (let ((sep (substring str (1- (car bounds)) (car bounds)))) | |
3303 | ;; FIXME: the above string-match checks the whole string, whereas | |
3304 | ;; we end up only caring about the after-boundary part. | |
3305 | (concat (substring str 0 (car bounds)) | |
3306 | (mapconcat 'string (substring str (car bounds)) sep)))))))) | |
3307 | ||
d032d5e7 | 3308 | (defun completion-initials-all-completions (string table pred _point) |
fcb68f70 SM |
3309 | (let ((newstr (completion-initials-expand string table pred))) |
3310 | (when newstr | |
3311 | (completion-pcm-all-completions newstr table pred (length newstr))))) | |
3312 | ||
d032d5e7 | 3313 | (defun completion-initials-try-completion (string table pred _point) |
fcb68f70 SM |
3314 | (let ((newstr (completion-initials-expand string table pred))) |
3315 | (when newstr | |
3316 | (completion-pcm-try-completion newstr table pred (length newstr))))) | |
4e323265 LL |
3317 | \f |
3318 | (defvar completing-read-function 'completing-read-default | |
3319 | "The function called by `completing-read' to do its work. | |
3320 | It should accept the same arguments as `completing-read'.") | |
3321 | ||
3322 | (defun completing-read-default (prompt collection &optional predicate | |
3323 | require-match initial-input | |
3324 | hist def inherit-input-method) | |
3325 | "Default method for reading from the minibuffer with completion. | |
3326 | See `completing-read' for the meaning of the arguments." | |
3327 | ||
3328 | (when (consp initial-input) | |
3329 | (setq initial-input | |
3330 | (cons (car initial-input) | |
3331 | ;; `completing-read' uses 0-based index while | |
3332 | ;; `read-from-minibuffer' uses 1-based index. | |
3333 | (1+ (cdr initial-input))))) | |
3334 | ||
3335 | (let* ((minibuffer-completion-table collection) | |
3336 | (minibuffer-completion-predicate predicate) | |
3337 | (minibuffer-completion-confirm (unless (eq require-match t) | |
3338 | require-match)) | |
3349e122 | 3339 | (base-keymap (if require-match |
4e323265 | 3340 | minibuffer-local-must-match-map |
3349e122 SM |
3341 | minibuffer-local-completion-map)) |
3342 | (keymap (if (memq minibuffer-completing-file-name '(nil lambda)) | |
3343 | base-keymap | |
3344 | ;; Layer minibuffer-local-filename-completion-map | |
3345 | ;; on top of the base map. | |
640c8776 SM |
3346 | (make-composed-keymap |
3347 | minibuffer-local-filename-completion-map | |
3348 | ;; Set base-keymap as the parent, so that nil bindings | |
3349 | ;; in minibuffer-local-filename-completion-map can | |
3350 | ;; override bindings in base-keymap. | |
3351 | base-keymap))) | |
4e323265 LL |
3352 | (result (read-from-minibuffer prompt initial-input keymap |
3353 | nil hist def inherit-input-method))) | |
3354 | (when (and (equal result "") def) | |
3355 | (setq result (if (consp def) (car def) def))) | |
3356 | result)) | |
7d371eac JL |
3357 | \f |
3358 | ;; Miscellaneous | |
3359 | ||
3360 | (defun minibuffer-insert-file-name-at-point () | |
3361 | "Get a file name at point in original buffer and insert it to minibuffer." | |
3362 | (interactive) | |
3363 | (let ((file-name-at-point | |
3364 | (with-current-buffer (window-buffer (minibuffer-selected-window)) | |
3365 | (run-hook-with-args-until-success 'file-name-at-point-functions)))) | |
3366 | (when file-name-at-point | |
3367 | (insert file-name-at-point)))) | |
34200787 | 3368 | |
32bae13c | 3369 | (provide 'minibuffer) |
dc6ee347 | 3370 | |
32bae13c | 3371 | ;;; minibuffer.el ends here |