Commit | Line | Data |
---|---|---|
32bae13c SM |
1 | ;;; minibuffer.el --- Minibuffer completion functions |
2 | ||
3 | ;; Copyright (C) 2008 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | |
6 | ||
7 | ;; This file is part of GNU Emacs. | |
8 | ||
eb3fa2cf | 9 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
32bae13c SM |
10 | ;; it under the terms of the GNU General Public License as published by |
11 | ;; the Free Software Foundation, either version 3 of the License, or | |
12 | ;; (at your option) any later version. | |
13 | ||
eb3fa2cf | 14 | ;; GNU Emacs is distributed in the hope that it will be useful, |
32bae13c SM |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
eb3fa2cf | 20 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
32bae13c SM |
21 | |
22 | ;;; Commentary: | |
23 | ||
a38313e1 SM |
24 | ;; Names with "--" are for functions and variables that are meant to be for |
25 | ;; internal use only. | |
26 | ||
27 | ;; Functional completion tables have an extended calling conventions: | |
28 | ;; - If completion-all-completions-with-base-size is set, then all-completions | |
29 | ;; should return the base-size in the last cdr. | |
30 | ;; - The `action' can be (additionally to nil, t, and lambda) of the form | |
f8381803 SM |
31 | ;; (boundaries . SUFFIX) in which case it should return |
32 | ;; (boundaries START . END). See `completion-boundaries'. | |
a38313e1 SM |
33 | ;; Any other return value should be ignored (so we ignore values returned |
34 | ;; from completion tables that don't know about this new `action' form). | |
35 | ;; See `completion-boundaries'. | |
36 | ||
37 | ;;; Bugs: | |
38 | ||
eee6de73 SM |
39 | ;; - completion-all-sorted-completions list all the completions, whereas |
40 | ;; it should only lists the ones that `try-completion' would consider. | |
41 | ;; E.g. it should honor completion-ignored-extensions. | |
a38313e1 SM |
42 | ;; - choose-completion can't automatically figure out the boundaries |
43 | ;; corresponding to the displayed completions. `base-size' gives the left | |
44 | ;; boundary, but not the righthand one. So we need to add | |
45 | ;; completion-extra-size (and also completion-no-auto-exit). | |
ba5ff07b | 46 | |
3911966b SM |
47 | ;;; Todo: |
48 | ||
eee6de73 | 49 | ;; - make lisp-complete-symbol and sym-comp use it. |
a38313e1 | 50 | ;; - add support for ** to pcm. |
19c04f39 | 51 | ;; - Make read-file-name-predicate obsolete. |
3911966b SM |
52 | ;; - Add vc-file-name-completion-table to read-file-name-internal. |
53 | ;; - A feature like completing-help.el. | |
eee6de73 | 54 | ;; - make lisp/complete.el obsolete. |
3911966b | 55 | ;; - Make the `hide-spaces' arg of all-completions obsolete? |
32bae13c SM |
56 | |
57 | ;;; Code: | |
58 | ||
59 | (eval-when-compile (require 'cl)) | |
60 | ||
e2947429 SM |
61 | (defvar completion-all-completions-with-base-size nil |
62 | "If non-nil, `all-completions' may return the base-size in the last cdr. | |
63 | The base-size is the length of the prefix that is elided from each | |
64 | element in the returned list of completions. See `completion-base-size'.") | |
65 | ||
21622c6d SM |
66 | ;;; Completion table manipulation |
67 | ||
a38313e1 | 68 | ;; New completion-table operation. |
f8381803 SM |
69 | (defun completion-boundaries (string table pred suffix) |
70 | "Return the boundaries of the completions returned by TABLE for STRING. | |
a38313e1 | 71 | STRING is the string on which completion will be performed. |
f8381803 SM |
72 | SUFFIX is the string after point. |
73 | The result is of the form (START . END) where START is the position | |
74 | in STRING of the beginning of the completion field and END is the position | |
75 | in SUFFIX of the end of the completion field. | |
a38313e1 | 76 | I.e. START is the same as the `completion-base-size'. |
f8381803 SM |
77 | E.g. for simple completion tables, the result is always (0 . (length SUFFIX)) |
78 | and for file names the result is the positions delimited by | |
a38313e1 SM |
79 | the closest directory separators." |
80 | (let ((boundaries (if (functionp table) | |
f8381803 | 81 | (funcall table string pred (cons 'boundaries suffix))))) |
a38313e1 SM |
82 | (if (not (eq (car-safe boundaries) 'boundaries)) |
83 | (setq boundaries nil)) | |
84 | (cons (or (cadr boundaries) 0) | |
f8381803 | 85 | (or (cddr boundaries) (length suffix))))) |
a38313e1 | 86 | |
e2947429 SM |
87 | (defun completion--some (fun xs) |
88 | "Apply FUN to each element of XS in turn. | |
89 | Return the first non-nil returned value. | |
90 | Like CL's `some'." | |
a38313e1 SM |
91 | (let ((firsterror nil) |
92 | res) | |
e2947429 | 93 | (while (and (not res) xs) |
a38313e1 SM |
94 | (condition-case err |
95 | (setq res (funcall fun (pop xs))) | |
96 | (error (unless firsterror (setq firsterror err)) nil))) | |
97 | (or res | |
98 | (if firsterror (signal (car firsterror) (cdr firsterror)))))) | |
e2947429 | 99 | |
21622c6d | 100 | (defun apply-partially (fun &rest args) |
e2947429 SM |
101 | "Do a \"curried\" partial application of FUN to ARGS. |
102 | ARGS is a list of the first N arguments to pass to FUN. | |
103 | The result is a new function that takes the remaining arguments, | |
104 | and calls FUN." | |
21622c6d SM |
105 | (lexical-let ((fun fun) (args1 args)) |
106 | (lambda (&rest args2) (apply fun (append args1 args2))))) | |
107 | ||
108 | (defun complete-with-action (action table string pred) | |
109 | "Perform completion ACTION. | |
110 | STRING is the string to complete. | |
111 | TABLE is the completion table, which should not be a function. | |
112 | PRED is a completion predicate. | |
113 | ACTION can be one of nil, t or `lambda'." | |
a38313e1 SM |
114 | (cond |
115 | ((functionp table) (funcall table string pred action)) | |
116 | ((eq (car-safe action) 'boundaries) | |
117 | (cons 'boundaries (completion-boundaries string table pred (cdr action)))) | |
118 | (t | |
119 | (funcall | |
120 | (cond | |
121 | ((null action) 'try-completion) | |
122 | ((eq action t) 'all-completions) | |
123 | (t 'test-completion)) | |
124 | string table pred)))) | |
21622c6d SM |
125 | |
126 | (defun completion-table-dynamic (fun) | |
127 | "Use function FUN as a dynamic completion table. | |
128 | FUN is called with one argument, the string for which completion is required, | |
b95c7600 JB |
129 | and it should return an alist containing all the intended possible completions. |
130 | This alist may be a full list of possible completions so that FUN can ignore | |
131 | the value of its argument. If completion is performed in the minibuffer, | |
132 | FUN will be called in the buffer from which the minibuffer was entered. | |
21622c6d SM |
133 | |
134 | The result of the `dynamic-completion-table' form is a function | |
d9aa6b33 | 135 | that can be used as the COLLECTION argument to `try-completion' and |
b95c7600 | 136 | `all-completions'. See Info node `(elisp)Programmed Completion'." |
21622c6d SM |
137 | (lexical-let ((fun fun)) |
138 | (lambda (string pred action) | |
139 | (with-current-buffer (let ((win (minibuffer-selected-window))) | |
140 | (if (window-live-p win) (window-buffer win) | |
141 | (current-buffer))) | |
142 | (complete-with-action action (funcall fun string) string pred))))) | |
143 | ||
144 | (defmacro lazy-completion-table (var fun) | |
145 | "Initialize variable VAR as a lazy completion table. | |
146 | If the completion table VAR is used for the first time (e.g., by passing VAR | |
147 | as an argument to `try-completion'), the function FUN is called with no | |
148 | arguments. FUN must return the completion table that will be stored in VAR. | |
149 | If completion is requested in the minibuffer, FUN will be called in the buffer | |
150 | from which the minibuffer was entered. The return value of | |
151 | `lazy-completion-table' must be used to initialize the value of VAR. | |
152 | ||
153 | You should give VAR a non-nil `risky-local-variable' property." | |
69e018a7 | 154 | (declare (debug (symbolp lambda-expr))) |
21622c6d SM |
155 | (let ((str (make-symbol "string"))) |
156 | `(completion-table-dynamic | |
157 | (lambda (,str) | |
158 | (when (functionp ,var) | |
159 | (setq ,var (,fun))) | |
160 | ,var)))) | |
161 | ||
162 | (defun completion-table-with-context (prefix table string pred action) | |
25c0d999 | 163 | ;; TODO: add `suffix' maybe? |
a38313e1 | 164 | ;; Notice that `pred' may not be a function in some abusive cases. |
34200787 SM |
165 | (when (functionp pred) |
166 | (setq pred | |
167 | (lexical-let ((pred pred)) | |
168 | ;; Predicates are called differently depending on the nature of | |
169 | ;; the completion table :-( | |
170 | (cond | |
171 | ((vectorp table) ;Obarray. | |
172 | (lambda (sym) (funcall pred (concat prefix (symbol-name sym))))) | |
173 | ((hash-table-p table) | |
174 | (lambda (s v) (funcall pred (concat prefix s)))) | |
175 | ((functionp table) | |
176 | (lambda (s) (funcall pred (concat prefix s)))) | |
177 | (t ;Lists and alists. | |
178 | (lambda (s) | |
179 | (funcall pred (concat prefix (if (consp s) (car s) s))))))))) | |
a38313e1 SM |
180 | (if (eq (car-safe action) 'boundaries) |
181 | (let* ((len (length prefix)) | |
f8381803 SM |
182 | (bound (completion-boundaries string table pred (cdr action)))) |
183 | (list* 'boundaries (+ (car bound) len) (cdr bound))) | |
a38313e1 SM |
184 | (let ((comp (complete-with-action action table string pred))) |
185 | (cond | |
186 | ;; In case of try-completion, add the prefix. | |
187 | ((stringp comp) (concat prefix comp)) | |
188 | ;; In case of non-empty all-completions, | |
189 | ;; add the prefix size to the base-size. | |
190 | ((consp comp) | |
191 | (let ((last (last comp))) | |
192 | (when completion-all-completions-with-base-size | |
193 | (setcdr last (+ (or (cdr last) 0) (length prefix)))) | |
194 | comp)) | |
195 | (t comp))))) | |
21622c6d SM |
196 | |
197 | (defun completion-table-with-terminator (terminator table string pred action) | |
25c0d999 SM |
198 | (cond |
199 | ((eq action nil) | |
200 | (let ((comp (try-completion string table pred))) | |
88893215 SM |
201 | (if (eq comp t) |
202 | (concat string terminator) | |
203 | (if (and (stringp comp) | |
25c0d999 | 204 | (eq (try-completion comp table pred) t)) |
88893215 | 205 | (concat comp terminator) |
25c0d999 | 206 | comp)))) |
a38313e1 SM |
207 | ((eq action t) |
208 | ;; FIXME: We generally want the `try' and `all' behaviors to be | |
209 | ;; consistent so pcm can merge the `all' output to get the `try' output, | |
210 | ;; but that sometimes clashes with the need for `all' output to look | |
211 | ;; good in *Completions*. | |
212 | ;; (let* ((all (all-completions string table pred)) | |
213 | ;; (last (last all)) | |
214 | ;; (base-size (cdr last))) | |
215 | ;; (when all | |
216 | ;; (setcdr all nil) | |
217 | ;; (nconc (mapcar (lambda (s) (concat s terminator)) all) base-size))) | |
218 | (all-completions string table pred)) | |
25c0d999 SM |
219 | ;; completion-table-with-terminator is always used for |
220 | ;; "sub-completions" so it's only called if the terminator is missing, | |
221 | ;; in which case `test-completion' should return nil. | |
222 | ((eq action 'lambda) nil))) | |
223 | ||
224 | (defun completion-table-with-predicate (table pred1 strict string pred2 action) | |
225 | "Make a completion table equivalent to TABLE but filtered through PRED1. | |
cf43708e | 226 | PRED1 is a function of one argument which returns non-nil if and only if the |
25c0d999 SM |
227 | argument is an element of TABLE which should be considered for completion. |
228 | STRING, PRED2, and ACTION are the usual arguments to completion tables, | |
229 | as described in `try-completion', `all-completions', and `test-completion'. | |
3911966b SM |
230 | If STRICT is t, the predicate always applies; if nil it only applies if |
231 | it does not reduce the set of possible completions to nothing. | |
25c0d999 SM |
232 | Note: TABLE needs to be a proper completion table which obeys predicates." |
233 | (cond | |
234 | ((and (not strict) (eq action 'lambda)) | |
235 | ;; Ignore pred1 since it doesn't really have to apply anyway. | |
af48580e | 236 | (test-completion string table pred2)) |
25c0d999 SM |
237 | (t |
238 | (or (complete-with-action action table string | |
239 | (if (null pred2) pred1 | |
240 | (lexical-let ((pred1 pred2) (pred2 pred2)) | |
241 | (lambda (x) | |
242 | ;; Call `pred1' first, so that `pred2' | |
243 | ;; really can't tell that `x' is in table. | |
244 | (if (funcall pred1 x) (funcall pred2 x)))))) | |
245 | ;; If completion failed and we're not applying pred1 strictly, try | |
246 | ;; again without pred1. | |
247 | (and (not strict) | |
248 | (complete-with-action action table string pred2)))))) | |
21622c6d | 249 | |
e2947429 SM |
250 | (defun completion-table-in-turn (&rest tables) |
251 | "Create a completion table that tries each table in TABLES in turn." | |
252 | (lexical-let ((tables tables)) | |
21622c6d | 253 | (lambda (string pred action) |
e2947429 SM |
254 | (completion--some (lambda (table) |
255 | (complete-with-action action table string pred)) | |
256 | tables)))) | |
257 | ||
25c0d999 SM |
258 | ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) |
259 | ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) | |
e2947429 SM |
260 | (define-obsolete-function-alias |
261 | 'complete-in-turn 'completion-table-in-turn "23.1") | |
25c0d999 SM |
262 | (define-obsolete-function-alias |
263 | 'dynamic-completion-table 'completion-table-dynamic "23.1") | |
21622c6d SM |
264 | |
265 | ;;; Minibuffer completion | |
266 | ||
ba5ff07b SM |
267 | (defgroup minibuffer nil |
268 | "Controlling the behavior of the minibuffer." | |
269 | :link '(custom-manual "(emacs)Minibuffer") | |
270 | :group 'environment) | |
271 | ||
32bae13c SM |
272 | (defun minibuffer-message (message &rest args) |
273 | "Temporarily display MESSAGE at the end of the minibuffer. | |
274 | The text is displayed for `minibuffer-message-timeout' seconds, | |
275 | or until the next input event arrives, whichever comes first. | |
276 | Enclose MESSAGE in [...] if this is not yet the case. | |
277 | If ARGS are provided, then pass MESSAGE through `format'." | |
278 | ;; Clear out any old echo-area message to make way for our new thing. | |
279 | (message nil) | |
bd5c2732 SM |
280 | (setq message (if (and (null args) (string-match "\\[.+\\]" message)) |
281 | ;; Make sure we can put-text-property. | |
282 | (copy-sequence message) | |
283 | (concat " [" message "]"))) | |
32bae13c | 284 | (when args (setq message (apply 'format message args))) |
24f7ee4c | 285 | (let ((ol (make-overlay (point-max) (point-max) nil t t)) |
eee6de73 SM |
286 | ;; A quit during sit-for normally only interrupts the sit-for, |
287 | ;; but since minibuffer-message is used at the end of a command, | |
288 | ;; at a time when the command has virtually finished already, a C-g | |
289 | ;; should really cause an abort-recursive-edit instead (i.e. as if | |
290 | ;; the C-g had been typed at top-level). Binding inhibit-quit here | |
291 | ;; is an attempt to get that behavior. | |
24f7ee4c | 292 | (inhibit-quit t)) |
32bae13c SM |
293 | (unwind-protect |
294 | (progn | |
bf87d5fc SM |
295 | (unless (zerop (length message)) |
296 | ;; The current C cursor code doesn't know to use the overlay's | |
297 | ;; marker's stickiness to figure out whether to place the cursor | |
298 | ;; before or after the string, so let's spoon-feed it the pos. | |
299 | (put-text-property 0 1 'cursor t message)) | |
32bae13c SM |
300 | (overlay-put ol 'after-string message) |
301 | (sit-for (or minibuffer-message-timeout 1000000))) | |
302 | (delete-overlay ol)))) | |
303 | ||
304 | (defun minibuffer-completion-contents () | |
305 | "Return the user input in a minibuffer before point as a string. | |
306 | That is what completion commands operate on." | |
307 | (buffer-substring (field-beginning) (point))) | |
308 | ||
309 | (defun delete-minibuffer-contents () | |
310 | "Delete all user input in a minibuffer. | |
311 | If the current buffer is not a minibuffer, erase its entire contents." | |
312 | (delete-field)) | |
313 | ||
ba5ff07b SM |
314 | (defcustom completion-auto-help t |
315 | "Non-nil means automatically provide help for invalid completion input. | |
316 | If the value is t the *Completion* buffer is displayed whenever completion | |
317 | is requested but cannot be done. | |
318 | If the value is `lazy', the *Completions* buffer is only displayed after | |
319 | the second failed attempt to complete." | |
e1bb0fe5 | 320 | :type '(choice (const nil) (const t) (const lazy)) |
ba5ff07b SM |
321 | :group 'minibuffer) |
322 | ||
e2947429 | 323 | (defvar completion-styles-alist |
19c04f39 SM |
324 | '((basic completion-basic-try-completion completion-basic-all-completions) |
325 | (emacs22 completion-emacs22-try-completion completion-emacs22-all-completions) | |
326 | (emacs21 completion-emacs21-try-completion completion-emacs21-all-completions) | |
34200787 SM |
327 | (partial-completion |
328 | completion-pcm-try-completion completion-pcm-all-completions)) | |
e2947429 SM |
329 | "List of available completion styles. |
330 | Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS) | |
26c548b0 | 331 | where NAME is the name that should be used in `completion-styles', |
e2947429 SM |
332 | TRY-COMPLETION is the function that does the completion, and |
333 | ALL-COMPLETIONS is the function that lists the completions.") | |
334 | ||
34200787 | 335 | (defcustom completion-styles '(basic partial-completion) |
e2947429 SM |
336 | "List of completion styles to use." |
337 | :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x))) | |
338 | completion-styles-alist))) | |
339 | :group 'minibuffer | |
340 | :version "23.1") | |
341 | ||
19c04f39 SM |
342 | (defun completion-try-completion (string table pred point) |
343 | "Try to complete STRING using completion table TABLE. | |
344 | Only the elements of table that satisfy predicate PRED are considered. | |
345 | POINT is the position of point within STRING. | |
346 | The return value can be either nil to indicate that there is no completion, | |
347 | t to indicate that STRING is the only possible completion, | |
348 | or a pair (STRING . NEWPOINT) of the completed result string together with | |
349 | a new position for point." | |
3911966b SM |
350 | ;; The property `completion-styles' indicates that this functional |
351 | ;; completion-table claims to take care of completion styles itself. | |
352 | ;; [I.e. It will most likely call us back at some point. ] | |
353 | (if (and (symbolp table) (get table 'completion-styles)) | |
19c04f39 SM |
354 | ;; Extended semantics for functional completion-tables: |
355 | ;; They accept a 4th argument `point' and when called with action=nil | |
356 | ;; and this 4th argument (a position inside `string'), they should | |
357 | ;; return instead of a string a pair (STRING . NEWPOINT). | |
358 | (funcall table string pred nil point) | |
e2947429 | 359 | (completion--some (lambda (style) |
2ed430f4 | 360 | (funcall (nth 1 (assq style completion-styles-alist)) |
19c04f39 | 361 | string table pred point)) |
e2947429 SM |
362 | completion-styles))) |
363 | ||
19c04f39 SM |
364 | (defun completion-all-completions (string table pred point) |
365 | "List the possible completions of STRING in completion table TABLE. | |
366 | Only the elements of table that satisfy predicate PRED are considered. | |
367 | POINT is the position of point within STRING. | |
26c548b0 | 368 | The return value is a list of completions and may contain the base-size |
19c04f39 | 369 | in the last `cdr'." |
e2947429 | 370 | (let ((completion-all-completions-with-base-size t)) |
a38313e1 SM |
371 | ;; The property `completion-styles' indicates that this functional |
372 | ;; completion-table claims to take care of completion styles itself. | |
373 | ;; [I.e. It will most likely call us back at some point. ] | |
19c04f39 SM |
374 | (if (and (symbolp table) (get table 'completion-styles)) |
375 | ;; Extended semantics for functional completion-tables: | |
376 | ;; They accept a 4th argument `point' and when called with action=t | |
377 | ;; and this 4th argument (a position inside `string'), they may | |
378 | ;; return BASE-SIZE in the last `cdr'. | |
379 | (funcall table string pred t point) | |
e2947429 | 380 | (completion--some (lambda (style) |
2ed430f4 | 381 | (funcall (nth 2 (assq style completion-styles-alist)) |
19c04f39 | 382 | string table pred point)) |
e2947429 SM |
383 | completion-styles)))) |
384 | ||
ba5ff07b SM |
385 | (defun minibuffer--bitset (modified completions exact) |
386 | (logior (if modified 4 0) | |
387 | (if completions 2 0) | |
388 | (if exact 1 0))) | |
389 | ||
3911966b | 390 | (defun completion--do-completion (&optional try-completion-function) |
32bae13c | 391 | "Do the completion and return a summary of what happened. |
ba5ff07b SM |
392 | M = completion was performed, the text was Modified. |
393 | C = there were available Completions. | |
394 | E = after completion we now have an Exact match. | |
395 | ||
396 | MCE | |
397 | 000 0 no possible completion | |
398 | 001 1 was already an exact and unique completion | |
399 | 010 2 no completion happened | |
400 | 011 3 was already an exact completion | |
401 | 100 4 ??? impossible | |
402 | 101 5 ??? impossible | |
403 | 110 6 some completion happened | |
404 | 111 7 completed to an exact completion" | |
405 | (let* ((beg (field-beginning)) | |
19c04f39 | 406 | (end (field-end)) |
3911966b | 407 | (string (buffer-substring beg end)) |
19c04f39 SM |
408 | (comp (funcall (or try-completion-function |
409 | 'completion-try-completion) | |
410 | string | |
411 | minibuffer-completion-table | |
412 | minibuffer-completion-predicate | |
413 | (- (point) beg)))) | |
32bae13c | 414 | (cond |
19c04f39 | 415 | ((null comp) |
ba5ff07b | 416 | (ding) (minibuffer-message "No match") (minibuffer--bitset nil nil nil)) |
19c04f39 | 417 | ((eq t comp) (minibuffer--bitset nil nil t)) ;Exact and unique match. |
32bae13c SM |
418 | (t |
419 | ;; `completed' should be t if some completion was done, which doesn't | |
420 | ;; include simply changing the case of the entered string. However, | |
421 | ;; for appearance, the string is rewritten if the case changes. | |
19c04f39 SM |
422 | (let* ((comp-pos (cdr comp)) |
423 | (completion (car comp)) | |
424 | (completed (not (eq t (compare-strings completion nil nil | |
425 | string nil nil t)))) | |
3911966b SM |
426 | (unchanged (eq t (compare-strings completion nil nil |
427 | string nil nil nil)))) | |
32bae13c | 428 | (unless unchanged |
ba5ff07b SM |
429 | |
430 | ;; Insert in minibuffer the chars we got. | |
3911966b SM |
431 | (goto-char end) |
432 | (insert completion) | |
81ff9458 SM |
433 | (delete-region beg end)) |
434 | ;; Move point. | |
435 | (goto-char (+ beg comp-pos)) | |
ba5ff07b | 436 | |
32bae13c SM |
437 | (if (not (or unchanged completed)) |
438 | ;; The case of the string changed, but that's all. We're not sure | |
439 | ;; whether this is a unique completion or not, so try again using | |
440 | ;; the real case (this shouldn't recurse again, because the next | |
441 | ;; time try-completion will return either t or the exact string). | |
3911966b | 442 | (completion--do-completion try-completion-function) |
32bae13c SM |
443 | |
444 | ;; It did find a match. Do we match some possibility exactly now? | |
19c04f39 | 445 | (let ((exact (test-completion completion |
32bae13c SM |
446 | minibuffer-completion-table |
447 | minibuffer-completion-predicate))) | |
ba5ff07b SM |
448 | (unless completed |
449 | ;; Show the completion table, if requested. | |
450 | (cond | |
451 | ((not exact) | |
452 | (if (case completion-auto-help | |
453 | (lazy (eq this-command last-command)) | |
454 | (t completion-auto-help)) | |
455 | (minibuffer-completion-help) | |
456 | (minibuffer-message "Next char not unique"))) | |
457 | ;; If the last exact completion and this one were the same, | |
458 | ;; it means we've already given a "Complete but not unique" | |
459 | ;; message and the user's hit TAB again, so now we give him help. | |
460 | ((eq this-command last-command) | |
461 | (if completion-auto-help (minibuffer-completion-help))))) | |
462 | ||
463 | (minibuffer--bitset completed t exact)))))))) | |
32bae13c SM |
464 | |
465 | (defun minibuffer-complete () | |
466 | "Complete the minibuffer contents as far as possible. | |
467 | Return nil if there is no valid completion, else t. | |
468 | If no characters can be completed, display a list of possible completions. | |
469 | If you repeat this command after it displayed such a list, | |
470 | scroll the window of possible completions." | |
471 | (interactive) | |
472 | ;; If the previous command was not this, | |
473 | ;; mark the completion buffer obsolete. | |
474 | (unless (eq this-command last-command) | |
475 | (setq minibuffer-scroll-window nil)) | |
476 | ||
477 | (let ((window minibuffer-scroll-window)) | |
478 | ;; If there's a fresh completion window with a live buffer, | |
479 | ;; and this command is repeated, scroll that window. | |
480 | (if (window-live-p window) | |
481 | (with-current-buffer (window-buffer window) | |
482 | (if (pos-visible-in-window-p (point-max) window) | |
483 | ;; If end is in view, scroll up to the beginning. | |
484 | (set-window-start window (point-min) nil) | |
485 | ;; Else scroll down one screen. | |
486 | (scroll-other-window)) | |
487 | nil) | |
488 | ||
3911966b | 489 | (case (completion--do-completion) |
a38313e1 SM |
490 | (#b000 nil) |
491 | (#b001 (goto-char (field-end)) | |
492 | (minibuffer-message "Sole completion") | |
493 | t) | |
494 | (#b011 (goto-char (field-end)) | |
495 | (minibuffer-message "Complete, but not unique") | |
496 | t) | |
497 | (t t))))) | |
32bae13c | 498 | |
14c24780 SM |
499 | (defvar completion-all-sorted-completions nil) |
500 | (make-variable-buffer-local 'completion-all-sorted-completions) | |
501 | ||
502 | (defun completion--flush-all-sorted-completions (&rest ignore) | |
503 | (setq completion-all-sorted-completions nil)) | |
504 | ||
505 | (defun completion-all-sorted-completions () | |
506 | (or completion-all-sorted-completions | |
507 | (let* ((start (field-beginning)) | |
508 | (end (field-end)) | |
509 | (all (completion-all-completions (buffer-substring start end) | |
510 | minibuffer-completion-table | |
511 | minibuffer-completion-predicate | |
512 | (- (point) start))) | |
513 | (last (last all)) | |
514 | (base-size (or (cdr last) 0))) | |
515 | (when last | |
516 | (setcdr last nil) | |
517 | ;; Prefer shorter completions. | |
518 | (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2))))) | |
519 | ;; Prefer recently used completions. | |
520 | (let ((hist (symbol-value minibuffer-history-variable))) | |
521 | (setq all (sort all (lambda (c1 c2) | |
522 | (> (length (member c1 hist)) | |
523 | (length (member c2 hist))))))) | |
524 | ;; Cache the result. This is not just for speed, but also so that | |
525 | ;; repeated calls to minibuffer-force-complete can cycle through | |
526 | ;; all possibilities. | |
527 | (add-hook 'after-change-functions | |
528 | 'completion--flush-all-sorted-completions nil t) | |
529 | (setq completion-all-sorted-completions | |
530 | (nconc all base-size)))))) | |
531 | ||
532 | (defun minibuffer-force-complete () | |
533 | "Complete the minibuffer to an exact match. | |
534 | Repeated uses step through the possible completions." | |
535 | (interactive) | |
536 | ;; FIXME: Need to deal with the extra-size issue here as well. | |
537 | (let* ((start (field-beginning)) | |
538 | (end (field-end)) | |
539 | (all (completion-all-sorted-completions))) | |
540 | (if (not (consp all)) | |
541 | (minibuffer-message (if all "No more completions" "No completions")) | |
542 | (goto-char end) | |
543 | (insert (car all)) | |
544 | (delete-region (+ start (cdr (last all))) end) | |
545 | ;; If completing file names, (car all) may be a directory, so we'd now | |
546 | ;; have a new set of possible completions and might want to reset | |
547 | ;; completion-all-sorted-completions to nil, but we prefer not to, | |
548 | ;; so that repeated calls minibuffer-force-complete still cycle | |
549 | ;; through the previous possible completions. | |
550 | (setq completion-all-sorted-completions (cdr all))))) | |
551 | ||
32bae13c SM |
552 | (defun minibuffer-complete-and-exit () |
553 | "If the minibuffer contents is a valid completion then exit. | |
554 | Otherwise try to complete it. If completion leads to a valid completion, | |
a38313e1 SM |
555 | a repetition of this command will exit. |
556 | If `minibuffer-completion-confirm' is equal to `confirm', then do not | |
557 | try to complete, but simply ask for confirmation and accept any | |
558 | input if confirmed." | |
32bae13c | 559 | (interactive) |
3911966b SM |
560 | (let ((beg (field-beginning)) |
561 | (end (field-end))) | |
562 | (cond | |
563 | ;; Allow user to specify null string | |
564 | ((= beg end) (exit-minibuffer)) | |
565 | ((test-completion (buffer-substring beg end) | |
566 | minibuffer-completion-table | |
567 | minibuffer-completion-predicate) | |
568 | (when completion-ignore-case | |
569 | ;; Fixup case of the field, if necessary. | |
b0a5a021 | 570 | (let* ((string (buffer-substring beg end)) |
3911966b SM |
571 | (compl (try-completion |
572 | string | |
573 | minibuffer-completion-table | |
574 | minibuffer-completion-predicate))) | |
575 | (when (and (stringp compl) | |
576 | ;; If it weren't for this piece of paranoia, I'd replace | |
577 | ;; the whole thing with a call to do-completion. | |
eee6de73 SM |
578 | ;; This is important, e.g. when the current minibuffer's |
579 | ;; content is a directory which only contains a single | |
580 | ;; file, so `try-completion' actually completes to | |
581 | ;; that file. | |
3911966b | 582 | (= (length string) (length compl))) |
32bae13c SM |
583 | (goto-char end) |
584 | (insert compl) | |
3911966b SM |
585 | (delete-region beg end)))) |
586 | (exit-minibuffer)) | |
32bae13c | 587 | |
3911966b SM |
588 | ((eq minibuffer-completion-confirm 'confirm-only) |
589 | ;; The user is permitted to exit with an input that's rejected | |
590 | ;; by test-completion, but at the condition to confirm her choice. | |
591 | (if (eq last-command this-command) | |
592 | (exit-minibuffer) | |
593 | (minibuffer-message "Confirm") | |
594 | nil)) | |
32bae13c | 595 | |
3911966b SM |
596 | (t |
597 | ;; Call do-completion, but ignore errors. | |
598 | (case (condition-case nil | |
599 | (completion--do-completion) | |
600 | (error 1)) | |
a38313e1 SM |
601 | ((#b001 #b011) (exit-minibuffer)) |
602 | (#b111 (if (not minibuffer-completion-confirm) | |
603 | (exit-minibuffer) | |
604 | (minibuffer-message "Confirm") | |
605 | nil)) | |
3911966b SM |
606 | (t nil)))))) |
607 | ||
19c04f39 SM |
608 | (defun completion--try-word-completion (string table predicate point) |
609 | (let ((comp (completion-try-completion string table predicate point))) | |
610 | (if (not (consp comp)) | |
611 | comp | |
32bae13c | 612 | |
3911966b SM |
613 | ;; If completion finds next char not unique, |
614 | ;; consider adding a space or a hyphen. | |
19c04f39 | 615 | (when (= (length string) (length (car comp))) |
3911966b | 616 | (let ((exts '(" " "-")) |
19c04f39 SM |
617 | (before (substring string 0 point)) |
618 | (after (substring string point)) | |
a38313e1 SM |
619 | ;; If the user hasn't entered any text yet, then she |
620 | ;; presumably hits SPC to see the *completions*, but | |
621 | ;; partial-completion will often find a " " or a "-" to match. | |
622 | ;; So disable partial-completion in that situation. | |
623 | (completion-styles | |
624 | (or (and (equal string "") | |
625 | (remove 'partial-completion completion-styles)) | |
626 | completion-styles)) | |
19c04f39 SM |
627 | tem) |
628 | (while (and exts (not (consp tem))) | |
3911966b | 629 | (setq tem (completion-try-completion |
19c04f39 SM |
630 | (concat before (pop exts) after) |
631 | table predicate (1+ point)))) | |
632 | (if (consp tem) (setq comp tem)))) | |
3911966b | 633 | |
32bae13c SM |
634 | ;; Completing a single word is actually more difficult than completing |
635 | ;; as much as possible, because we first have to find the "current | |
636 | ;; position" in `completion' in order to find the end of the word | |
637 | ;; we're completing. Normally, `string' is a prefix of `completion', | |
638 | ;; which makes it trivial to find the position, but with fancier | |
639 | ;; completion (plus env-var expansion, ...) `completion' might not | |
640 | ;; look anything like `string' at all. | |
19c04f39 SM |
641 | (let* ((comppoint (cdr comp)) |
642 | (completion (car comp)) | |
643 | (before (substring string 0 point)) | |
644 | (combined (concat before "\n" completion))) | |
645 | ;; Find in completion the longest text that was right before point. | |
646 | (when (string-match "\\(.+\\)\n.*?\\1" combined) | |
647 | (let* ((prefix (match-string 1 before)) | |
648 | ;; We used non-greedy match to make `rem' as long as possible. | |
649 | (rem (substring combined (match-end 0))) | |
650 | ;; Find in the remainder of completion the longest text | |
651 | ;; that was right after point. | |
652 | (after (substring string point)) | |
653 | (suffix (if (string-match "\\`\\(.+\\).*\n.*\\1" | |
654 | (concat after "\n" rem)) | |
655 | (match-string 1 after)))) | |
656 | ;; The general idea is to try and guess what text was inserted | |
657 | ;; at point by the completion. Problem is: if we guess wrong, | |
658 | ;; we may end up treating as "added by completion" text that was | |
659 | ;; actually painfully typed by the user. So if we then cut | |
660 | ;; after the first word, we may throw away things the | |
661 | ;; user wrote. So let's try to be as conservative as possible: | |
662 | ;; only cut after the first word, if we're reasonably sure that | |
663 | ;; our guess is correct. | |
664 | ;; Note: a quick survey on emacs-devel seemed to indicate that | |
665 | ;; nobody actually cares about the "word-at-a-time" feature of | |
666 | ;; minibuffer-complete-word, whose real raison-d'être is that it | |
667 | ;; tries to add "-" or " ". One more reason to only cut after | |
668 | ;; the first word, if we're really sure we're right. | |
669 | (when (and (or suffix (zerop (length after))) | |
670 | (string-match (concat | |
671 | ;; Make submatch 1 as small as possible | |
672 | ;; to reduce the risk of cutting | |
673 | ;; valuable text. | |
674 | ".*" (regexp-quote prefix) "\\(.*?\\)" | |
675 | (if suffix (regexp-quote suffix) "\\'")) | |
676 | completion) | |
677 | ;; The new point in `completion' should also be just | |
678 | ;; before the suffix, otherwise something more complex | |
679 | ;; is going on, and we're not sure where we are. | |
680 | (eq (match-end 1) comppoint) | |
681 | ;; (match-beginning 1)..comppoint is now the stretch | |
682 | ;; of text in `completion' that was completed at point. | |
683 | (string-match "\\W" completion (match-beginning 1)) | |
684 | ;; Is there really something to cut? | |
685 | (> comppoint (match-end 0))) | |
686 | ;; Cut after the first word. | |
687 | (let ((cutpos (match-end 0))) | |
688 | (setq completion (concat (substring completion 0 cutpos) | |
689 | (substring completion comppoint))) | |
690 | (setq comppoint cutpos))))) | |
691 | ||
692 | (cons completion comppoint))))) | |
ba5ff07b SM |
693 | |
694 | ||
695 | (defun minibuffer-complete-word () | |
696 | "Complete the minibuffer contents at most a single word. | |
697 | After one word is completed as much as possible, a space or hyphen | |
698 | is added, provided that matches some possible completion. | |
699 | Return nil if there is no valid completion, else t." | |
700 | (interactive) | |
3911966b | 701 | (case (completion--do-completion 'completion--try-word-completion) |
a38313e1 SM |
702 | (#b000 nil) |
703 | (#b001 (goto-char (field-end)) | |
704 | (minibuffer-message "Sole completion") | |
705 | t) | |
706 | (#b011 (goto-char (field-end)) | |
707 | (minibuffer-message "Complete, but not unique") | |
708 | t) | |
709 | (t t))) | |
ba5ff07b | 710 | |
3911966b | 711 | (defun completion--insert-strings (strings) |
32bae13c SM |
712 | "Insert a list of STRINGS into the current buffer. |
713 | Uses columns to keep the listing readable but compact. | |
714 | It also eliminates runs of equal strings." | |
715 | (when (consp strings) | |
716 | (let* ((length (apply 'max | |
717 | (mapcar (lambda (s) | |
718 | (if (consp s) | |
e5b5b82d SM |
719 | (+ (string-width (car s)) |
720 | (string-width (cadr s))) | |
721 | (string-width s))) | |
32bae13c SM |
722 | strings))) |
723 | (window (get-buffer-window (current-buffer) 0)) | |
724 | (wwidth (if window (1- (window-width window)) 79)) | |
725 | (columns (min | |
726 | ;; At least 2 columns; at least 2 spaces between columns. | |
727 | (max 2 (/ wwidth (+ 2 length))) | |
728 | ;; Don't allocate more columns than we can fill. | |
729 | ;; Windows can't show less than 3 lines anyway. | |
730 | (max 1 (/ (length strings) 2)))) | |
731 | (colwidth (/ wwidth columns)) | |
732 | (column 0) | |
733 | (laststring nil)) | |
734 | ;; The insertion should be "sensible" no matter what choices were made | |
735 | ;; for the parameters above. | |
736 | (dolist (str strings) | |
737 | (unless (equal laststring str) ; Remove (consecutive) duplicates. | |
738 | (setq laststring str) | |
739 | (unless (bolp) | |
740 | (insert " \t") | |
741 | (setq column (+ column colwidth)) | |
742 | ;; Leave the space unpropertized so that in the case we're | |
743 | ;; already past the goal column, there is still | |
744 | ;; a space displayed. | |
745 | (set-text-properties (- (point) 1) (point) | |
746 | ;; We can't just set tab-width, because | |
747 | ;; completion-setup-function will kill all | |
748 | ;; local variables :-( | |
5270bf51 AS |
749 | `(display (space :align-to ,column))) |
750 | (when (< wwidth (+ (max colwidth | |
751 | (if (consp str) | |
752 | (+ (string-width (car str)) | |
753 | (string-width (cadr str))) | |
754 | (string-width str))) | |
755 | column)) | |
756 | (delete-char -2) (insert "\n") (setq column 0))) | |
32bae13c SM |
757 | (if (not (consp str)) |
758 | (put-text-property (point) (progn (insert str) (point)) | |
759 | 'mouse-face 'highlight) | |
760 | (put-text-property (point) (progn (insert (car str)) (point)) | |
761 | 'mouse-face 'highlight) | |
762 | (put-text-property (point) (progn (insert (cadr str)) (point)) | |
763 | 'mouse-face nil))))))) | |
764 | ||
6138158d SM |
765 | (defvar completion-common-substring nil) |
766 | (make-obsolete-variable 'completion-common-substring nil "23.1") | |
32bae13c | 767 | |
21622c6d SM |
768 | (defvar completion-setup-hook nil |
769 | "Normal hook run at the end of setting up a completion list buffer. | |
770 | When this hook is run, the current buffer is the one in which the | |
771 | command to display the completion list buffer was run. | |
772 | The completion list buffer is available as the value of `standard-output'. | |
6138158d SM |
773 | See also `display-completion-list'.") |
774 | ||
775 | (defface completions-first-difference | |
776 | '((t (:inherit bold))) | |
777 | "Face put on the first uncommon character in completions in *Completions* buffer." | |
778 | :group 'completion) | |
779 | ||
780 | (defface completions-common-part | |
781 | '((t (:inherit default))) | |
782 | "Face put on the common prefix substring in completions in *Completions* buffer. | |
783 | The idea of `completions-common-part' is that you can use it to | |
784 | make the common parts less visible than normal, so that the rest | |
785 | of the differing parts is, by contrast, slightly highlighted." | |
786 | :group 'completion) | |
787 | ||
788 | (defun completion-hilit-commonality (completions prefix-len) | |
789 | (when completions | |
790 | (let* ((last (last completions)) | |
791 | (base-size (cdr last)) | |
792 | (com-str-len (- prefix-len (or base-size 0)))) | |
793 | ;; Remove base-size during mapcar, and add it back later. | |
794 | (setcdr last nil) | |
795 | (nconc | |
796 | (mapcar | |
457d37ba SM |
797 | (lambda (elem) |
798 | (let ((str | |
799 | ;; Don't modify the string itself, but a copy, since the | |
800 | ;; the string may be read-only or used for other purposes. | |
801 | ;; Furthermore, since `completions' may come from | |
802 | ;; display-completion-list, `elem' may be a list. | |
803 | (if (consp elem) | |
804 | (car (setq elem (cons (copy-sequence (car elem)) | |
805 | (cdr elem)))) | |
806 | (setq elem (copy-sequence elem))))) | |
807 | (put-text-property 0 com-str-len | |
808 | 'font-lock-face 'completions-common-part | |
809 | str) | |
810 | (if (> (length str) com-str-len) | |
811 | (put-text-property com-str-len (1+ com-str-len) | |
812 | 'font-lock-face 'completions-first-difference | |
813 | str))) | |
814 | elem) | |
6138158d SM |
815 | completions) |
816 | base-size)))) | |
21622c6d | 817 | |
32bae13c SM |
818 | (defun display-completion-list (completions &optional common-substring) |
819 | "Display the list of completions, COMPLETIONS, using `standard-output'. | |
820 | Each element may be just a symbol or string | |
821 | or may be a list of two strings to be printed as if concatenated. | |
822 | If it is a list of two strings, the first is the actual completion | |
823 | alternative, the second serves as annotation. | |
824 | `standard-output' must be a buffer. | |
825 | The actual completion alternatives, as inserted, are given `mouse-face' | |
826 | properties of `highlight'. | |
827 | At the end, this runs the normal hook `completion-setup-hook'. | |
828 | It can find the completion buffer in `standard-output'. | |
6138158d | 829 | The obsolete optional second arg COMMON-SUBSTRING is a string. |
32bae13c | 830 | It is used to put faces, `completions-first-difference' and |
b95c7600 | 831 | `completions-common-part' on the completion buffer. The |
32bae13c | 832 | `completions-common-part' face is put on the common substring |
6138158d SM |
833 | specified by COMMON-SUBSTRING." |
834 | (if common-substring | |
835 | (setq completions (completion-hilit-commonality | |
836 | completions (length common-substring)))) | |
32bae13c SM |
837 | (if (not (bufferp standard-output)) |
838 | ;; This *never* (ever) happens, so there's no point trying to be clever. | |
839 | (with-temp-buffer | |
840 | (let ((standard-output (current-buffer)) | |
841 | (completion-setup-hook nil)) | |
842 | (display-completion-list completions)) | |
843 | (princ (buffer-string))) | |
844 | ||
845 | (with-current-buffer standard-output | |
846 | (goto-char (point-max)) | |
847 | (if (null completions) | |
848 | (insert "There are no possible completions of what you have typed.") | |
e1bb0fe5 | 849 | |
32bae13c | 850 | (insert "Possible completions are:\n") |
e2947429 SM |
851 | (let ((last (last completions))) |
852 | ;; Get the base-size from the tail of the list. | |
853 | (set (make-local-variable 'completion-base-size) (or (cdr last) 0)) | |
854 | (setcdr last nil)) ;Make completions a properly nil-terminated list. | |
3911966b | 855 | (completion--insert-strings completions)))) |
e2947429 | 856 | |
6138158d SM |
857 | ;; The hilit used to be applied via completion-setup-hook, so there |
858 | ;; may still be some code that uses completion-common-substring. | |
32bae13c SM |
859 | (let ((completion-common-substring common-substring)) |
860 | (run-hooks 'completion-setup-hook)) | |
861 | nil) | |
862 | ||
863 | (defun minibuffer-completion-help () | |
864 | "Display a list of possible completions of the current minibuffer contents." | |
865 | (interactive) | |
866 | (message "Making completion list...") | |
867 | (let* ((string (field-string)) | |
3911966b | 868 | (completions (completion-all-completions |
32bae13c SM |
869 | string |
870 | minibuffer-completion-table | |
19c04f39 SM |
871 | minibuffer-completion-predicate |
872 | (- (point) (field-beginning))))) | |
32bae13c SM |
873 | (message nil) |
874 | (if (and completions | |
e2947429 SM |
875 | (or (consp (cdr completions)) |
876 | (not (equal (car completions) string)))) | |
32bae13c | 877 | (with-output-to-temp-buffer "*Completions*" |
e2947429 SM |
878 | (let* ((last (last completions)) |
879 | (base-size (cdr last))) | |
880 | ;; Remove the base-size tail because `sort' requires a properly | |
881 | ;; nil-terminated list. | |
882 | (when last (setcdr last nil)) | |
883 | (display-completion-list (nconc (sort completions 'string-lessp) | |
884 | base-size)))) | |
32bae13c SM |
885 | |
886 | ;; If there are no completions, or if the current input is already the | |
887 | ;; only possible completion, then hide (previous&stale) completions. | |
888 | (let ((window (and (get-buffer "*Completions*") | |
889 | (get-buffer-window "*Completions*" 0)))) | |
890 | (when (and (window-live-p window) (window-dedicated-p window)) | |
891 | (condition-case () | |
892 | (delete-window window) | |
893 | (error (iconify-frame (window-frame window)))))) | |
894 | (ding) | |
895 | (minibuffer-message | |
896 | (if completions "Sole completion" "No completions"))) | |
897 | nil)) | |
898 | ||
899 | (defun exit-minibuffer () | |
900 | "Terminate this minibuffer argument." | |
901 | (interactive) | |
902 | ;; If the command that uses this has made modifications in the minibuffer, | |
903 | ;; we don't want them to cause deactivation of the mark in the original | |
904 | ;; buffer. | |
905 | ;; A better solution would be to make deactivate-mark buffer-local | |
906 | ;; (or to turn it into a list of buffers, ...), but in the mean time, | |
907 | ;; this should do the trick in most cases. | |
ba5ff07b | 908 | (setq deactivate-mark nil) |
32bae13c SM |
909 | (throw 'exit nil)) |
910 | ||
911 | (defun self-insert-and-exit () | |
912 | "Terminate minibuffer input." | |
913 | (interactive) | |
914 | (if (characterp last-command-char) | |
915 | (call-interactively 'self-insert-command) | |
916 | (ding)) | |
917 | (exit-minibuffer)) | |
918 | ||
a38313e1 SM |
919 | ;;; Key bindings. |
920 | ||
8ba31f36 SM |
921 | (define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map |
922 | 'minibuffer-local-filename-must-match-map "23.1") | |
923 | ||
a38313e1 SM |
924 | (let ((map minibuffer-local-map)) |
925 | (define-key map "\C-g" 'abort-recursive-edit) | |
926 | (define-key map "\r" 'exit-minibuffer) | |
927 | (define-key map "\n" 'exit-minibuffer)) | |
928 | ||
929 | (let ((map minibuffer-local-completion-map)) | |
930 | (define-key map "\t" 'minibuffer-complete) | |
14c24780 SM |
931 | ;; M-TAB is already abused for many other purposes, so we should find |
932 | ;; another binding for it. | |
933 | ;; (define-key map "\e\t" 'minibuffer-force-complete) | |
a38313e1 SM |
934 | (define-key map " " 'minibuffer-complete-word) |
935 | (define-key map "?" 'minibuffer-completion-help)) | |
936 | ||
937 | (let ((map minibuffer-local-must-match-map)) | |
938 | (define-key map "\r" 'minibuffer-complete-and-exit) | |
939 | (define-key map "\n" 'minibuffer-complete-and-exit)) | |
940 | ||
941 | (let ((map minibuffer-local-filename-completion-map)) | |
942 | (define-key map " " nil)) | |
8ba31f36 | 943 | (let ((map minibuffer-local-filename-must-match-map)) |
a38313e1 SM |
944 | (define-key map " " nil)) |
945 | ||
946 | (let ((map minibuffer-local-ns-map)) | |
947 | (define-key map " " 'exit-minibuffer) | |
948 | (define-key map "\t" 'exit-minibuffer) | |
949 | (define-key map "?" 'self-insert-and-exit)) | |
950 | ||
951 | ;;; Completion tables. | |
952 | ||
34b67b0f SM |
953 | (defun minibuffer--double-dollars (str) |
954 | (replace-regexp-in-string "\\$" "$$" str)) | |
955 | ||
21622c6d SM |
956 | (defun completion--make-envvar-table () |
957 | (mapcar (lambda (enventry) | |
958 | (substring enventry 0 (string-match "=" enventry))) | |
959 | process-environment)) | |
960 | ||
a38313e1 SM |
961 | (defconst completion--embedded-envvar-re |
962 | (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" | |
963 | "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) | |
964 | ||
21622c6d | 965 | (defun completion--embedded-envvar-table (string pred action) |
a38313e1 SM |
966 | (if (eq (car-safe action) 'boundaries) |
967 | ;; Compute the boundaries of the subfield to which this | |
968 | ;; completion applies. | |
f8381803 SM |
969 | (let ((suffix (cdr action))) |
970 | (if (string-match completion--embedded-envvar-re string) | |
971 | (list* 'boundaries | |
972 | (or (match-beginning 2) (match-beginning 1)) | |
a38313e1 | 973 | (when (string-match "[^[:alnum:]_]" suffix) |
f8381803 | 974 | (match-beginning 0))))) |
a38313e1 SM |
975 | (when (string-match completion--embedded-envvar-re string) |
976 | (let* ((beg (or (match-beginning 2) (match-beginning 1))) | |
977 | (table (completion--make-envvar-table)) | |
978 | (prefix (substring string 0 beg))) | |
979 | (if (eq (aref string (1- beg)) ?{) | |
980 | (setq table (apply-partially 'completion-table-with-terminator | |
981 | "}" table))) | |
982 | (completion-table-with-context | |
983 | prefix table (substring string beg) pred action))))) | |
017c22fe | 984 | |
f50e56f0 | 985 | (defun completion--file-name-table (string pred action) |
b95c7600 | 986 | "Internal subroutine for `read-file-name'. Do not call this." |
a38313e1 SM |
987 | (cond |
988 | ((and (zerop (length string)) (eq 'lambda action)) | |
989 | nil) ; FIXME: why? | |
990 | ((eq (car-safe action) 'boundaries) | |
991 | ;; FIXME: Actually, this is not always right in the presence of | |
992 | ;; envvars, but there's not much we can do, I think. | |
f8381803 SM |
993 | (let ((start (length (file-name-directory string))) |
994 | (end (string-match "/" (cdr action)))) | |
a38313e1 | 995 | (list* 'boundaries start end))) |
d9aa6b33 | 996 | |
a38313e1 | 997 | (t |
f50e56f0 SM |
998 | (let* ((dir (if (stringp pred) |
999 | ;; It used to be that `pred' was abused to pass `dir' | |
1000 | ;; as an argument. | |
1001 | (prog1 (expand-file-name pred) (setq pred nil)) | |
1002 | default-directory)) | |
1003 | (str (condition-case nil | |
21622c6d SM |
1004 | (substitute-in-file-name string) |
1005 | (error string))) | |
34b67b0f SM |
1006 | (name (file-name-nondirectory str)) |
1007 | (specdir (file-name-directory str)) | |
1008 | (realdir (if specdir (expand-file-name specdir dir) | |
1009 | (file-name-as-directory dir)))) | |
017c22fe | 1010 | |
34b67b0f SM |
1011 | (cond |
1012 | ((null action) | |
1013 | (let ((comp (file-name-completion name realdir | |
1014 | read-file-name-predicate))) | |
1015 | (if (stringp comp) | |
1016 | ;; Requote the $s before returning the completion. | |
1017 | (minibuffer--double-dollars (concat specdir comp)) | |
1018 | ;; Requote the $s before checking for changes. | |
1019 | (setq str (minibuffer--double-dollars str)) | |
1020 | (if (string-equal string str) | |
1021 | comp | |
1022 | ;; If there's no real completion, but substitute-in-file-name | |
1023 | ;; changed the string, then return the new string. | |
1024 | str)))) | |
017c22fe | 1025 | |
34b67b0f | 1026 | ((eq action t) |
e2947429 | 1027 | (let ((all (file-name-all-completions name realdir)) |
a38313e1 SM |
1028 | ;; FIXME: Actually, this is not always right in the presence |
1029 | ;; of envvars, but there's not much we can do, I think. | |
e2947429 SM |
1030 | (base-size (length (file-name-directory string)))) |
1031 | ||
1032 | ;; Check the predicate, if necessary. | |
1033 | (unless (memq read-file-name-predicate '(nil file-exists-p)) | |
34b67b0f SM |
1034 | (let ((comp ()) |
1035 | (pred | |
1036 | (if (eq read-file-name-predicate 'file-directory-p) | |
1037 | ;; Brute-force speed up for directory checking: | |
1038 | ;; Discard strings which don't end in a slash. | |
1039 | (lambda (s) | |
1040 | (let ((len (length s))) | |
1041 | (and (> len 0) (eq (aref s (1- len)) ?/)))) | |
1042 | ;; Must do it the hard (and slow) way. | |
1043 | read-file-name-predicate))) | |
1044 | (let ((default-directory realdir)) | |
1045 | (dolist (tem all) | |
1046 | (if (funcall pred tem) (push tem comp)))) | |
e2947429 SM |
1047 | (setq all (nreverse comp)))) |
1048 | ||
88893215 SM |
1049 | (if (and completion-all-completions-with-base-size (consp all)) |
1050 | ;; Add base-size, but only if the list is non-empty. | |
a38313e1 SM |
1051 | (nconc all base-size) |
1052 | all))) | |
34b67b0f SM |
1053 | |
1054 | (t | |
1055 | ;; Only other case actually used is ACTION = lambda. | |
1056 | (let ((default-directory dir)) | |
a38313e1 | 1057 | (funcall (or read-file-name-predicate 'file-exists-p) str)))))))) |
34b67b0f | 1058 | |
21622c6d | 1059 | (defalias 'read-file-name-internal |
017c22fe | 1060 | (completion-table-in-turn 'completion--embedded-envvar-table |
88893215 | 1061 | 'completion--file-name-table) |
21622c6d | 1062 | "Internal subroutine for `read-file-name'. Do not call this.") |
34b67b0f | 1063 | |
dbd50d4b SM |
1064 | (defvar read-file-name-function nil |
1065 | "If this is non-nil, `read-file-name' does its work by calling this function.") | |
1066 | ||
1067 | (defvar read-file-name-predicate nil | |
1068 | "Current predicate used by `read-file-name-internal'.") | |
1069 | ||
1070 | (defcustom read-file-name-completion-ignore-case | |
7c2fb837 | 1071 | (if (memq system-type '(ms-dos windows-nt darwin)) |
dbd50d4b SM |
1072 | t nil) |
1073 | "Non-nil means when reading a file name completion ignores case." | |
1074 | :group 'minibuffer | |
1075 | :type 'boolean | |
1076 | :version "22.1") | |
1077 | ||
1078 | (defcustom insert-default-directory t | |
1079 | "Non-nil means when reading a filename start with default dir in minibuffer. | |
1080 | ||
1081 | When the initial minibuffer contents show a name of a file or a directory, | |
1082 | typing RETURN without editing the initial contents is equivalent to typing | |
1083 | the default file name. | |
1084 | ||
1085 | If this variable is non-nil, the minibuffer contents are always | |
1086 | initially non-empty, and typing RETURN without editing will fetch the | |
1087 | default name, if one is provided. Note however that this default name | |
1088 | is not necessarily the same as initial contents inserted in the minibuffer, | |
1089 | if the initial contents is just the default directory. | |
1090 | ||
1091 | If this variable is nil, the minibuffer often starts out empty. In | |
1092 | that case you may have to explicitly fetch the next history element to | |
1093 | request the default name; typing RETURN without editing will leave | |
1094 | the minibuffer empty. | |
1095 | ||
1096 | For some commands, exiting with an empty minibuffer has a special meaning, | |
1097 | such as making the current buffer visit no file in the case of | |
1098 | `set-visited-file-name'." | |
1099 | :group 'minibuffer | |
1100 | :type 'boolean) | |
1101 | ||
4e3870f5 GM |
1102 | ;; Not always defined, but only called if next-read-file-uses-dialog-p says so. |
1103 | (declare-function x-file-dialog "xfns.c" | |
1104 | (prompt dir &optional default-filename mustmatch only-dir-p)) | |
1105 | ||
dbd50d4b SM |
1106 | (defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate) |
1107 | "Read file name, prompting with PROMPT and completing in directory DIR. | |
1108 | Value is not expanded---you must call `expand-file-name' yourself. | |
1109 | Default name to DEFAULT-FILENAME if user exits the minibuffer with | |
1110 | the same non-empty string that was inserted by this function. | |
1111 | (If DEFAULT-FILENAME is omitted, the visited file name is used, | |
1112 | except that if INITIAL is specified, that combined with DIR is used.) | |
1113 | If the user exits with an empty minibuffer, this function returns | |
1114 | an empty string. (This can only happen if the user erased the | |
1115 | pre-inserted contents or if `insert-default-directory' is nil.) | |
1116 | Fourth arg MUSTMATCH non-nil means require existing file's name. | |
1117 | Non-nil and non-t means also require confirmation after completion. | |
1118 | Fifth arg INITIAL specifies text to start with. | |
1119 | If optional sixth arg PREDICATE is non-nil, possible completions and | |
1120 | the resulting file name must satisfy (funcall PREDICATE NAME). | |
1121 | DIR should be an absolute directory name. It defaults to the value of | |
1122 | `default-directory'. | |
1123 | ||
1124 | If this command was invoked with the mouse, use a file dialog box if | |
1125 | `use-dialog-box' is non-nil, and the window system or X toolkit in use | |
1126 | provides a file dialog box. | |
1127 | ||
1128 | See also `read-file-name-completion-ignore-case' | |
1129 | and `read-file-name-function'." | |
1130 | (unless dir (setq dir default-directory)) | |
1131 | (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir))) | |
1132 | (unless default-filename | |
1133 | (setq default-filename (if initial (expand-file-name initial dir) | |
1134 | buffer-file-name))) | |
1135 | ;; If dir starts with user's homedir, change that to ~. | |
1136 | (setq dir (abbreviate-file-name dir)) | |
1137 | ;; Likewise for default-filename. | |
e8a5fe3e SM |
1138 | (if default-filename |
1139 | (setq default-filename (abbreviate-file-name default-filename))) | |
dbd50d4b SM |
1140 | (let ((insdef (cond |
1141 | ((and insert-default-directory (stringp dir)) | |
1142 | (if initial | |
1143 | (cons (minibuffer--double-dollars (concat dir initial)) | |
1144 | (length (minibuffer--double-dollars dir))) | |
1145 | (minibuffer--double-dollars dir))) | |
1146 | (initial (cons (minibuffer--double-dollars initial) 0))))) | |
1147 | ||
1148 | (if read-file-name-function | |
1149 | (funcall read-file-name-function | |
1150 | prompt dir default-filename mustmatch initial predicate) | |
e8a5fe3e | 1151 | (let ((completion-ignore-case read-file-name-completion-ignore-case) |
dbd50d4b SM |
1152 | (minibuffer-completing-file-name t) |
1153 | (read-file-name-predicate (or predicate 'file-exists-p)) | |
1154 | (add-to-history nil)) | |
1155 | ||
1156 | (let* ((val | |
1157 | (if (not (next-read-file-uses-dialog-p)) | |
e8a5fe3e SM |
1158 | ;; We used to pass `dir' to `read-file-name-internal' by |
1159 | ;; abusing the `predicate' argument. It's better to | |
1160 | ;; just use `default-directory', but in order to avoid | |
1161 | ;; changing `default-directory' in the current buffer, | |
1162 | ;; we don't let-bind it. | |
1163 | (lexical-let ((dir (file-name-as-directory | |
1164 | (expand-file-name dir)))) | |
1165 | (minibuffer-with-setup-hook | |
1166 | (lambda () (setq default-directory dir)) | |
1167 | (completing-read prompt 'read-file-name-internal | |
1168 | nil mustmatch insdef 'file-name-history | |
1169 | default-filename))) | |
dbd50d4b SM |
1170 | ;; If DIR contains a file name, split it. |
1171 | (let ((file (file-name-nondirectory dir))) | |
1172 | (when (and default-filename (not (zerop (length file)))) | |
1173 | (setq default-filename file) | |
1174 | (setq dir (file-name-directory dir))) | |
1175 | (if default-filename | |
1176 | (setq default-filename | |
1177 | (expand-file-name default-filename dir))) | |
1178 | (setq add-to-history t) | |
1179 | (x-file-dialog prompt dir default-filename mustmatch | |
1180 | (eq predicate 'file-directory-p))))) | |
1181 | ||
1182 | (replace-in-history (eq (car-safe file-name-history) val))) | |
1183 | ;; If completing-read returned the inserted default string itself | |
1184 | ;; (rather than a new string with the same contents), | |
1185 | ;; it has to mean that the user typed RET with the minibuffer empty. | |
1186 | ;; In that case, we really want to return "" | |
1187 | ;; so that commands such as set-visited-file-name can distinguish. | |
1188 | (when (eq val default-filename) | |
1189 | ;; In this case, completing-read has not added an element | |
1190 | ;; to the history. Maybe we should. | |
1191 | (if (not replace-in-history) | |
1192 | (setq add-to-history t)) | |
1193 | (setq val "")) | |
1194 | (unless val (error "No file name specified")) | |
1195 | ||
1196 | (if (and default-filename | |
1197 | (string-equal val (if (consp insdef) (car insdef) insdef))) | |
1198 | (setq val default-filename)) | |
1199 | (setq val (substitute-in-file-name val)) | |
1200 | ||
1201 | (if replace-in-history | |
1202 | ;; Replace what Fcompleting_read added to the history | |
1203 | ;; with what we will actually return. | |
1204 | (let ((val1 (minibuffer--double-dollars val))) | |
1205 | (if history-delete-duplicates | |
1206 | (setcdr file-name-history | |
1207 | (delete val1 (cdr file-name-history)))) | |
1208 | (setcar file-name-history val1)) | |
1209 | (if add-to-history | |
1210 | ;; Add the value to the history--but not if it matches | |
1211 | ;; the last value already there. | |
1212 | (let ((val1 (minibuffer--double-dollars val))) | |
1213 | (unless (and (consp file-name-history) | |
1214 | (equal (car file-name-history) val1)) | |
1215 | (setq file-name-history | |
1216 | (cons val1 | |
1217 | (if history-delete-duplicates | |
1218 | (delete val1 file-name-history) | |
1219 | file-name-history))))))) | |
1220 | val))))) | |
1221 | ||
8b04c0ae JL |
1222 | (defun internal-complete-buffer-except (&optional buffer) |
1223 | "Perform completion on all buffers excluding BUFFER. | |
1224 | Like `internal-complete-buffer', but removes BUFFER from the completion list." | |
1225 | (lexical-let ((except (if (stringp buffer) buffer (buffer-name buffer)))) | |
1226 | (apply-partially 'completion-table-with-predicate | |
1227 | 'internal-complete-buffer | |
1228 | (lambda (name) | |
1229 | (not (equal (if (consp name) (car name) name) except))) | |
1230 | nil))) | |
1231 | ||
eee6de73 | 1232 | ;;; Old-style completion, used in Emacs-21 and Emacs-22. |
19c04f39 SM |
1233 | |
1234 | (defun completion-emacs21-try-completion (string table pred point) | |
1235 | (let ((completion (try-completion string table pred))) | |
1236 | (if (stringp completion) | |
1237 | (cons completion (length completion)) | |
1238 | completion))) | |
1239 | ||
1240 | (defun completion-emacs21-all-completions (string table pred point) | |
6138158d | 1241 | (completion-hilit-commonality |
eee6de73 | 1242 | (all-completions string table pred) |
6138158d | 1243 | (length string))) |
19c04f39 | 1244 | |
19c04f39 SM |
1245 | (defun completion-emacs22-try-completion (string table pred point) |
1246 | (let ((suffix (substring string point)) | |
1247 | (completion (try-completion (substring string 0 point) table pred))) | |
1248 | (if (not (stringp completion)) | |
1249 | completion | |
1250 | ;; Merge a trailing / in completion with a / after point. | |
1251 | ;; We used to only do it for word completion, but it seems to make | |
1252 | ;; sense for all completions. | |
34200787 SM |
1253 | ;; Actually, claiming this feature was part of Emacs-22 completion |
1254 | ;; is pushing it a bit: it was only done in minibuffer-completion-word, | |
1255 | ;; which was (by default) not bound during file completion, where such | |
1256 | ;; slashes are most likely to occur. | |
1257 | (if (and (not (zerop (length completion))) | |
1258 | (eq ?/ (aref completion (1- (length completion)))) | |
19c04f39 SM |
1259 | (not (zerop (length suffix))) |
1260 | (eq ?/ (aref suffix 0))) | |
34200787 SM |
1261 | ;; This leaves point after the / . |
1262 | (setq suffix (substring suffix 1))) | |
19c04f39 SM |
1263 | (cons (concat completion suffix) (length completion))))) |
1264 | ||
1265 | (defun completion-emacs22-all-completions (string table pred point) | |
6138158d | 1266 | (completion-hilit-commonality |
eee6de73 | 1267 | (all-completions (substring string 0 point) table pred) |
6138158d | 1268 | point)) |
19c04f39 | 1269 | |
eee6de73 SM |
1270 | ;;; Basic completion. |
1271 | ||
1272 | (defun completion--merge-suffix (completion point suffix) | |
1273 | "Merge end of COMPLETION with beginning of SUFFIX. | |
1274 | Simple generalization of the \"merge trailing /\" done in Emacs-22. | |
1275 | Return the new suffix." | |
1276 | (if (and (not (zerop (length suffix))) | |
1277 | (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix) | |
1278 | ;; Make sure we don't compress things to less | |
1279 | ;; than we started with. | |
1280 | point) | |
1281 | ;; Just make sure we didn't match some other \n. | |
1282 | (eq (match-end 1) (length completion))) | |
1283 | (substring suffix (- (match-end 1) (match-beginning 1))) | |
1284 | ;; Nothing to merge. | |
1285 | suffix)) | |
1286 | ||
34200787 | 1287 | (defun completion-basic-try-completion (string table pred point) |
eee6de73 SM |
1288 | (let* ((beforepoint (substring string 0 point)) |
1289 | (afterpoint (substring string point)) | |
86011bf2 SM |
1290 | (bounds (completion-boundaries beforepoint table pred afterpoint))) |
1291 | (if (zerop (cdr bounds)) | |
1292 | ;; `try-completion' may return a subtly different result | |
1293 | ;; than `all+merge', so try to use it whenever possible. | |
1294 | (let ((completion (try-completion beforepoint table pred))) | |
1295 | (if (not (stringp completion)) | |
1296 | completion | |
1297 | (cons | |
1298 | (concat completion | |
1299 | (completion--merge-suffix completion point afterpoint)) | |
1300 | (length completion)))) | |
1301 | (let* ((suffix (substring afterpoint (cdr bounds))) | |
1302 | (prefix (substring beforepoint 0 (car bounds))) | |
1303 | (pattern (delete | |
1304 | "" (list (substring beforepoint (car bounds)) | |
1305 | 'point | |
1306 | (substring afterpoint 0 (cdr bounds))))) | |
1307 | (all (completion-pcm--all-completions prefix pattern table pred))) | |
1308 | (if minibuffer-completing-file-name | |
1309 | (setq all (completion-pcm--filename-try-filter all))) | |
1310 | (completion-pcm--merge-try pattern all prefix suffix))))) | |
1311 | ||
1312 | (defun completion-basic-all-completions (string table pred point) | |
1313 | (let* ((beforepoint (substring string 0 point)) | |
1314 | (afterpoint (substring string point)) | |
1315 | (bounds (completion-boundaries beforepoint table pred afterpoint)) | |
1316 | (suffix (substring afterpoint (cdr bounds))) | |
1317 | (prefix (substring beforepoint 0 (car bounds))) | |
1318 | (pattern (delete | |
1319 | "" (list (substring beforepoint (car bounds)) | |
1320 | 'point | |
1321 | (substring afterpoint 0 (cdr bounds))))) | |
1322 | (all (completion-pcm--all-completions prefix pattern table pred))) | |
1323 | (completion-hilit-commonality | |
1324 | (if (consp all) (nconc all (car bounds)) all) | |
1325 | point))) | |
19c04f39 | 1326 | |
34200787 SM |
1327 | ;;; Partial-completion-mode style completion. |
1328 | ||
34200787 SM |
1329 | (defvar completion-pcm--delim-wild-regex nil) |
1330 | ||
1331 | (defun completion-pcm--prepare-delim-re (delims) | |
1332 | (setq completion-pcm--delim-wild-regex (concat "[" delims "*]"))) | |
1333 | ||
1334 | (defcustom completion-pcm-word-delimiters "-_. " | |
1335 | "A string of characters treated as word delimiters for completion. | |
1336 | Some arcane rules: | |
1337 | If `]' is in this string, it must come first. | |
1338 | If `^' is in this string, it must not come first. | |
1339 | If `-' is in this string, it must come first or right after `]'. | |
1340 | In other words, if S is this string, then `[S]' must be a valid Emacs regular | |
1341 | expression (not containing character ranges like `a-z')." | |
1342 | :set (lambda (symbol value) | |
1343 | (set-default symbol value) | |
1344 | ;; Refresh other vars. | |
1345 | (completion-pcm--prepare-delim-re value)) | |
1346 | :initialize 'custom-initialize-reset | |
26c548b0 | 1347 | :group 'minibuffer |
34200787 SM |
1348 | :type 'string) |
1349 | ||
1350 | (defun completion-pcm--pattern-trivial-p (pattern) | |
1351 | (and (stringp (car pattern)) (null (cdr pattern)))) | |
1352 | ||
a38313e1 SM |
1353 | (defun completion-pcm--string->pattern (string &optional point) |
1354 | "Split STRING into a pattern. | |
34200787 SM |
1355 | A pattern is a list where each element is either a string |
1356 | or a symbol chosen among `any', `star', `point'." | |
a38313e1 SM |
1357 | (if (and point (< point (length string))) |
1358 | (let ((prefix (substring string 0 point)) | |
1359 | (suffix (substring string point))) | |
34200787 SM |
1360 | (append (completion-pcm--string->pattern prefix) |
1361 | '(point) | |
1362 | (completion-pcm--string->pattern suffix))) | |
1363 | (let ((pattern nil) | |
1364 | (p 0) | |
1365 | (p0 0)) | |
26c548b0 | 1366 | |
a38313e1 SM |
1367 | (while (setq p (string-match completion-pcm--delim-wild-regex string p)) |
1368 | (push (substring string p0 p) pattern) | |
1369 | (if (eq (aref string p) ?*) | |
34200787 SM |
1370 | (progn |
1371 | (push 'star pattern) | |
1372 | (setq p0 (1+ p))) | |
1373 | (push 'any pattern) | |
1374 | (setq p0 p)) | |
1375 | (incf p)) | |
1376 | ||
1377 | ;; An empty string might be erroneously added at the beginning. | |
1378 | ;; It should be avoided properly, but it's so easy to remove it here. | |
a38313e1 | 1379 | (delete "" (nreverse (cons (substring string p0) pattern)))))) |
34200787 SM |
1380 | |
1381 | (defun completion-pcm--pattern->regex (pattern &optional group) | |
a38313e1 | 1382 | (let ((re |
34200787 SM |
1383 | (concat "\\`" |
1384 | (mapconcat | |
1385 | (lambda (x) | |
1386 | (case x | |
a38313e1 SM |
1387 | ((star any point) |
1388 | (if (if (consp group) (memq x group) group) | |
7372b09c | 1389 | "\\(.*?\\)" ".*?")) |
34200787 SM |
1390 | (t (regexp-quote x)))) |
1391 | pattern | |
a38313e1 SM |
1392 | "")))) |
1393 | ;; Avoid pathological backtracking. | |
1394 | (while (string-match "\\.\\*\\?\\(?:\\\\[()]\\)*\\(\\.\\*\\?\\)" re) | |
1395 | (setq re (replace-match "" t t re 1))) | |
1396 | re)) | |
34200787 | 1397 | |
a38313e1 | 1398 | (defun completion-pcm--all-completions (prefix pattern table pred) |
34200787 | 1399 | "Find all completions for PATTERN in TABLE obeying PRED. |
26c548b0 | 1400 | PATTERN is as returned by `completion-pcm--string->pattern'." |
34200787 SM |
1401 | ;; Find an initial list of possible completions. |
1402 | (if (completion-pcm--pattern-trivial-p pattern) | |
1403 | ||
1404 | ;; Minibuffer contains no delimiters -- simple case! | |
a38313e1 SM |
1405 | (let* ((all (all-completions (concat prefix (car pattern)) table pred)) |
1406 | (last (last all))) | |
1407 | (if last (setcdr last nil)) | |
1408 | all) | |
26c548b0 | 1409 | |
34200787 SM |
1410 | ;; Use all-completions to do an initial cull. This is a big win, |
1411 | ;; since all-completions is written in C! | |
1412 | (let* (;; Convert search pattern to a standard regular expression. | |
1413 | (regex (completion-pcm--pattern->regex pattern)) | |
1414 | (completion-regexp-list (cons regex completion-regexp-list)) | |
1415 | (compl (all-completions | |
a38313e1 | 1416 | (concat prefix (if (stringp (car pattern)) (car pattern) "")) |
34200787 SM |
1417 | table pred)) |
1418 | (last (last compl))) | |
a38313e1 SM |
1419 | (when last |
1420 | (if (and (numberp (cdr last)) (/= (cdr last) (length prefix))) | |
1421 | (message "Inconsistent base-size returned by completion table %s" | |
1422 | table)) | |
1423 | (setcdr last nil)) | |
34200787 SM |
1424 | (if (not (functionp table)) |
1425 | ;; The internal functions already obeyed completion-regexp-list. | |
1426 | compl | |
1427 | (let ((case-fold-search completion-ignore-case) | |
1428 | (poss ())) | |
1429 | (dolist (c compl) | |
1430 | (when (string-match regex c) (push c poss))) | |
1431 | poss))))) | |
1432 | ||
7372b09c SM |
1433 | (defun completion-pcm--hilit-commonality (pattern completions) |
1434 | (when completions | |
1435 | (let* ((re (completion-pcm--pattern->regex pattern '(point))) | |
1436 | (last (last completions)) | |
1437 | (base-size (cdr last))) | |
1438 | ;; Remove base-size during mapcar, and add it back later. | |
1439 | (setcdr last nil) | |
1440 | (nconc | |
1441 | (mapcar | |
1442 | (lambda (str) | |
1443 | ;; Don't modify the string itself. | |
1444 | (setq str (copy-sequence str)) | |
1445 | (unless (string-match re str) | |
1446 | (error "Internal error: %s does not match %s" re str)) | |
1447 | (let ((pos (or (match-beginning 1) (match-end 0)))) | |
1448 | (put-text-property 0 pos | |
1449 | 'font-lock-face 'completions-common-part | |
1450 | str) | |
1451 | (if (> (length str) pos) | |
1452 | (put-text-property pos (1+ pos) | |
1453 | 'font-lock-face 'completions-first-difference | |
1454 | str))) | |
1455 | str) | |
1456 | completions) | |
1457 | base-size)))) | |
1458 | ||
eee6de73 SM |
1459 | (defun completion-pcm--find-all-completions (string table pred point |
1460 | &optional filter) | |
1461 | "Find all completions for STRING at POINT in TABLE, satisfying PRED. | |
1462 | POINT is a position inside STRING. | |
1463 | FILTER is a function applied to the return value, that can be used, e.g. to | |
1464 | filter out additional entries (because TABLE migth not obey PRED)." | |
1465 | (unless filter (setq filter 'identity)) | |
f8381803 SM |
1466 | (let* ((beforepoint (substring string 0 point)) |
1467 | (afterpoint (substring string point)) | |
1468 | (bounds (completion-boundaries beforepoint table pred afterpoint)) | |
1469 | (prefix (substring beforepoint 0 (car bounds))) | |
1470 | (suffix (substring afterpoint (cdr bounds))) | |
a38313e1 | 1471 | firsterror) |
f8381803 SM |
1472 | (setq string (substring string (car bounds) (+ point (cdr bounds)))) |
1473 | (let* ((relpoint (- point (car bounds))) | |
1474 | (pattern (completion-pcm--string->pattern string relpoint)) | |
a38313e1 | 1475 | (all (condition-case err |
eee6de73 SM |
1476 | (funcall filter |
1477 | (completion-pcm--all-completions | |
1478 | prefix pattern table pred)) | |
a38313e1 SM |
1479 | (error (unless firsterror (setq firsterror err)) nil)))) |
1480 | (when (and (null all) | |
1481 | (> (car bounds) 0) | |
1482 | (null (ignore-errors (try-completion prefix table pred)))) | |
1483 | ;; The prefix has no completions at all, so we should try and fix | |
1484 | ;; that first. | |
1485 | (let ((substring (substring prefix 0 -1))) | |
1486 | (destructuring-bind (subpat suball subprefix subsuffix) | |
1487 | (completion-pcm--find-all-completions | |
eee6de73 | 1488 | substring table pred (length substring) filter) |
a38313e1 SM |
1489 | (let ((sep (aref prefix (1- (length prefix)))) |
1490 | ;; Text that goes between the new submatches and the | |
1491 | ;; completion substring. | |
1492 | (between nil)) | |
1493 | ;; Eliminate submatches that don't end with the separator. | |
1494 | (dolist (submatch (prog1 suball (setq suball ()))) | |
1495 | (when (eq sep (aref submatch (1- (length submatch)))) | |
1496 | (push submatch suball))) | |
1497 | (when suball | |
1498 | ;; Update the boundaries and corresponding pattern. | |
1499 | ;; We assume that all submatches result in the same boundaries | |
1500 | ;; since we wouldn't know how to merge them otherwise anyway. | |
f8381803 SM |
1501 | ;; FIXME: COMPLETE REWRITE!!! |
1502 | (let* ((newbeforepoint | |
1503 | (concat subprefix (car suball) | |
1504 | (substring string 0 relpoint))) | |
1505 | (leftbound (+ (length subprefix) (length (car suball)))) | |
a38313e1 | 1506 | (newbounds (completion-boundaries |
f8381803 SM |
1507 | newbeforepoint table pred afterpoint))) |
1508 | (unless (or (and (eq (cdr bounds) (cdr newbounds)) | |
1509 | (eq (car newbounds) leftbound)) | |
a38313e1 SM |
1510 | ;; Refuse new boundaries if they step over |
1511 | ;; the submatch. | |
f8381803 | 1512 | (< (car newbounds) leftbound)) |
a38313e1 SM |
1513 | ;; The new completed prefix does change the boundaries |
1514 | ;; of the completed substring. | |
f8381803 SM |
1515 | (setq suffix (substring afterpoint (cdr newbounds))) |
1516 | (setq string | |
1517 | (concat (substring newbeforepoint (car newbounds)) | |
1518 | (substring afterpoint 0 (cdr newbounds)))) | |
1519 | (setq between (substring newbeforepoint leftbound | |
a38313e1 SM |
1520 | (car newbounds))) |
1521 | (setq pattern (completion-pcm--string->pattern | |
f8381803 SM |
1522 | string |
1523 | (- (length newbeforepoint) | |
1524 | (car newbounds))))) | |
a38313e1 SM |
1525 | (dolist (submatch suball) |
1526 | (setq all (nconc (mapcar | |
1527 | (lambda (s) (concat submatch between s)) | |
eee6de73 SM |
1528 | (funcall filter |
1529 | (completion-pcm--all-completions | |
1530 | (concat subprefix submatch between) | |
1531 | pattern table pred))) | |
a38313e1 | 1532 | all))) |
c63028e1 SM |
1533 | ;; FIXME: This can come in handy for try-completion, |
1534 | ;; but isn't right for all-completions, since it lists | |
1535 | ;; invalid completions. | |
1536 | ;; (unless all | |
1537 | ;; ;; Even though we found expansions in the prefix, none | |
1538 | ;; ;; leads to a valid completion. | |
1539 | ;; ;; Let's keep the expansions, tho. | |
1540 | ;; (dolist (submatch suball) | |
1541 | ;; (push (concat submatch between newsubstring) all))) | |
1542 | )) | |
a38313e1 SM |
1543 | (setq pattern (append subpat (list 'any (string sep)) |
1544 | (if between (list between)) pattern)) | |
1545 | (setq prefix subprefix))))) | |
1546 | (if (and (null all) firsterror) | |
1547 | (signal (car firsterror) (cdr firsterror)) | |
1548 | (list pattern all prefix suffix))))) | |
1549 | ||
34200787 | 1550 | (defun completion-pcm-all-completions (string table pred point) |
a38313e1 SM |
1551 | (destructuring-bind (pattern all &optional prefix suffix) |
1552 | (completion-pcm--find-all-completions string table pred point) | |
d4e88786 SM |
1553 | (when all |
1554 | (nconc (completion-pcm--hilit-commonality pattern all) | |
1555 | (length prefix))))) | |
34200787 SM |
1556 | |
1557 | (defun completion-pcm--merge-completions (strs pattern) | |
1558 | "Extract the commonality in STRS, with the help of PATTERN." | |
1559 | (cond | |
1560 | ((null (cdr strs)) (list (car strs))) | |
1561 | (t | |
1562 | (let ((re (completion-pcm--pattern->regex pattern 'group)) | |
1563 | (ccs ())) ;Chopped completions. | |
1564 | ||
1565 | ;; First chop each string into the parts corresponding to each | |
1566 | ;; non-constant element of `pattern', using regexp-matching. | |
1567 | (let ((case-fold-search completion-ignore-case)) | |
1568 | (dolist (str strs) | |
1569 | (unless (string-match re str) | |
1570 | (error "Internal error: %s doesn't match %s" str re)) | |
1571 | (let ((chopped ()) | |
1572 | (i 1)) | |
1573 | (while (match-beginning i) | |
1574 | (push (match-string i str) chopped) | |
1575 | (setq i (1+ i))) | |
1576 | ;; Add the text corresponding to the implicit trailing `any'. | |
1577 | (push (substring str (match-end 0)) chopped) | |
1578 | (push (nreverse chopped) ccs)))) | |
1579 | ||
1580 | ;; Then for each of those non-constant elements, extract the | |
1581 | ;; commonality between them. | |
1582 | (let ((res ())) | |
1583 | ;; Make the implicit `any' explicit. We could make it explicit | |
1584 | ;; everywhere, but it would slow down regexp-matching a little bit. | |
1585 | (dolist (elem (append pattern '(any))) | |
1586 | (if (stringp elem) | |
1587 | (push elem res) | |
1588 | (let ((comps ())) | |
1589 | (dolist (cc (prog1 ccs (setq ccs nil))) | |
1590 | (push (car cc) comps) | |
1591 | (push (cdr cc) ccs)) | |
1592 | (let* ((prefix (try-completion "" comps)) | |
1593 | (unique (or (and (eq prefix t) (setq prefix "")) | |
1594 | (eq t (try-completion prefix comps))))) | |
1595 | (unless (equal prefix "") (push prefix res)) | |
1596 | ;; If there's only one completion, `elem' is not useful | |
1597 | ;; any more: it can only match the empty string. | |
1598 | ;; FIXME: in some cases, it may be necessary to turn an | |
1599 | ;; `any' into a `star' because the surrounding context has | |
1600 | ;; changed such that string->pattern wouldn't add an `any' | |
1601 | ;; here any more. | |
1602 | (unless unique (push elem res)))))) | |
1603 | ;; We return it in reverse order. | |
1604 | res))))) | |
1605 | ||
1606 | (defun completion-pcm--pattern->string (pattern) | |
1607 | (mapconcat (lambda (x) (cond | |
1608 | ((stringp x) x) | |
1609 | ((eq x 'star) "*") | |
1610 | ((eq x 'any) "") | |
1611 | ((eq x 'point) ""))) | |
1612 | pattern | |
1613 | "")) | |
1614 | ||
eee6de73 SM |
1615 | ;; We want to provide the functionality of `try', but we use `all' |
1616 | ;; and then merge it. In most cases, this works perfectly, but | |
1617 | ;; if the completion table doesn't consider the same completions in | |
1618 | ;; `try' as in `all', then we have a problem. The most common such | |
1619 | ;; case is for filename completion where completion-ignored-extensions | |
1620 | ;; is only obeyed by the `try' code. We paper over the difference | |
1621 | ;; here. Note that it is not quite right either: if the completion | |
1622 | ;; table uses completion-table-in-turn, this filtering may take place | |
1623 | ;; too late to correctly fallback from the first to the | |
1624 | ;; second alternative. | |
1625 | (defun completion-pcm--filename-try-filter (all) | |
1626 | "Filter to adjust `all' file completion to the behavior of `try'." | |
34200787 | 1627 | (when all |
eee6de73 SM |
1628 | (let ((try ()) |
1629 | (re (concat "\\(?:\\`\\.\\.?/\\|" | |
1630 | (regexp-opt completion-ignored-extensions) | |
1631 | "\\)\\'"))) | |
1632 | (dolist (f all) | |
1633 | (unless (string-match re f) (push f try))) | |
1634 | (or try all)))) | |
1635 | ||
1636 | ||
1637 | (defun completion-pcm--merge-try (pattern all prefix suffix) | |
1638 | (cond | |
1639 | ((not (consp all)) all) | |
1640 | ((and (not (consp (cdr all))) ;Only one completion. | |
1641 | ;; Ignore completion-ignore-case here. | |
1642 | (equal (completion-pcm--pattern->string pattern) (car all))) | |
1643 | t) | |
1644 | (t | |
34200787 | 1645 | (let* ((mergedpat (completion-pcm--merge-completions all pattern)) |
81ff9458 SM |
1646 | ;; `mergedpat' is in reverse order. Place new point (by |
1647 | ;; order of preference) either at the old point, or at | |
1648 | ;; the last place where there's something to choose, or | |
1649 | ;; at the very end. | |
1650 | (pointpat (or (memq 'point mergedpat) (memq 'any mergedpat) | |
b00942d0 | 1651 | mergedpat)) |
81ff9458 | 1652 | ;; New pos from the start. |
34200787 | 1653 | (newpos (length (completion-pcm--pattern->string pointpat))) |
81ff9458 | 1654 | ;; Do it afterwards because it changes `pointpat' by sideeffect. |
34200787 | 1655 | (merged (completion-pcm--pattern->string (nreverse mergedpat)))) |
eee6de73 SM |
1656 | |
1657 | (setq suffix (completion--merge-suffix merged newpos suffix)) | |
a38313e1 | 1658 | (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) |
34200787 | 1659 | |
eee6de73 SM |
1660 | (defun completion-pcm-try-completion (string table pred point) |
1661 | (destructuring-bind (pattern all prefix suffix) | |
1662 | (completion-pcm--find-all-completions | |
1663 | string table pred point | |
1664 | (if minibuffer-completing-file-name | |
1665 | 'completion-pcm--filename-try-filter)) | |
1666 | (completion-pcm--merge-try pattern all prefix suffix))) | |
1667 | ||
34200787 | 1668 | |
32bae13c | 1669 | (provide 'minibuffer) |
dc6ee347 MB |
1670 | |
1671 | ;; arch-tag: ef8a0a15-1080-4790-a754-04017c02f08f | |
32bae13c | 1672 | ;;; minibuffer.el ends here |