Commit | Line | Data |
---|---|---|
a647cb26 | 1 | ;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*- |
32bae13c | 2 | |
73b0cd50 | 3 | ;; Copyright (C) 2008-2011 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: | |
a38313e1 | 29 | ;; - The `action' can be (additionally to nil, t, and lambda) of the form |
f8381803 SM |
30 | ;; (boundaries . SUFFIX) in which case it should return |
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). | |
a38313e1 SM |
34 | |
35 | ;;; Bugs: | |
36 | ||
eee6de73 SM |
37 | ;; - completion-all-sorted-completions list all the completions, whereas |
38 | ;; it should only lists the ones that `try-completion' would consider. | |
39 | ;; E.g. it should honor completion-ignored-extensions. | |
a38313e1 | 40 | ;; - choose-completion can't automatically figure out the boundaries |
528c56e2 SM |
41 | ;; corresponding to the displayed completions because we only |
42 | ;; provide the start info but not the end info in | |
43 | ;; completion-base-position. | |
4fcc3d32 | 44 | ;; - quoting is problematic. E.g. the double-dollar quoting used in |
9bdba5f5 | 45 | ;; substitute-in-file-name (and hence read-file-name-internal) bumps |
4fcc3d32 | 46 | ;; into various bugs: |
528c56e2 SM |
47 | ;; - choose-completion doesn't know how to quote the text it inserts. |
48 | ;; E.g. it fails to double the dollars in file-name completion, or | |
49 | ;; to backslash-escape spaces and other chars in comint completion. | |
4fcc3d32 SM |
50 | ;; - when completing ~/tmp/fo$$o, the highligting in *Completions* |
51 | ;; is off by one position. | |
52 | ;; - all code like PCM which relies on all-completions to match | |
53 | ;; its argument gets confused because all-completions returns unquoted | |
54 | ;; texts (as desired for *Completions* output). | |
528c56e2 SM |
55 | ;; - C-x C-f ~/*/sr ? should not list "~/./src". |
56 | ;; - minibuffer-force-complete completes ~/src/emacs/t<!>/lisp/minibuffer.el | |
57 | ;; to ~/src/emacs/trunk/ and throws away lisp/minibuffer.el. | |
ba5ff07b | 58 | |
3911966b SM |
59 | ;;; Todo: |
60 | ||
365b9a62 SM |
61 | ;; - extend `boundaries' to provide various other meta-data about the |
62 | ;; output of `all-completions': | |
c53b9c3b SM |
63 | ;; - preferred sorting order when displayed in *Completions*. |
64 | ;; - annotations/text-properties to add when displayed in *Completions*. | |
365b9a62 SM |
65 | ;; - quoting/unquoting (so we can complete files names with envvars |
66 | ;; and backslashes, and all-completion can list names without | |
67 | ;; quoting backslashes and dollars). | |
68 | ;; - indicate how to turn all-completion's output into | |
69 | ;; try-completion's output: e.g. completion-ignored-extensions. | |
70 | ;; maybe that could be merged with the "quote" operation above. | |
71 | ;; - completion hook to run when the completion is | |
72 | ;; selected/inserted (maybe this should be provided some other | |
73 | ;; way, e.g. as text-property, so `try-completion can also return it?) | |
74 | ;; both for when it's inserted via TAB or via choose-completion. | |
75 | ;; - indicate that `all-completions' doesn't do prefix-completion | |
76 | ;; but just returns some list that relates in some other way to | |
77 | ;; the provided string (as is the case in filecache.el), in which | |
78 | ;; case partial-completion (for example) doesn't make any sense | |
79 | ;; and neither does the completions-first-difference highlight. | |
902a6d8d SM |
80 | ;; - indicate how to display the completions in *Completions* (turn |
81 | ;; \n into something else, add special boundaries between | |
82 | ;; completions). E.g. when completing from the kill-ring. | |
365b9a62 SM |
83 | |
84 | ;; - make partial-completion-mode obsolete: | |
ab22be48 | 85 | ;; - (?) <foo.h> style completion for file names. |
528c56e2 SM |
86 | ;; This can't be done identically just by tweaking completion, |
87 | ;; because partial-completion-mode's behavior is to expand <string.h> | |
88 | ;; to /usr/include/string.h only when exiting the minibuffer, at which | |
89 | ;; point the completion code is actually not involved normally. | |
90 | ;; Partial-completion-mode does it via a find-file-not-found-function. | |
91 | ;; - special code for C-x C-f <> to visit the file ref'd at point | |
92 | ;; via (require 'foo) or #include "foo". ffap seems like a better | |
93 | ;; place for this feature (supplemented with major-mode-provided | |
94 | ;; functions to find the file ref'd at point). | |
95 | ||
96 | ;; - case-sensitivity currently confuses two issues: | |
ab22be48 | 97 | ;; - whether or not a particular completion table should be case-sensitive |
528c56e2 | 98 | ;; (i.e. whether strings that differ only by case are semantically |
ab22be48 SM |
99 | ;; equivalent) |
100 | ;; - whether the user wants completion to pay attention to case. | |
101 | ;; e.g. we may want to make it possible for the user to say "first try | |
102 | ;; completion case-sensitively, and if that fails, try to ignore case". | |
103 | ||
a38313e1 | 104 | ;; - add support for ** to pcm. |
3911966b SM |
105 | ;; - Add vc-file-name-completion-table to read-file-name-internal. |
106 | ;; - A feature like completing-help.el. | |
32bae13c SM |
107 | |
108 | ;;; Code: | |
109 | ||
110 | (eval-when-compile (require 'cl)) | |
111 | ||
21622c6d SM |
112 | ;;; Completion table manipulation |
113 | ||
a38313e1 | 114 | ;; New completion-table operation. |
f8381803 SM |
115 | (defun completion-boundaries (string table pred suffix) |
116 | "Return the boundaries of the completions returned by TABLE for STRING. | |
a38313e1 | 117 | STRING is the string on which completion will be performed. |
f8381803 SM |
118 | SUFFIX is the string after point. |
119 | The result is of the form (START . END) where START is the position | |
120 | in STRING of the beginning of the completion field and END is the position | |
121 | in SUFFIX of the end of the completion field. | |
f8381803 SM |
122 | E.g. for simple completion tables, the result is always (0 . (length SUFFIX)) |
123 | and for file names the result is the positions delimited by | |
a38313e1 SM |
124 | the closest directory separators." |
125 | (let ((boundaries (if (functionp table) | |
f8381803 | 126 | (funcall table string pred (cons 'boundaries suffix))))) |
a38313e1 SM |
127 | (if (not (eq (car-safe boundaries) 'boundaries)) |
128 | (setq boundaries nil)) | |
129 | (cons (or (cadr boundaries) 0) | |
f8381803 | 130 | (or (cddr boundaries) (length suffix))))) |
a38313e1 | 131 | |
e2947429 SM |
132 | (defun completion--some (fun xs) |
133 | "Apply FUN to each element of XS in turn. | |
134 | Return the first non-nil returned value. | |
135 | Like CL's `some'." | |
a647cb26 SM |
136 | (let ((firsterror nil) |
137 | res) | |
e2947429 | 138 | (while (and (not res) xs) |
a38313e1 SM |
139 | (condition-case err |
140 | (setq res (funcall fun (pop xs))) | |
141 | (error (unless firsterror (setq firsterror err)) nil))) | |
142 | (or res | |
143 | (if firsterror (signal (car firsterror) (cdr firsterror)))))) | |
e2947429 | 144 | |
21622c6d SM |
145 | (defun complete-with-action (action table string pred) |
146 | "Perform completion ACTION. | |
147 | STRING is the string to complete. | |
148 | TABLE is the completion table, which should not be a function. | |
149 | PRED is a completion predicate. | |
150 | ACTION can be one of nil, t or `lambda'." | |
a38313e1 SM |
151 | (cond |
152 | ((functionp table) (funcall table string pred action)) | |
153 | ((eq (car-safe action) 'boundaries) | |
154 | (cons 'boundaries (completion-boundaries string table pred (cdr action)))) | |
155 | (t | |
156 | (funcall | |
157 | (cond | |
158 | ((null action) 'try-completion) | |
159 | ((eq action t) 'all-completions) | |
160 | (t 'test-completion)) | |
161 | string table pred)))) | |
21622c6d SM |
162 | |
163 | (defun completion-table-dynamic (fun) | |
164 | "Use function FUN as a dynamic completion table. | |
165 | FUN is called with one argument, the string for which completion is required, | |
b95c7600 JB |
166 | and it should return an alist containing all the intended possible completions. |
167 | This alist may be a full list of possible completions so that FUN can ignore | |
168 | the value of its argument. If completion is performed in the minibuffer, | |
169 | FUN will be called in the buffer from which the minibuffer was entered. | |
21622c6d | 170 | |
e8061cd9 | 171 | The result of the `completion-table-dynamic' form is a function |
d9aa6b33 | 172 | that can be used as the COLLECTION argument to `try-completion' and |
b95c7600 | 173 | `all-completions'. See Info node `(elisp)Programmed Completion'." |
a647cb26 | 174 | (lambda (string pred action) |
03408648 SM |
175 | (if (eq (car-safe action) 'boundaries) |
176 | ;; `fun' is not supposed to return another function but a plain old | |
177 | ;; completion table, whose boundaries are always trivial. | |
178 | nil | |
179 | (with-current-buffer (let ((win (minibuffer-selected-window))) | |
180 | (if (window-live-p win) (window-buffer win) | |
181 | (current-buffer))) | |
182 | (complete-with-action action (funcall fun string) string pred))))) | |
21622c6d SM |
183 | |
184 | (defmacro lazy-completion-table (var fun) | |
185 | "Initialize variable VAR as a lazy completion table. | |
186 | If the completion table VAR is used for the first time (e.g., by passing VAR | |
187 | as an argument to `try-completion'), the function FUN is called with no | |
188 | arguments. FUN must return the completion table that will be stored in VAR. | |
189 | If completion is requested in the minibuffer, FUN will be called in the buffer | |
190 | from which the minibuffer was entered. The return value of | |
191 | `lazy-completion-table' must be used to initialize the value of VAR. | |
192 | ||
193 | You should give VAR a non-nil `risky-local-variable' property." | |
69e018a7 | 194 | (declare (debug (symbolp lambda-expr))) |
21622c6d SM |
195 | (let ((str (make-symbol "string"))) |
196 | `(completion-table-dynamic | |
197 | (lambda (,str) | |
198 | (when (functionp ,var) | |
199 | (setq ,var (,fun))) | |
200 | ,var)))) | |
201 | ||
e2784c87 TH |
202 | (defun completion-table-case-fold (table string pred action) |
203 | (let ((completion-ignore-case t)) | |
204 | (complete-with-action action table string pred))) | |
205 | ||
21622c6d | 206 | (defun completion-table-with-context (prefix table string pred action) |
25c0d999 | 207 | ;; TODO: add `suffix' maybe? |
a38313e1 | 208 | ;; Notice that `pred' may not be a function in some abusive cases. |
34200787 SM |
209 | (when (functionp pred) |
210 | (setq pred | |
a647cb26 SM |
211 | ;; Predicates are called differently depending on the nature of |
212 | ;; the completion table :-( | |
213 | (cond | |
214 | ((vectorp table) ;Obarray. | |
215 | (lambda (sym) (funcall pred (concat prefix (symbol-name sym))))) | |
216 | ((hash-table-p table) | |
d032d5e7 | 217 | (lambda (s _v) (funcall pred (concat prefix s)))) |
a647cb26 SM |
218 | ((functionp table) |
219 | (lambda (s) (funcall pred (concat prefix s)))) | |
220 | (t ;Lists and alists. | |
221 | (lambda (s) | |
222 | (funcall pred (concat prefix (if (consp s) (car s) s)))))))) | |
a38313e1 SM |
223 | (if (eq (car-safe action) 'boundaries) |
224 | (let* ((len (length prefix)) | |
f8381803 SM |
225 | (bound (completion-boundaries string table pred (cdr action)))) |
226 | (list* 'boundaries (+ (car bound) len) (cdr bound))) | |
a38313e1 SM |
227 | (let ((comp (complete-with-action action table string pred))) |
228 | (cond | |
229 | ;; In case of try-completion, add the prefix. | |
230 | ((stringp comp) (concat prefix comp)) | |
a38313e1 | 231 | (t comp))))) |
21622c6d SM |
232 | |
233 | (defun completion-table-with-terminator (terminator table string pred action) | |
528c56e2 SM |
234 | "Construct a completion table like TABLE but with an extra TERMINATOR. |
235 | This is meant to be called in a curried way by first passing TERMINATOR | |
236 | and TABLE only (via `apply-partially'). | |
237 | TABLE is a completion table, and TERMINATOR is a string appended to TABLE's | |
238 | completion if it is complete. TERMINATOR is also used to determine the | |
a452eee8 SM |
239 | completion suffix's boundary. |
240 | TERMINATOR can also be a cons cell (TERMINATOR . TERMINATOR-REGEXP) | |
241 | in which case TERMINATOR-REGEXP is a regular expression whose submatch | |
242 | number 1 should match TERMINATOR. This is used when there is a need to | |
243 | distinguish occurrences of the TERMINATOR strings which are really terminators | |
244 | from others (e.g. escaped)." | |
3e2d70fd SM |
245 | ;; FIXME: This implementation is not right since it only adds the terminator |
246 | ;; in try-completion, so any completion-style that builds the completion via | |
247 | ;; all-completions won't get the terminator, and selecting an entry in | |
248 | ;; *Completions* won't get the terminator added either. | |
25c0d999 | 249 | (cond |
528c56e2 SM |
250 | ((eq (car-safe action) 'boundaries) |
251 | (let* ((suffix (cdr action)) | |
252 | (bounds (completion-boundaries string table pred suffix)) | |
a452eee8 SM |
253 | (terminator-regexp (if (consp terminator) |
254 | (cdr terminator) (regexp-quote terminator))) | |
255 | (max (string-match terminator-regexp suffix))) | |
528c56e2 SM |
256 | (list* 'boundaries (car bounds) |
257 | (min (cdr bounds) (or max (length suffix)))))) | |
25c0d999 SM |
258 | ((eq action nil) |
259 | (let ((comp (try-completion string table pred))) | |
a452eee8 | 260 | (if (consp terminator) (setq terminator (car terminator))) |
88893215 SM |
261 | (if (eq comp t) |
262 | (concat string terminator) | |
263 | (if (and (stringp comp) | |
528c56e2 SM |
264 | ;; FIXME: Try to avoid this second call, especially since |
265 | ;; it may be very inefficient (because `comp' made us | |
266 | ;; jump to a new boundary, so we complete in that | |
267 | ;; boundary with an empty start string). | |
268 | ;; completion-boundaries might help. | |
25c0d999 | 269 | (eq (try-completion comp table pred) t)) |
88893215 | 270 | (concat comp terminator) |
25c0d999 | 271 | comp)))) |
a38313e1 SM |
272 | ((eq action t) |
273 | ;; FIXME: We generally want the `try' and `all' behaviors to be | |
274 | ;; consistent so pcm can merge the `all' output to get the `try' output, | |
275 | ;; but that sometimes clashes with the need for `all' output to look | |
276 | ;; good in *Completions*. | |
125f7951 SM |
277 | ;; (mapcar (lambda (s) (concat s terminator)) |
278 | ;; (all-completions string table pred)))) | |
a38313e1 | 279 | (all-completions string table pred)) |
25c0d999 SM |
280 | ;; completion-table-with-terminator is always used for |
281 | ;; "sub-completions" so it's only called if the terminator is missing, | |
282 | ;; in which case `test-completion' should return nil. | |
283 | ((eq action 'lambda) nil))) | |
284 | ||
285 | (defun completion-table-with-predicate (table pred1 strict string pred2 action) | |
286 | "Make a completion table equivalent to TABLE but filtered through PRED1. | |
cf43708e | 287 | PRED1 is a function of one argument which returns non-nil if and only if the |
25c0d999 SM |
288 | argument is an element of TABLE which should be considered for completion. |
289 | STRING, PRED2, and ACTION are the usual arguments to completion tables, | |
290 | as described in `try-completion', `all-completions', and `test-completion'. | |
3911966b SM |
291 | If STRICT is t, the predicate always applies; if nil it only applies if |
292 | it does not reduce the set of possible completions to nothing. | |
25c0d999 SM |
293 | Note: TABLE needs to be a proper completion table which obeys predicates." |
294 | (cond | |
295 | ((and (not strict) (eq action 'lambda)) | |
296 | ;; Ignore pred1 since it doesn't really have to apply anyway. | |
af48580e | 297 | (test-completion string table pred2)) |
25c0d999 SM |
298 | (t |
299 | (or (complete-with-action action table string | |
300 | (if (null pred2) pred1 | |
a647cb26 SM |
301 | (lambda (x) |
302 | ;; Call `pred1' first, so that `pred2' | |
303 | ;; really can't tell that `x' is in table. | |
304 | (if (funcall pred1 x) (funcall pred2 x))))) | |
25c0d999 SM |
305 | ;; If completion failed and we're not applying pred1 strictly, try |
306 | ;; again without pred1. | |
307 | (and (not strict) | |
308 | (complete-with-action action table string pred2)))))) | |
21622c6d | 309 | |
e2947429 SM |
310 | (defun completion-table-in-turn (&rest tables) |
311 | "Create a completion table that tries each table in TABLES in turn." | |
528c56e2 SM |
312 | ;; FIXME: the boundaries may come from TABLE1 even when the completion list |
313 | ;; is returned by TABLE2 (because TABLE1 returned an empty list). | |
a647cb26 SM |
314 | (lambda (string pred action) |
315 | (completion--some (lambda (table) | |
316 | (complete-with-action action table string pred)) | |
317 | tables))) | |
e2947429 | 318 | |
25c0d999 SM |
319 | ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) |
320 | ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) | |
e2947429 SM |
321 | (define-obsolete-function-alias |
322 | 'complete-in-turn 'completion-table-in-turn "23.1") | |
25c0d999 SM |
323 | (define-obsolete-function-alias |
324 | 'dynamic-completion-table 'completion-table-dynamic "23.1") | |
21622c6d SM |
325 | |
326 | ;;; Minibuffer completion | |
327 | ||
ba5ff07b SM |
328 | (defgroup minibuffer nil |
329 | "Controlling the behavior of the minibuffer." | |
330 | :link '(custom-manual "(emacs)Minibuffer") | |
331 | :group 'environment) | |
332 | ||
32bae13c SM |
333 | (defun minibuffer-message (message &rest args) |
334 | "Temporarily display MESSAGE at the end of the minibuffer. | |
335 | The text is displayed for `minibuffer-message-timeout' seconds, | |
336 | or until the next input event arrives, whichever comes first. | |
337 | Enclose MESSAGE in [...] if this is not yet the case. | |
338 | If ARGS are provided, then pass MESSAGE through `format'." | |
ab22be48 SM |
339 | (if (not (minibufferp (current-buffer))) |
340 | (progn | |
341 | (if args | |
342 | (apply 'message message args) | |
343 | (message "%s" message)) | |
344 | (prog1 (sit-for (or minibuffer-message-timeout 1000000)) | |
345 | (message nil))) | |
346 | ;; Clear out any old echo-area message to make way for our new thing. | |
347 | (message nil) | |
348 | (setq message (if (and (null args) (string-match-p "\\` *\\[.+\\]\\'" message)) | |
349 | ;; Make sure we can put-text-property. | |
350 | (copy-sequence message) | |
351 | (concat " [" message "]"))) | |
352 | (when args (setq message (apply 'format message args))) | |
353 | (let ((ol (make-overlay (point-max) (point-max) nil t t)) | |
354 | ;; A quit during sit-for normally only interrupts the sit-for, | |
355 | ;; but since minibuffer-message is used at the end of a command, | |
356 | ;; at a time when the command has virtually finished already, a C-g | |
357 | ;; should really cause an abort-recursive-edit instead (i.e. as if | |
358 | ;; the C-g had been typed at top-level). Binding inhibit-quit here | |
359 | ;; is an attempt to get that behavior. | |
360 | (inhibit-quit t)) | |
361 | (unwind-protect | |
362 | (progn | |
363 | (unless (zerop (length message)) | |
364 | ;; The current C cursor code doesn't know to use the overlay's | |
365 | ;; marker's stickiness to figure out whether to place the cursor | |
366 | ;; before or after the string, so let's spoon-feed it the pos. | |
367 | (put-text-property 0 1 'cursor t message)) | |
368 | (overlay-put ol 'after-string message) | |
369 | (sit-for (or minibuffer-message-timeout 1000000))) | |
370 | (delete-overlay ol))))) | |
32bae13c SM |
371 | |
372 | (defun minibuffer-completion-contents () | |
373 | "Return the user input in a minibuffer before point as a string. | |
374 | That is what completion commands operate on." | |
375 | (buffer-substring (field-beginning) (point))) | |
376 | ||
377 | (defun delete-minibuffer-contents () | |
378 | "Delete all user input in a minibuffer. | |
379 | If the current buffer is not a minibuffer, erase its entire contents." | |
8c9f211f CY |
380 | ;; We used to do `delete-field' here, but when file name shadowing |
381 | ;; is on, the field doesn't cover the entire minibuffer contents. | |
382 | (delete-region (minibuffer-prompt-end) (point-max))) | |
32bae13c | 383 | |
369e974d CY |
384 | (defvar completion-show-inline-help t |
385 | "If non-nil, print helpful inline messages during completion.") | |
386 | ||
ba5ff07b SM |
387 | (defcustom completion-auto-help t |
388 | "Non-nil means automatically provide help for invalid completion input. | |
389 | If the value is t the *Completion* buffer is displayed whenever completion | |
390 | is requested but cannot be done. | |
391 | If the value is `lazy', the *Completions* buffer is only displayed after | |
392 | the second failed attempt to complete." | |
e1bb0fe5 | 393 | :type '(choice (const nil) (const t) (const lazy)) |
ba5ff07b SM |
394 | :group 'minibuffer) |
395 | ||
2f7f4bee | 396 | (defconst completion-styles-alist |
fcb68f70 SM |
397 | '((emacs21 |
398 | completion-emacs21-try-completion completion-emacs21-all-completions | |
79d74ac5 SM |
399 | "Simple prefix-based completion. |
400 | I.e. when completing \"foo_bar\" (where _ is the position of point), | |
401 | it will consider all completions candidates matching the glob | |
402 | pattern \"foobar*\".") | |
fcb68f70 SM |
403 | (emacs22 |
404 | completion-emacs22-try-completion completion-emacs22-all-completions | |
79d74ac5 SM |
405 | "Prefix completion that only operates on the text before point. |
406 | I.e. when completing \"foo_bar\" (where _ is the position of point), | |
407 | it will consider all completions candidates matching the glob | |
408 | pattern \"foo*\" and will add back \"bar\" to the end of it.") | |
fcb68f70 SM |
409 | (basic |
410 | completion-basic-try-completion completion-basic-all-completions | |
79d74ac5 SM |
411 | "Completion of the prefix before point and the suffix after point. |
412 | I.e. when completing \"foo_bar\" (where _ is the position of point), | |
413 | it will consider all completions candidates matching the glob | |
414 | pattern \"foo*bar*\".") | |
34200787 | 415 | (partial-completion |
fcb68f70 SM |
416 | completion-pcm-try-completion completion-pcm-all-completions |
417 | "Completion of multiple words, each one taken as a prefix. | |
79d74ac5 SM |
418 | I.e. when completing \"l-co_h\" (where _ is the position of point), |
419 | it will consider all completions candidates matching the glob | |
420 | pattern \"l*-co*h*\". | |
421 | Furthermore, for completions that are done step by step in subfields, | |
422 | the method is applied to all the preceding fields that do not yet match. | |
423 | E.g. C-x C-f /u/mo/s TAB could complete to /usr/monnier/src. | |
424 | Additionally the user can use the char \"*\" as a glob pattern.") | |
56d365a9 SM |
425 | (substring |
426 | completion-substring-try-completion completion-substring-all-completions | |
427 | "Completion of the string taken as a substring. | |
428 | I.e. when completing \"foo_bar\" (where _ is the position of point), | |
429 | it will consider all completions candidates matching the glob | |
430 | pattern \"*foo*bar*\".") | |
fcb68f70 SM |
431 | (initials |
432 | completion-initials-try-completion completion-initials-all-completions | |
433 | "Completion of acronyms and initialisms. | |
434 | E.g. can complete M-x lch to list-command-history | |
435 | and C-x C-f ~/sew to ~/src/emacs/work.")) | |
e2947429 | 436 | "List of available completion styles. |
fcb68f70 | 437 | Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS DOC): |
26c548b0 | 438 | where NAME is the name that should be used in `completion-styles', |
fcb68f70 SM |
439 | TRY-COMPLETION is the function that does the completion (it should |
440 | follow the same calling convention as `completion-try-completion'), | |
441 | ALL-COMPLETIONS is the function that lists the completions (it should | |
442 | follow the calling convention of `completion-all-completions'), | |
443 | and DOC describes the way this style of completion works.") | |
e2947429 | 444 | |
79d74ac5 SM |
445 | (defcustom completion-styles |
446 | ;; First, use `basic' because prefix completion has been the standard | |
447 | ;; for "ever" and works well in most cases, so using it first | |
448 | ;; ensures that we obey previous behavior in most cases. | |
449 | '(basic | |
450 | ;; Then use `partial-completion' because it has proven to | |
451 | ;; be a very convenient extension. | |
452 | partial-completion | |
453 | ;; Finally use `emacs22' so as to maintain (in many/most cases) | |
454 | ;; the previous behavior that when completing "foobar" with point | |
455 | ;; between "foo" and "bar" the completion try to complete "foo" | |
456 | ;; and simply add "bar" to the end of the result. | |
457 | emacs22) | |
265d4549 SM |
458 | "List of completion styles to use. |
459 | The available styles are listed in `completion-styles-alist'." | |
e2947429 SM |
460 | :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x))) |
461 | completion-styles-alist))) | |
462 | :group 'minibuffer | |
463 | :version "23.1") | |
464 | ||
19c04f39 SM |
465 | (defun completion-try-completion (string table pred point) |
466 | "Try to complete STRING using completion table TABLE. | |
467 | Only the elements of table that satisfy predicate PRED are considered. | |
468 | POINT is the position of point within STRING. | |
469 | The return value can be either nil to indicate that there is no completion, | |
470 | t to indicate that STRING is the only possible completion, | |
471 | or a pair (STRING . NEWPOINT) of the completed result string together with | |
472 | a new position for point." | |
fcb68f70 SM |
473 | (completion--some (lambda (style) |
474 | (funcall (nth 1 (assq style completion-styles-alist)) | |
475 | string table pred point)) | |
476 | completion-styles)) | |
e2947429 | 477 | |
19c04f39 SM |
478 | (defun completion-all-completions (string table pred point) |
479 | "List the possible completions of STRING in completion table TABLE. | |
480 | Only the elements of table that satisfy predicate PRED are considered. | |
481 | POINT is the position of point within STRING. | |
26c548b0 | 482 | The return value is a list of completions and may contain the base-size |
19c04f39 | 483 | in the last `cdr'." |
365b9a62 SM |
484 | ;; FIXME: We need to additionally return the info needed for the |
485 | ;; second part of completion-base-position. | |
fcb68f70 SM |
486 | (completion--some (lambda (style) |
487 | (funcall (nth 2 (assq style completion-styles-alist)) | |
488 | string table pred point)) | |
489 | completion-styles)) | |
e2947429 | 490 | |
ba5ff07b SM |
491 | (defun minibuffer--bitset (modified completions exact) |
492 | (logior (if modified 4 0) | |
493 | (if completions 2 0) | |
494 | (if exact 1 0))) | |
495 | ||
c53b9c3b SM |
496 | (defun completion--replace (beg end newtext) |
497 | "Replace the buffer text between BEG and END with NEWTEXT. | |
498 | Moves point to the end of the new text." | |
55586d2a | 499 | ;; Maybe this should be in subr.el. |
c53b9c3b SM |
500 | ;; You'd think this is trivial to do, but details matter if you want |
501 | ;; to keep markers "at the right place" and be robust in the face of | |
502 | ;; after-change-functions that may themselves modify the buffer. | |
55586d2a SM |
503 | (let ((prefix-len 0)) |
504 | ;; Don't touch markers in the shared prefix (if any). | |
505 | (while (and (< prefix-len (length newtext)) | |
506 | (< (+ beg prefix-len) end) | |
507 | (eq (char-after (+ beg prefix-len)) | |
508 | (aref newtext prefix-len))) | |
509 | (setq prefix-len (1+ prefix-len))) | |
510 | (unless (zerop prefix-len) | |
511 | (setq beg (+ beg prefix-len)) | |
512 | (setq newtext (substring newtext prefix-len)))) | |
513 | (let ((suffix-len 0)) | |
514 | ;; Don't touch markers in the shared suffix (if any). | |
515 | (while (and (< suffix-len (length newtext)) | |
516 | (< beg (- end suffix-len)) | |
517 | (eq (char-before (- end suffix-len)) | |
518 | (aref newtext (- (length newtext) suffix-len 1)))) | |
519 | (setq suffix-len (1+ suffix-len))) | |
520 | (unless (zerop suffix-len) | |
521 | (setq end (- end suffix-len)) | |
8348910a SM |
522 | (setq newtext (substring newtext 0 (- suffix-len)))) |
523 | (goto-char beg) | |
524 | (insert newtext) | |
525 | (delete-region (point) (+ (point) (- end beg))) | |
526 | (forward-char suffix-len))) | |
c53b9c3b | 527 | |
902a6d8d SM |
528 | (defcustom completion-cycle-threshold nil |
529 | "Number of completion candidates below which cycling is used. | |
530 | Depending on this setting `minibuffer-complete' may use cycling, | |
531 | like `minibuffer-force-complete'. | |
532 | If nil, cycling is never used. | |
533 | If t, cycling is always used. | |
534 | If an integer, cycling is used as soon as there are fewer completion | |
535 | candidates than this number." | |
536 | :type '(choice (const :tag "No cycling" nil) | |
537 | (const :tag "Always cycle" t) | |
538 | (integer :tag "Threshold"))) | |
539 | ||
6175cd08 SM |
540 | (defvar completion-all-sorted-completions nil) |
541 | (make-variable-buffer-local 'completion-all-sorted-completions) | |
542 | (defvar completion-cycling nil) | |
543 | ||
b7e270a2 SM |
544 | (defvar completion-fail-discreetly nil |
545 | "If non-nil, stay quiet when there is no match.") | |
546 | ||
3911966b | 547 | (defun completion--do-completion (&optional try-completion-function) |
32bae13c | 548 | "Do the completion and return a summary of what happened. |
ba5ff07b SM |
549 | M = completion was performed, the text was Modified. |
550 | C = there were available Completions. | |
551 | E = after completion we now have an Exact match. | |
552 | ||
553 | MCE | |
554 | 000 0 no possible completion | |
555 | 001 1 was already an exact and unique completion | |
556 | 010 2 no completion happened | |
557 | 011 3 was already an exact completion | |
558 | 100 4 ??? impossible | |
559 | 101 5 ??? impossible | |
560 | 110 6 some completion happened | |
561 | 111 7 completed to an exact completion" | |
a647cb26 SM |
562 | (let* ((beg (field-beginning)) |
563 | (end (field-end)) | |
564 | (string (buffer-substring beg end)) | |
565 | (comp (funcall (or try-completion-function | |
566 | 'completion-try-completion) | |
567 | string | |
568 | minibuffer-completion-table | |
569 | minibuffer-completion-predicate | |
570 | (- (point) beg)))) | |
32bae13c | 571 | (cond |
19c04f39 | 572 | ((null comp) |
890429cc | 573 | (minibuffer-hide-completions) |
369e974d CY |
574 | (when (and (not completion-fail-discreetly) completion-show-inline-help) |
575 | (ding) | |
576 | (minibuffer-message "No match")) | |
b7e270a2 | 577 | (minibuffer--bitset nil nil nil)) |
265d4549 | 578 | ((eq t comp) |
890429cc | 579 | (minibuffer-hide-completions) |
265d4549 | 580 | (goto-char (field-end)) |
6175cd08 | 581 | (minibuffer--bitset nil nil t)) ;Exact and unique match. |
32bae13c SM |
582 | (t |
583 | ;; `completed' should be t if some completion was done, which doesn't | |
584 | ;; include simply changing the case of the entered string. However, | |
585 | ;; for appearance, the string is rewritten if the case changes. | |
a647cb26 SM |
586 | (let* ((comp-pos (cdr comp)) |
587 | (completion (car comp)) | |
588 | (completed (not (eq t (compare-strings completion nil nil | |
589 | string nil nil t)))) | |
590 | (unchanged (eq t (compare-strings completion nil nil | |
591 | string nil nil nil)))) | |
c53b9c3b | 592 | (if unchanged |
397ae226 | 593 | (goto-char end) |
c53b9c3b SM |
594 | ;; Insert in minibuffer the chars we got. |
595 | (completion--replace beg end completion)) | |
596 | ;; Move point to its completion-mandated destination. | |
597 | (forward-char (- comp-pos (length completion))) | |
ba5ff07b | 598 | |
32bae13c | 599 | (if (not (or unchanged completed)) |
6175cd08 SM |
600 | ;; The case of the string changed, but that's all. We're not sure |
601 | ;; whether this is a unique completion or not, so try again using | |
602 | ;; the real case (this shouldn't recurse again, because the next | |
603 | ;; time try-completion will return either t or the exact string). | |
604 | (completion--do-completion try-completion-function) | |
32bae13c SM |
605 | |
606 | ;; It did find a match. Do we match some possibility exactly now? | |
19c04f39 | 607 | (let ((exact (test-completion completion |
32bae13c | 608 | minibuffer-completion-table |
902a6d8d SM |
609 | minibuffer-completion-predicate)) |
610 | (comps | |
611 | ;; Check to see if we want to do cycling. We do it | |
612 | ;; here, after having performed the normal completion, | |
613 | ;; so as to take advantage of the difference between | |
614 | ;; try-completion and all-completions, for things | |
615 | ;; like completion-ignored-extensions. | |
616 | (when (and completion-cycle-threshold | |
617 | ;; Check that the completion didn't make | |
618 | ;; us jump to a different boundary. | |
619 | (or (not completed) | |
620 | (< (car (completion-boundaries | |
621 | (substring completion 0 comp-pos) | |
622 | minibuffer-completion-table | |
623 | minibuffer-completion-predicate | |
624 | "")) | |
625 | comp-pos))) | |
626 | (completion-all-sorted-completions)))) | |
6175cd08 | 627 | (completion--flush-all-sorted-completions) |
902a6d8d | 628 | (cond |
6175cd08 SM |
629 | ((and (consp (cdr comps)) ;; There's something to cycle. |
630 | (not (ignore-errors | |
902a6d8d SM |
631 | ;; This signal an (intended) error if comps is too |
632 | ;; short or if completion-cycle-threshold is t. | |
6175cd08 | 633 | (consp (nthcdr completion-cycle-threshold comps))))) |
902a6d8d SM |
634 | ;; Fewer than completion-cycle-threshold remaining |
635 | ;; completions: let's cycle. | |
636 | (setq completed t exact t) | |
637 | (setq completion-all-sorted-completions comps) | |
638 | (minibuffer-force-complete)) | |
639 | (completed | |
6175cd08 SM |
640 | ;; We could also decide to refresh the completions, |
641 | ;; if they're displayed (and assuming there are | |
642 | ;; completions left). | |
902a6d8d | 643 | (minibuffer-hide-completions)) |
6175cd08 SM |
644 | ;; Show the completion table, if requested. |
645 | ((not exact) | |
369e974d CY |
646 | (if (cond ((null completion-show-inline-help) t) |
647 | ((eq completion-auto-help 'lazy) | |
648 | (eq this-command last-command)) | |
649 | (t completion-auto-help)) | |
6175cd08 SM |
650 | (minibuffer-completion-help) |
651 | (minibuffer-message "Next char not unique"))) | |
652 | ;; If the last exact completion and this one were the same, it | |
653 | ;; means we've already given a "Next char not unique" message | |
654 | ;; and the user's hit TAB again, so now we give him help. | |
655 | ((eq this-command last-command) | |
902a6d8d | 656 | (if completion-auto-help (minibuffer-completion-help)))) |
ba5ff07b SM |
657 | |
658 | (minibuffer--bitset completed t exact)))))))) | |
32bae13c SM |
659 | |
660 | (defun minibuffer-complete () | |
661 | "Complete the minibuffer contents as far as possible. | |
662 | Return nil if there is no valid completion, else t. | |
663 | If no characters can be completed, display a list of possible completions. | |
664 | If you repeat this command after it displayed such a list, | |
665 | scroll the window of possible completions." | |
666 | (interactive) | |
667 | ;; If the previous command was not this, | |
668 | ;; mark the completion buffer obsolete. | |
669 | (unless (eq this-command last-command) | |
6175cd08 | 670 | (completion--flush-all-sorted-completions) |
32bae13c SM |
671 | (setq minibuffer-scroll-window nil)) |
672 | ||
902a6d8d | 673 | (cond |
03408648 SM |
674 | ;; If there's a fresh completion window with a live buffer, |
675 | ;; and this command is repeated, scroll that window. | |
902a6d8d SM |
676 | ((window-live-p minibuffer-scroll-window) |
677 | (let ((window minibuffer-scroll-window)) | |
03408648 SM |
678 | (with-current-buffer (window-buffer window) |
679 | (if (pos-visible-in-window-p (point-max) window) | |
680 | ;; If end is in view, scroll up to the beginning. | |
681 | (set-window-start window (point-min) nil) | |
682 | ;; Else scroll down one screen. | |
683 | (scroll-other-window)) | |
902a6d8d SM |
684 | nil))) |
685 | ;; If we're cycling, keep on cycling. | |
6175cd08 | 686 | ((and completion-cycling completion-all-sorted-completions) |
902a6d8d SM |
687 | (minibuffer-force-complete) |
688 | t) | |
689 | (t (case (completion--do-completion) | |
a38313e1 | 690 | (#b000 nil) |
369e974d CY |
691 | (#b001 (if completion-show-inline-help |
692 | (minibuffer-message "Sole completion")) | |
a38313e1 | 693 | t) |
369e974d CY |
694 | (#b011 (if completion-show-inline-help |
695 | (minibuffer-message "Complete, but not unique")) | |
a38313e1 SM |
696 | t) |
697 | (t t))))) | |
32bae13c | 698 | |
d032d5e7 | 699 | (defun completion--flush-all-sorted-completions (&rest _ignore) |
d86d2721 SM |
700 | (remove-hook 'after-change-functions |
701 | 'completion--flush-all-sorted-completions t) | |
6175cd08 | 702 | (setq completion-cycling nil) |
14c24780 SM |
703 | (setq completion-all-sorted-completions nil)) |
704 | ||
705 | (defun completion-all-sorted-completions () | |
706 | (or completion-all-sorted-completions | |
707 | (let* ((start (field-beginning)) | |
708 | (end (field-end)) | |
709 | (all (completion-all-completions (buffer-substring start end) | |
710 | minibuffer-completion-table | |
711 | minibuffer-completion-predicate | |
712 | (- (point) start))) | |
713 | (last (last all)) | |
714 | (base-size (or (cdr last) 0))) | |
715 | (when last | |
716 | (setcdr last nil) | |
717 | ;; Prefer shorter completions. | |
40c2934b SM |
718 | (setq all (sort all (lambda (c1 c2) |
719 | (let ((s1 (get-text-property | |
720 | 0 :completion-cycle-penalty c1)) | |
721 | (s2 (get-text-property | |
722 | 0 :completion-cycle-penalty c2))) | |
723 | (if (eq s1 s2) | |
724 | (< (length c1) (length c2)) | |
725 | (< (or s1 (length c1)) | |
726 | (or s2 (length c2)))))))) | |
14c24780 | 727 | ;; Prefer recently used completions. |
3e2d70fd SM |
728 | ;; FIXME: Additional sorting ideas: |
729 | ;; - for M-x, prefer commands that have no key binding. | |
14c24780 SM |
730 | (let ((hist (symbol-value minibuffer-history-variable))) |
731 | (setq all (sort all (lambda (c1 c2) | |
732 | (> (length (member c1 hist)) | |
733 | (length (member c2 hist))))))) | |
734 | ;; Cache the result. This is not just for speed, but also so that | |
735 | ;; repeated calls to minibuffer-force-complete can cycle through | |
736 | ;; all possibilities. | |
737 | (add-hook 'after-change-functions | |
738 | 'completion--flush-all-sorted-completions nil t) | |
739 | (setq completion-all-sorted-completions | |
740 | (nconc all base-size)))))) | |
741 | ||
742 | (defun minibuffer-force-complete () | |
743 | "Complete the minibuffer to an exact match. | |
744 | Repeated uses step through the possible completions." | |
745 | (interactive) | |
746 | ;; FIXME: Need to deal with the extra-size issue here as well. | |
528c56e2 SM |
747 | ;; FIXME: ~/src/emacs/t<M-TAB>/lisp/minibuffer.el completes to |
748 | ;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el. | |
14c24780 SM |
749 | (let* ((start (field-beginning)) |
750 | (end (field-end)) | |
751 | (all (completion-all-sorted-completions))) | |
752 | (if (not (consp all)) | |
369e974d CY |
753 | (if completion-show-inline-help |
754 | (minibuffer-message | |
755 | (if all "No more completions" "No completions"))) | |
6175cd08 | 756 | (setq completion-cycling t) |
14c24780 SM |
757 | (goto-char end) |
758 | (insert (car all)) | |
759 | (delete-region (+ start (cdr (last all))) end) | |
760 | ;; If completing file names, (car all) may be a directory, so we'd now | |
761 | ;; have a new set of possible completions and might want to reset | |
762 | ;; completion-all-sorted-completions to nil, but we prefer not to, | |
763 | ;; so that repeated calls minibuffer-force-complete still cycle | |
764 | ;; through the previous possible completions. | |
075518b5 SM |
765 | (let ((last (last all))) |
766 | (setcdr last (cons (car all) (cdr last))) | |
767 | (setq completion-all-sorted-completions (cdr all)))))) | |
14c24780 | 768 | |
d1826585 | 769 | (defvar minibuffer-confirm-exit-commands |
a25c543a | 770 | '(minibuffer-complete minibuffer-complete-word PC-complete PC-complete-word) |
d1826585 MB |
771 | "A list of commands which cause an immediately following |
772 | `minibuffer-complete-and-exit' to ask for extra confirmation.") | |
773 | ||
32bae13c | 774 | (defun minibuffer-complete-and-exit () |
bec1e8a5 CY |
775 | "Exit if the minibuffer contains a valid completion. |
776 | Otherwise, try to complete the minibuffer contents. If | |
777 | completion leads to a valid completion, a repetition of this | |
778 | command will exit. | |
779 | ||
780 | If `minibuffer-completion-confirm' is `confirm', do not try to | |
781 | complete; instead, ask for confirmation and accept any input if | |
782 | confirmed. | |
783 | If `minibuffer-completion-confirm' is `confirm-after-completion', | |
784 | do not try to complete; instead, ask for confirmation if the | |
90810a8e CY |
785 | preceding minibuffer command was a member of |
786 | `minibuffer-confirm-exit-commands', and accept the input | |
787 | otherwise." | |
32bae13c | 788 | (interactive) |
a647cb26 SM |
789 | (let ((beg (field-beginning)) |
790 | (end (field-end))) | |
3911966b SM |
791 | (cond |
792 | ;; Allow user to specify null string | |
793 | ((= beg end) (exit-minibuffer)) | |
794 | ((test-completion (buffer-substring beg end) | |
795 | minibuffer-completion-table | |
796 | minibuffer-completion-predicate) | |
365b9a62 SM |
797 | ;; FIXME: completion-ignore-case has various slightly |
798 | ;; incompatible meanings. E.g. it can reflect whether the user | |
799 | ;; wants completion to pay attention to case, or whether the | |
800 | ;; string will be used in a context where case is significant. | |
801 | ;; E.g. usually try-completion should obey the first, whereas | |
802 | ;; test-completion should obey the second. | |
3911966b SM |
803 | (when completion-ignore-case |
804 | ;; Fixup case of the field, if necessary. | |
b0a5a021 | 805 | (let* ((string (buffer-substring beg end)) |
3911966b SM |
806 | (compl (try-completion |
807 | string | |
808 | minibuffer-completion-table | |
809 | minibuffer-completion-predicate))) | |
365b9a62 | 810 | (when (and (stringp compl) (not (equal string compl)) |
3911966b SM |
811 | ;; If it weren't for this piece of paranoia, I'd replace |
812 | ;; the whole thing with a call to do-completion. | |
eee6de73 SM |
813 | ;; This is important, e.g. when the current minibuffer's |
814 | ;; content is a directory which only contains a single | |
815 | ;; file, so `try-completion' actually completes to | |
816 | ;; that file. | |
3911966b | 817 | (= (length string) (length compl))) |
32bae13c SM |
818 | (goto-char end) |
819 | (insert compl) | |
3911966b SM |
820 | (delete-region beg end)))) |
821 | (exit-minibuffer)) | |
32bae13c | 822 | |
365b9a62 | 823 | ((memq minibuffer-completion-confirm '(confirm confirm-after-completion)) |
3911966b | 824 | ;; The user is permitted to exit with an input that's rejected |
bec1e8a5 | 825 | ;; by test-completion, after confirming her choice. |
365b9a62 SM |
826 | (if (or (eq last-command this-command) |
827 | ;; For `confirm-after-completion' we only ask for confirmation | |
828 | ;; if trying to exit immediately after typing TAB (this | |
829 | ;; catches most minibuffer typos). | |
830 | (and (eq minibuffer-completion-confirm 'confirm-after-completion) | |
831 | (not (memq last-command minibuffer-confirm-exit-commands)))) | |
3911966b SM |
832 | (exit-minibuffer) |
833 | (minibuffer-message "Confirm") | |
834 | nil)) | |
32bae13c | 835 | |
3911966b SM |
836 | (t |
837 | ;; Call do-completion, but ignore errors. | |
838 | (case (condition-case nil | |
839 | (completion--do-completion) | |
840 | (error 1)) | |
a38313e1 SM |
841 | ((#b001 #b011) (exit-minibuffer)) |
842 | (#b111 (if (not minibuffer-completion-confirm) | |
843 | (exit-minibuffer) | |
844 | (minibuffer-message "Confirm") | |
845 | nil)) | |
3911966b SM |
846 | (t nil)))))) |
847 | ||
19c04f39 SM |
848 | (defun completion--try-word-completion (string table predicate point) |
849 | (let ((comp (completion-try-completion string table predicate point))) | |
850 | (if (not (consp comp)) | |
851 | comp | |
32bae13c | 852 | |
3911966b SM |
853 | ;; If completion finds next char not unique, |
854 | ;; consider adding a space or a hyphen. | |
19c04f39 | 855 | (when (= (length string) (length (car comp))) |
1afbbf85 SM |
856 | ;; Mark the added char with the `completion-word' property, so it |
857 | ;; can be handled specially by completion styles such as | |
858 | ;; partial-completion. | |
859 | ;; We used to remove `partial-completion' from completion-styles | |
860 | ;; instead, but it was too blunt, leading to situations where SPC | |
861 | ;; was the only insertable char at point but minibuffer-complete-word | |
862 | ;; refused inserting it. | |
863 | (let ((exts (mapcar (lambda (str) (propertize str 'completion-try-word t)) | |
864 | '(" " "-"))) | |
19c04f39 SM |
865 | (before (substring string 0 point)) |
866 | (after (substring string point)) | |
867 | tem) | |
868 | (while (and exts (not (consp tem))) | |
3911966b | 869 | (setq tem (completion-try-completion |
19c04f39 SM |
870 | (concat before (pop exts) after) |
871 | table predicate (1+ point)))) | |
872 | (if (consp tem) (setq comp tem)))) | |
3911966b | 873 | |
32bae13c SM |
874 | ;; Completing a single word is actually more difficult than completing |
875 | ;; as much as possible, because we first have to find the "current | |
876 | ;; position" in `completion' in order to find the end of the word | |
877 | ;; we're completing. Normally, `string' is a prefix of `completion', | |
878 | ;; which makes it trivial to find the position, but with fancier | |
879 | ;; completion (plus env-var expansion, ...) `completion' might not | |
880 | ;; look anything like `string' at all. | |
19c04f39 SM |
881 | (let* ((comppoint (cdr comp)) |
882 | (completion (car comp)) | |
883 | (before (substring string 0 point)) | |
884 | (combined (concat before "\n" completion))) | |
885 | ;; Find in completion the longest text that was right before point. | |
886 | (when (string-match "\\(.+\\)\n.*?\\1" combined) | |
887 | (let* ((prefix (match-string 1 before)) | |
888 | ;; We used non-greedy match to make `rem' as long as possible. | |
889 | (rem (substring combined (match-end 0))) | |
890 | ;; Find in the remainder of completion the longest text | |
891 | ;; that was right after point. | |
892 | (after (substring string point)) | |
893 | (suffix (if (string-match "\\`\\(.+\\).*\n.*\\1" | |
894 | (concat after "\n" rem)) | |
895 | (match-string 1 after)))) | |
896 | ;; The general idea is to try and guess what text was inserted | |
897 | ;; at point by the completion. Problem is: if we guess wrong, | |
898 | ;; we may end up treating as "added by completion" text that was | |
899 | ;; actually painfully typed by the user. So if we then cut | |
900 | ;; after the first word, we may throw away things the | |
901 | ;; user wrote. So let's try to be as conservative as possible: | |
902 | ;; only cut after the first word, if we're reasonably sure that | |
903 | ;; our guess is correct. | |
904 | ;; Note: a quick survey on emacs-devel seemed to indicate that | |
905 | ;; nobody actually cares about the "word-at-a-time" feature of | |
906 | ;; minibuffer-complete-word, whose real raison-d'être is that it | |
907 | ;; tries to add "-" or " ". One more reason to only cut after | |
908 | ;; the first word, if we're really sure we're right. | |
909 | (when (and (or suffix (zerop (length after))) | |
910 | (string-match (concat | |
911 | ;; Make submatch 1 as small as possible | |
912 | ;; to reduce the risk of cutting | |
913 | ;; valuable text. | |
914 | ".*" (regexp-quote prefix) "\\(.*?\\)" | |
915 | (if suffix (regexp-quote suffix) "\\'")) | |
916 | completion) | |
917 | ;; The new point in `completion' should also be just | |
918 | ;; before the suffix, otherwise something more complex | |
919 | ;; is going on, and we're not sure where we are. | |
920 | (eq (match-end 1) comppoint) | |
921 | ;; (match-beginning 1)..comppoint is now the stretch | |
922 | ;; of text in `completion' that was completed at point. | |
923 | (string-match "\\W" completion (match-beginning 1)) | |
924 | ;; Is there really something to cut? | |
925 | (> comppoint (match-end 0))) | |
926 | ;; Cut after the first word. | |
927 | (let ((cutpos (match-end 0))) | |
928 | (setq completion (concat (substring completion 0 cutpos) | |
929 | (substring completion comppoint))) | |
930 | (setq comppoint cutpos))))) | |
931 | ||
932 | (cons completion comppoint))))) | |
ba5ff07b SM |
933 | |
934 | ||
935 | (defun minibuffer-complete-word () | |
936 | "Complete the minibuffer contents at most a single word. | |
937 | After one word is completed as much as possible, a space or hyphen | |
938 | is added, provided that matches some possible completion. | |
939 | Return nil if there is no valid completion, else t." | |
940 | (interactive) | |
3911966b | 941 | (case (completion--do-completion 'completion--try-word-completion) |
a38313e1 | 942 | (#b000 nil) |
369e974d CY |
943 | (#b001 (if completion-show-inline-help |
944 | (minibuffer-message "Sole completion")) | |
a38313e1 | 945 | t) |
369e974d CY |
946 | (#b011 (if completion-show-inline-help |
947 | (minibuffer-message "Complete, but not unique")) | |
a38313e1 SM |
948 | t) |
949 | (t t))) | |
ba5ff07b | 950 | |
890429cc SM |
951 | (defface completions-annotations '((t :inherit italic)) |
952 | "Face to use for annotations in the *Completions* buffer.") | |
953 | ||
8f3b8a5f | 954 | (defcustom completions-format 'horizontal |
3a9f97fa JL |
955 | "Define the appearance and sorting of completions. |
956 | If the value is `vertical', display completions sorted vertically | |
957 | in columns in the *Completions* buffer. | |
8f3b8a5f | 958 | If the value is `horizontal', display completions sorted |
3a9f97fa | 959 | horizontally in alphabetical order, rather than down the screen." |
8f3b8a5f | 960 | :type '(choice (const horizontal) (const vertical)) |
3a9f97fa JL |
961 | :group 'minibuffer |
962 | :version "23.2") | |
963 | ||
3911966b | 964 | (defun completion--insert-strings (strings) |
32bae13c SM |
965 | "Insert a list of STRINGS into the current buffer. |
966 | Uses columns to keep the listing readable but compact. | |
967 | It also eliminates runs of equal strings." | |
968 | (when (consp strings) | |
969 | (let* ((length (apply 'max | |
970 | (mapcar (lambda (s) | |
971 | (if (consp s) | |
e5b5b82d SM |
972 | (+ (string-width (car s)) |
973 | (string-width (cadr s))) | |
974 | (string-width s))) | |
32bae13c SM |
975 | strings))) |
976 | (window (get-buffer-window (current-buffer) 0)) | |
977 | (wwidth (if window (1- (window-width window)) 79)) | |
978 | (columns (min | |
979 | ;; At least 2 columns; at least 2 spaces between columns. | |
980 | (max 2 (/ wwidth (+ 2 length))) | |
981 | ;; Don't allocate more columns than we can fill. | |
982 | ;; Windows can't show less than 3 lines anyway. | |
983 | (max 1 (/ (length strings) 2)))) | |
984 | (colwidth (/ wwidth columns)) | |
985 | (column 0) | |
3a9f97fa JL |
986 | (rows (/ (length strings) columns)) |
987 | (row 0) | |
32bae13c SM |
988 | (laststring nil)) |
989 | ;; The insertion should be "sensible" no matter what choices were made | |
990 | ;; for the parameters above. | |
991 | (dolist (str strings) | |
f87ff539 | 992 | (unless (equal laststring str) ; Remove (consecutive) duplicates. |
32bae13c | 993 | (setq laststring str) |
f87ff539 SM |
994 | (let ((length (if (consp str) |
995 | (+ (string-width (car str)) | |
996 | (string-width (cadr str))) | |
997 | (string-width str)))) | |
3a9f97fa JL |
998 | (cond |
999 | ((eq completions-format 'vertical) | |
1000 | ;; Vertical format | |
1001 | (when (> row rows) | |
1002 | (forward-line (- -1 rows)) | |
1003 | (setq row 0 column (+ column colwidth))) | |
1004 | (when (> column 0) | |
1005 | (end-of-line) | |
1006 | (while (> (current-column) column) | |
1007 | (if (eobp) | |
1008 | (insert "\n") | |
1009 | (forward-line 1) | |
1010 | (end-of-line))) | |
1011 | (insert " \t") | |
1012 | (set-text-properties (- (point) 1) (point) | |
1013 | `(display (space :align-to ,column))))) | |
1014 | (t | |
1015 | ;; Horizontal format | |
1016 | (unless (bolp) | |
1017 | (if (< wwidth (+ (max colwidth length) column)) | |
1018 | ;; No space for `str' at point, move to next line. | |
1019 | (progn (insert "\n") (setq column 0)) | |
1020 | (insert " \t") | |
1021 | ;; Leave the space unpropertized so that in the case we're | |
1022 | ;; already past the goal column, there is still | |
1023 | ;; a space displayed. | |
1024 | (set-text-properties (- (point) 1) (point) | |
1025 | ;; We can't just set tab-width, because | |
3e2d70fd SM |
1026 | ;; completion-setup-function will kill |
1027 | ;; all local variables :-( | |
3a9f97fa JL |
1028 | `(display (space :align-to ,column))) |
1029 | nil)))) | |
f87ff539 SM |
1030 | (if (not (consp str)) |
1031 | (put-text-property (point) (progn (insert str) (point)) | |
1032 | 'mouse-face 'highlight) | |
1033 | (put-text-property (point) (progn (insert (car str)) (point)) | |
1034 | 'mouse-face 'highlight) | |
890429cc SM |
1035 | (add-text-properties (point) (progn (insert (cadr str)) (point)) |
1036 | '(mouse-face nil | |
03408648 | 1037 | face completions-annotations))) |
3a9f97fa JL |
1038 | (cond |
1039 | ((eq completions-format 'vertical) | |
1040 | ;; Vertical format | |
1041 | (if (> column 0) | |
1042 | (forward-line) | |
1043 | (insert "\n")) | |
1044 | (setq row (1+ row))) | |
1045 | (t | |
1046 | ;; Horizontal format | |
1047 | ;; Next column to align to. | |
1048 | (setq column (+ column | |
1049 | ;; Round up to a whole number of columns. | |
1050 | (* colwidth (ceiling length colwidth)))))))))))) | |
32bae13c | 1051 | |
6138158d SM |
1052 | (defvar completion-common-substring nil) |
1053 | (make-obsolete-variable 'completion-common-substring nil "23.1") | |
32bae13c | 1054 | |
21622c6d SM |
1055 | (defvar completion-setup-hook nil |
1056 | "Normal hook run at the end of setting up a completion list buffer. | |
1057 | When this hook is run, the current buffer is the one in which the | |
1058 | command to display the completion list buffer was run. | |
1059 | The completion list buffer is available as the value of `standard-output'. | |
6138158d SM |
1060 | See also `display-completion-list'.") |
1061 | ||
1062 | (defface completions-first-difference | |
1063 | '((t (:inherit bold))) | |
1064 | "Face put on the first uncommon character in completions in *Completions* buffer." | |
1065 | :group 'completion) | |
1066 | ||
1067 | (defface completions-common-part | |
1068 | '((t (:inherit default))) | |
1069 | "Face put on the common prefix substring in completions in *Completions* buffer. | |
1070 | The idea of `completions-common-part' is that you can use it to | |
1071 | make the common parts less visible than normal, so that the rest | |
1072 | of the differing parts is, by contrast, slightly highlighted." | |
1073 | :group 'completion) | |
1074 | ||
125f7951 | 1075 | (defun completion-hilit-commonality (completions prefix-len base-size) |
6138158d | 1076 | (when completions |
125f7951 | 1077 | (let ((com-str-len (- prefix-len (or base-size 0)))) |
6138158d SM |
1078 | (nconc |
1079 | (mapcar | |
457d37ba SM |
1080 | (lambda (elem) |
1081 | (let ((str | |
1082 | ;; Don't modify the string itself, but a copy, since the | |
1083 | ;; the string may be read-only or used for other purposes. | |
1084 | ;; Furthermore, since `completions' may come from | |
1085 | ;; display-completion-list, `elem' may be a list. | |
1086 | (if (consp elem) | |
1087 | (car (setq elem (cons (copy-sequence (car elem)) | |
1088 | (cdr elem)))) | |
1089 | (setq elem (copy-sequence elem))))) | |
1bba1cfc SM |
1090 | (put-text-property 0 |
1091 | ;; If completion-boundaries returns incorrect | |
1092 | ;; values, all-completions may return strings | |
1093 | ;; that don't contain the prefix. | |
1094 | (min com-str-len (length str)) | |
457d37ba SM |
1095 | 'font-lock-face 'completions-common-part |
1096 | str) | |
1097 | (if (> (length str) com-str-len) | |
1098 | (put-text-property com-str-len (1+ com-str-len) | |
1099 | 'font-lock-face 'completions-first-difference | |
1100 | str))) | |
1101 | elem) | |
6138158d SM |
1102 | completions) |
1103 | base-size)))) | |
21622c6d | 1104 | |
7bc7f64d | 1105 | (defun display-completion-list (completions &optional common-substring) |
32bae13c SM |
1106 | "Display the list of completions, COMPLETIONS, using `standard-output'. |
1107 | Each element may be just a symbol or string | |
1108 | or may be a list of two strings to be printed as if concatenated. | |
1109 | If it is a list of two strings, the first is the actual completion | |
1110 | alternative, the second serves as annotation. | |
1111 | `standard-output' must be a buffer. | |
1112 | The actual completion alternatives, as inserted, are given `mouse-face' | |
1113 | properties of `highlight'. | |
1114 | At the end, this runs the normal hook `completion-setup-hook'. | |
1115 | It can find the completion buffer in `standard-output'. | |
7ce8dff2 | 1116 | |
72444d02 | 1117 | The obsolete optional arg COMMON-SUBSTRING, if non-nil, should be a string |
7ce8dff2 CY |
1118 | specifying a common substring for adding the faces |
1119 | `completions-first-difference' and `completions-common-part' to | |
7bc7f64d | 1120 | the completions buffer." |
6138158d SM |
1121 | (if common-substring |
1122 | (setq completions (completion-hilit-commonality | |
125f7951 SM |
1123 | completions (length common-substring) |
1124 | ;; We don't know the base-size. | |
1125 | nil))) | |
32bae13c SM |
1126 | (if (not (bufferp standard-output)) |
1127 | ;; This *never* (ever) happens, so there's no point trying to be clever. | |
1128 | (with-temp-buffer | |
1129 | (let ((standard-output (current-buffer)) | |
1130 | (completion-setup-hook nil)) | |
7bc7f64d | 1131 | (display-completion-list completions common-substring)) |
32bae13c SM |
1132 | (princ (buffer-string))) |
1133 | ||
d5e63715 SM |
1134 | (with-current-buffer standard-output |
1135 | (goto-char (point-max)) | |
1136 | (if (null completions) | |
1137 | (insert "There are no possible completions of what you have typed.") | |
1138 | (insert "Possible completions are:\n") | |
1139 | (completion--insert-strings completions)))) | |
e2947429 | 1140 | |
6138158d SM |
1141 | ;; The hilit used to be applied via completion-setup-hook, so there |
1142 | ;; may still be some code that uses completion-common-substring. | |
7ce8dff2 CY |
1143 | (with-no-warnings |
1144 | (let ((completion-common-substring common-substring)) | |
1145 | (run-hooks 'completion-setup-hook))) | |
32bae13c SM |
1146 | nil) |
1147 | ||
ab22be48 SM |
1148 | (defvar completion-annotate-function |
1149 | nil | |
1150 | ;; Note: there's a lot of scope as for when to add annotations and | |
1151 | ;; what annotations to add. E.g. completing-help.el allowed adding | |
1152 | ;; the first line of docstrings to M-x completion. But there's | |
1153 | ;; a tension, since such annotations, while useful at times, can | |
1154 | ;; actually drown the useful information. | |
1155 | ;; So completion-annotate-function should be used parsimoniously, or | |
1156 | ;; else only used upon a user's request (e.g. we could add a command | |
1157 | ;; to completion-list-mode to add annotations to the current | |
1158 | ;; completions). | |
1159 | "Function to add annotations in the *Completions* buffer. | |
1160 | The function takes a completion and should either return nil, or a string that | |
1161 | will be displayed next to the completion. The function can access the | |
1162 | completion table and predicates via `minibuffer-completion-table' and related | |
1163 | variables.") | |
1164 | ||
32bae13c SM |
1165 | (defun minibuffer-completion-help () |
1166 | "Display a list of possible completions of the current minibuffer contents." | |
1167 | (interactive) | |
1168 | (message "Making completion list...") | |
a647cb26 SM |
1169 | (let* ((start (field-beginning)) |
1170 | (end (field-end)) | |
1171 | (string (field-string)) | |
1172 | (completions (completion-all-completions | |
1173 | string | |
1174 | minibuffer-completion-table | |
1175 | minibuffer-completion-predicate | |
1176 | (- (point) (field-beginning))))) | |
32bae13c SM |
1177 | (message nil) |
1178 | (if (and completions | |
e2947429 SM |
1179 | (or (consp (cdr completions)) |
1180 | (not (equal (car completions) string)))) | |
d2c9fc42 SM |
1181 | (let* ((last (last completions)) |
1182 | (base-size (cdr last)) | |
1183 | ;; If the *Completions* buffer is shown in a new | |
1184 | ;; window, mark it as softly-dedicated, so bury-buffer in | |
1185 | ;; minibuffer-hide-completions will know whether to | |
1186 | ;; delete the window or not. | |
1187 | (display-buffer-mark-dedicated 'soft)) | |
1188 | (with-output-to-temp-buffer "*Completions*" | |
e2947429 SM |
1189 | ;; Remove the base-size tail because `sort' requires a properly |
1190 | ;; nil-terminated list. | |
1191 | (when last (setcdr last nil)) | |
ab22be48 SM |
1192 | (setq completions (sort completions 'string-lessp)) |
1193 | (when completion-annotate-function | |
1194 | (setq completions | |
1195 | (mapcar (lambda (s) | |
1196 | (let ((ann | |
1197 | (funcall completion-annotate-function s))) | |
1198 | (if ann (list s ann) s))) | |
1199 | completions))) | |
d5e63715 | 1200 | (with-current-buffer standard-output |
d2c9fc42 | 1201 | (set (make-local-variable 'completion-base-position) |
9bdba5f5 SM |
1202 | (list (+ start base-size) |
1203 | ;; FIXME: We should pay attention to completion | |
1204 | ;; boundaries here, but currently | |
1205 | ;; completion-all-completions does not give us the | |
1206 | ;; necessary information. | |
1207 | end))) | |
d5e63715 | 1208 | (display-completion-list completions))) |
32bae13c SM |
1209 | |
1210 | ;; If there are no completions, or if the current input is already the | |
1211 | ;; only possible completion, then hide (previous&stale) completions. | |
4d93a9e0 | 1212 | (minibuffer-hide-completions) |
32bae13c SM |
1213 | (ding) |
1214 | (minibuffer-message | |
1215 | (if completions "Sole completion" "No completions"))) | |
1216 | nil)) | |
1217 | ||
890429cc SM |
1218 | (defun minibuffer-hide-completions () |
1219 | "Get rid of an out-of-date *Completions* buffer." | |
1220 | ;; FIXME: We could/should use minibuffer-scroll-window here, but it | |
1221 | ;; can also point to the minibuffer-parent-window, so it's a bit tricky. | |
1222 | (let ((win (get-buffer-window "*Completions*" 0))) | |
1223 | (if win (with-selected-window win (bury-buffer))))) | |
1224 | ||
32bae13c SM |
1225 | (defun exit-minibuffer () |
1226 | "Terminate this minibuffer argument." | |
1227 | (interactive) | |
1228 | ;; If the command that uses this has made modifications in the minibuffer, | |
1229 | ;; we don't want them to cause deactivation of the mark in the original | |
1230 | ;; buffer. | |
1231 | ;; A better solution would be to make deactivate-mark buffer-local | |
1232 | ;; (or to turn it into a list of buffers, ...), but in the mean time, | |
1233 | ;; this should do the trick in most cases. | |
ba5ff07b | 1234 | (setq deactivate-mark nil) |
32bae13c SM |
1235 | (throw 'exit nil)) |
1236 | ||
1237 | (defun self-insert-and-exit () | |
1238 | "Terminate minibuffer input." | |
1239 | (interactive) | |
8989a920 | 1240 | (if (characterp last-command-event) |
32bae13c SM |
1241 | (call-interactively 'self-insert-command) |
1242 | (ding)) | |
1243 | (exit-minibuffer)) | |
1244 | ||
a185548b | 1245 | (defvar completion-in-region-functions nil |
d1200087 | 1246 | "Wrapper hook around `completion-in-region'. |
a185548b SM |
1247 | The functions on this special hook are called with 5 arguments: |
1248 | NEXT-FUN START END COLLECTION PREDICATE. | |
1249 | NEXT-FUN is a function of four arguments (START END COLLECTION PREDICATE) | |
c8de140b | 1250 | that performs the default operation. The other four arguments are like |
d1200087 | 1251 | the ones passed to `completion-in-region'. The functions on this hook |
a185548b SM |
1252 | are expected to perform completion on START..END using COLLECTION |
1253 | and PREDICATE, either by calling NEXT-FUN or by doing it themselves.") | |
1254 | ||
3e2d70fd SM |
1255 | (defvar completion-in-region--data nil) |
1256 | ||
a185548b SM |
1257 | (defun completion-in-region (start end collection &optional predicate) |
1258 | "Complete the text between START and END using COLLECTION. | |
3e38b2bd | 1259 | Return nil if there is no valid completion, else t. |
a185548b | 1260 | Point needs to be somewhere between START and END." |
a185548b SM |
1261 | (assert (<= start (point)) (<= (point) end)) |
1262 | ;; FIXME: undisplay the *Completions* buffer once the completion is done. | |
1263 | (with-wrapper-hook | |
d86d2721 SM |
1264 | ;; FIXME: Maybe we should use this hook to provide a "display |
1265 | ;; completions" operation as well. | |
a185548b SM |
1266 | completion-in-region-functions (start end collection predicate) |
1267 | (let ((minibuffer-completion-table collection) | |
1268 | (minibuffer-completion-predicate predicate) | |
1269 | (ol (make-overlay start end nil nil t))) | |
1270 | (overlay-put ol 'field 'completion) | |
3e2d70fd SM |
1271 | (completion-in-region-mode 1) |
1272 | (setq completion-in-region--data | |
1273 | (list (current-buffer) start end collection)) | |
a185548b SM |
1274 | (unwind-protect |
1275 | (call-interactively 'minibuffer-complete) | |
1276 | (delete-overlay ol))))) | |
8ba31f36 | 1277 | |
3e2d70fd SM |
1278 | (defvar completion-in-region-mode-map |
1279 | (let ((map (make-sparse-keymap))) | |
1280 | (define-key map "?" 'completion-help-at-point) | |
1281 | (define-key map "\t" 'completion-at-point) | |
1282 | map) | |
1283 | "Keymap activated during `completion-in-region'.") | |
1284 | ||
1285 | ;; It is difficult to know when to exit completion-in-region-mode (i.e. hide | |
1286 | ;; the *Completions*). | |
1287 | ;; - lisp-mode: never. | |
1288 | ;; - comint: only do it if you hit SPC at the right time. | |
1289 | ;; - pcomplete: pop it down on SPC or after some time-delay. | |
1290 | ;; - semantic: use a post-command-hook check similar to this one. | |
1291 | (defun completion-in-region--postch () | |
3e2d70fd SM |
1292 | (or unread-command-events ;Don't pop down the completions in the middle of |
1293 | ;mouse-drag-region/mouse-set-point. | |
1294 | (and completion-in-region--data | |
1295 | (and (eq (car completion-in-region--data) | |
1296 | (current-buffer)) | |
1297 | (>= (point) (nth 1 completion-in-region--data)) | |
1298 | (<= (point) | |
1299 | (save-excursion | |
1300 | (goto-char (nth 2 completion-in-region--data)) | |
1301 | (line-end-position))) | |
1302 | (let ((comp-data (run-hook-wrapped | |
1303 | 'completion-at-point-functions | |
1304 | ;; Only use the known-safe functions. | |
1305 | #'completion--capf-wrapper 'safe))) | |
1306 | (eq (car comp-data) | |
1307 | ;; We're still in the same completion field. | |
1308 | (nth 1 completion-in-region--data))))) | |
1309 | (completion-in-region-mode -1))) | |
1310 | ||
1311 | ;; (defalias 'completion-in-region--prech 'completion-in-region--postch) | |
1312 | ||
1313 | (define-minor-mode completion-in-region-mode | |
1314 | "Transient minor mode used during `completion-in-region'." | |
1315 | :global t | |
1316 | (setq completion-in-region--data nil) | |
1317 | ;; (remove-hook 'pre-command-hook #'completion-in-region--prech) | |
1318 | (remove-hook 'post-command-hook #'completion-in-region--postch) | |
1319 | (setq minor-mode-overriding-map-alist | |
1320 | (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist) | |
1321 | minor-mode-overriding-map-alist)) | |
1322 | (if (null completion-in-region-mode) | |
41ea9e48 CY |
1323 | (unless (equal "*Completions*" (buffer-name (window-buffer))) |
1324 | (minibuffer-hide-completions)) | |
3e2d70fd SM |
1325 | ;; (add-hook 'pre-command-hook #'completion-in-region--prech) |
1326 | (add-hook 'post-command-hook #'completion-in-region--postch) | |
1327 | (push `(completion-in-region-mode . ,completion-in-region-mode-map) | |
1328 | minor-mode-overriding-map-alist))) | |
1329 | ||
1330 | ;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it | |
1331 | ;; on minor-mode-overriding-map-alist instead. | |
1332 | (setq minor-mode-map-alist | |
1333 | (delq (assq 'completion-in-region-mode minor-mode-map-alist) | |
1334 | minor-mode-map-alist)) | |
1335 | ||
3a07ffce | 1336 | (defvar completion-at-point-functions '(tags-completion-at-point-function) |
51ef56c4 | 1337 | "Special hook to find the completion table for the thing at point. |
d86d2721 SM |
1338 | Each function on this hook is called in turns without any argument and should |
1339 | return either nil to mean that it is not applicable at point, | |
51ef56c4 SM |
1340 | or a function of no argument to perform completion (discouraged), |
1341 | or a list of the form (START END COLLECTION &rest PROPS) where | |
1342 | START and END delimit the entity to complete and should include point, | |
1343 | COLLECTION is the completion table to use to complete it, and | |
1344 | PROPS is a property list for additional information. | |
1345 | Currently supported properties are: | |
1346 | `:predicate' a predicate that completion candidates need to satisfy. | |
1347 | `:annotation-function' the value to use for `completion-annotate-function'.") | |
1348 | ||
3e2d70fd SM |
1349 | (defvar completion--capf-misbehave-funs nil |
1350 | "List of functions found on `completion-at-point-functions' that misbehave.") | |
1351 | (defvar completion--capf-safe-funs nil | |
1352 | "List of well-behaved functions found on `completion-at-point-functions'.") | |
1353 | ||
1354 | (defun completion--capf-wrapper (fun which) | |
1355 | (if (case which | |
1356 | (all t) | |
1357 | (safe (member fun completion--capf-safe-funs)) | |
1358 | (optimist (not (member fun completion--capf-misbehave-funs)))) | |
1359 | (let ((res (funcall fun))) | |
1360 | (cond | |
1361 | ((consp res) | |
1362 | (unless (member fun completion--capf-safe-funs) | |
1363 | (push fun completion--capf-safe-funs))) | |
1364 | ((not (or (listp res) (functionp res))) | |
1365 | (unless (member fun completion--capf-misbehave-funs) | |
1366 | (message | |
1367 | "Completion function %S uses a deprecated calling convention" fun) | |
1368 | (push fun completion--capf-misbehave-funs)))) | |
1369 | res))) | |
1370 | ||
67027b49 | 1371 | (defun completion-at-point () |
48111a85 | 1372 | "Perform completion on the text around point. |
67027b49 SM |
1373 | The completion method is determined by `completion-at-point-functions'." |
1374 | (interactive) | |
3e2d70fd SM |
1375 | (let ((res (run-hook-wrapped 'completion-at-point-functions |
1376 | #'completion--capf-wrapper 'all))) | |
67027b49 SM |
1377 | (cond |
1378 | ((functionp res) (funcall res)) | |
d86d2721 | 1379 | ((consp res) |
67027b49 SM |
1380 | (let* ((plist (nthcdr 3 res)) |
1381 | (start (nth 0 res)) | |
1382 | (end (nth 1 res)) | |
1383 | (completion-annotate-function | |
1384 | (or (plist-get plist :annotation-function) | |
1385 | completion-annotate-function))) | |
1386 | (completion-in-region start end (nth 2 res) | |
d86d2721 SM |
1387 | (plist-get plist :predicate)))) |
1388 | (res)))) ;Maybe completion already happened and the function returned t. | |
51ef56c4 | 1389 | |
3e2d70fd SM |
1390 | (defun completion-help-at-point () |
1391 | "Display the completions on the text around point. | |
1392 | The completion method is determined by `completion-at-point-functions'." | |
1393 | (interactive) | |
1394 | (let ((res (run-hook-wrapped 'completion-at-point-functions | |
1395 | ;; Ignore misbehaving functions. | |
1396 | #'completion--capf-wrapper 'optimist))) | |
1397 | (cond | |
1398 | ((functionp res) | |
1399 | (message "Don't know how to show completions for %S" res)) | |
1400 | ((consp res) | |
1401 | (let* ((plist (nthcdr 3 res)) | |
1402 | (minibuffer-completion-table (nth 2 res)) | |
1403 | (minibuffer-completion-predicate (plist-get plist :predicate)) | |
1404 | (completion-annotate-function | |
1405 | (or (plist-get plist :annotation-function) | |
1406 | completion-annotate-function)) | |
1407 | (ol (make-overlay (nth 0 res) (nth 1 res) nil nil t))) | |
1408 | ;; FIXME: We should somehow (ab)use completion-in-region-function or | |
1409 | ;; introduce a corresponding hook (plus another for word-completion, | |
1410 | ;; and another for force-completion, maybe?). | |
1411 | (overlay-put ol 'field 'completion) | |
1412 | (unwind-protect | |
1413 | (call-interactively 'minibuffer-completion-help) | |
1414 | (delete-overlay ol)))) | |
1415 | (res | |
1416 | ;; The hook function already performed completion :-( | |
1417 | ;; Not much we can do at this point. | |
1418 | nil) | |
1419 | (t (message "Nothing to complete at point"))))) | |
1420 | ||
1d4adede SM |
1421 | ;;; Key bindings. |
1422 | ||
1423 | (define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map | |
1424 | 'minibuffer-local-filename-must-match-map "23.1") | |
51ef56c4 | 1425 | |
a38313e1 SM |
1426 | (let ((map minibuffer-local-map)) |
1427 | (define-key map "\C-g" 'abort-recursive-edit) | |
1428 | (define-key map "\r" 'exit-minibuffer) | |
1429 | (define-key map "\n" 'exit-minibuffer)) | |
1430 | ||
1431 | (let ((map minibuffer-local-completion-map)) | |
1432 | (define-key map "\t" 'minibuffer-complete) | |
14c24780 SM |
1433 | ;; M-TAB is already abused for many other purposes, so we should find |
1434 | ;; another binding for it. | |
1435 | ;; (define-key map "\e\t" 'minibuffer-force-complete) | |
a38313e1 SM |
1436 | (define-key map " " 'minibuffer-complete-word) |
1437 | (define-key map "?" 'minibuffer-completion-help)) | |
1438 | ||
1439 | (let ((map minibuffer-local-must-match-map)) | |
1440 | (define-key map "\r" 'minibuffer-complete-and-exit) | |
1441 | (define-key map "\n" 'minibuffer-complete-and-exit)) | |
1442 | ||
1443 | (let ((map minibuffer-local-filename-completion-map)) | |
1444 | (define-key map " " nil)) | |
8ba31f36 | 1445 | (let ((map minibuffer-local-filename-must-match-map)) |
a38313e1 SM |
1446 | (define-key map " " nil)) |
1447 | ||
1448 | (let ((map minibuffer-local-ns-map)) | |
1449 | (define-key map " " 'exit-minibuffer) | |
1450 | (define-key map "\t" 'exit-minibuffer) | |
1451 | (define-key map "?" 'self-insert-and-exit)) | |
1452 | ||
1453 | ;;; Completion tables. | |
1454 | ||
34b67b0f SM |
1455 | (defun minibuffer--double-dollars (str) |
1456 | (replace-regexp-in-string "\\$" "$$" str)) | |
1457 | ||
21622c6d SM |
1458 | (defun completion--make-envvar-table () |
1459 | (mapcar (lambda (enventry) | |
9f3618b5 | 1460 | (substring enventry 0 (string-match-p "=" enventry))) |
21622c6d SM |
1461 | process-environment)) |
1462 | ||
a38313e1 SM |
1463 | (defconst completion--embedded-envvar-re |
1464 | (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" | |
1465 | "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) | |
1466 | ||
d032d5e7 | 1467 | (defun completion--embedded-envvar-table (string _pred action) |
c6432f1e SM |
1468 | "Completion table for envvars embedded in a string. |
1469 | The envvar syntax (and escaping) rules followed by this table are the | |
1470 | same as `substitute-in-file-name'." | |
1471 | ;; We ignore `pred', because the predicates passed to us via | |
1472 | ;; read-file-name-internal are not 100% correct and fail here: | |
1473 | ;; e.g. we get predicates like file-directory-p there, whereas the filename | |
1474 | ;; completed needs to be passed through substitute-in-file-name before it | |
1475 | ;; can be passed to file-directory-p. | |
528c56e2 SM |
1476 | (when (string-match completion--embedded-envvar-re string) |
1477 | (let* ((beg (or (match-beginning 2) (match-beginning 1))) | |
1478 | (table (completion--make-envvar-table)) | |
1479 | (prefix (substring string 0 beg))) | |
c6432f1e SM |
1480 | (cond |
1481 | ((eq action 'lambda) | |
1482 | ;; This table is expected to be used in conjunction with some | |
1483 | ;; other table that provides the "main" completion. Let the | |
1484 | ;; other table handle the test-completion case. | |
1485 | nil) | |
1486 | ((eq (car-safe action) 'boundaries) | |
03408648 SM |
1487 | ;; Only return boundaries if there's something to complete, |
1488 | ;; since otherwise when we're used in | |
1489 | ;; completion-table-in-turn, we could return boundaries and | |
1490 | ;; let some subsequent table return a list of completions. | |
1491 | ;; FIXME: Maybe it should rather be fixed in | |
1492 | ;; completion-table-in-turn instead, but it's difficult to | |
1493 | ;; do it efficiently there. | |
c6432f1e | 1494 | (when (try-completion (substring string beg) table nil) |
03408648 SM |
1495 | ;; Compute the boundaries of the subfield to which this |
1496 | ;; completion applies. | |
1497 | (let ((suffix (cdr action))) | |
1498 | (list* 'boundaries | |
1499 | (or (match-beginning 2) (match-beginning 1)) | |
1500 | (when (string-match "[^[:alnum:]_]" suffix) | |
c6432f1e SM |
1501 | (match-beginning 0)))))) |
1502 | (t | |
a38313e1 SM |
1503 | (if (eq (aref string (1- beg)) ?{) |
1504 | (setq table (apply-partially 'completion-table-with-terminator | |
1505 | "}" table))) | |
ab22be48 SM |
1506 | ;; Even if file-name completion is case-insensitive, we want |
1507 | ;; envvar completion to be case-sensitive. | |
1508 | (let ((completion-ignore-case nil)) | |
1509 | (completion-table-with-context | |
c6432f1e | 1510 | prefix table (substring string beg) nil action))))))) |
017c22fe | 1511 | |
528c56e2 SM |
1512 | (defun completion-file-name-table (string pred action) |
1513 | "Completion table for file names." | |
1514 | (ignore-errors | |
03408648 SM |
1515 | (cond |
1516 | ((eq (car-safe action) 'boundaries) | |
1517 | (let ((start (length (file-name-directory string))) | |
1518 | (end (string-match-p "/" (cdr action)))) | |
1519 | (list* 'boundaries | |
1520 | ;; if `string' is "C:" in w32, (file-name-directory string) | |
1521 | ;; returns "C:/", so `start' is 3 rather than 2. | |
1522 | ;; Not quite sure what is The Right Fix, but clipping it | |
1523 | ;; back to 2 will work for this particular case. We'll | |
1524 | ;; see if we can come up with a better fix when we bump | |
1525 | ;; into more such problematic cases. | |
1526 | (min start (length string)) end))) | |
1527 | ||
1528 | ((eq action 'lambda) | |
1529 | (if (zerop (length string)) | |
1530 | nil ;Not sure why it's here, but it probably doesn't harm. | |
1531 | (funcall (or pred 'file-exists-p) string))) | |
528c56e2 | 1532 | |
03408648 | 1533 | (t |
528c56e2 SM |
1534 | (let* ((name (file-name-nondirectory string)) |
1535 | (specdir (file-name-directory string)) | |
1536 | (realdir (or specdir default-directory))) | |
017c22fe | 1537 | |
03408648 SM |
1538 | (cond |
1539 | ((null action) | |
528c56e2 SM |
1540 | (let ((comp (file-name-completion name realdir pred))) |
1541 | (if (stringp comp) | |
1542 | (concat specdir comp) | |
1543 | comp))) | |
017c22fe | 1544 | |
03408648 SM |
1545 | ((eq action t) |
1546 | (let ((all (file-name-all-completions name realdir))) | |
e2947429 | 1547 | |
03408648 | 1548 | ;; Check the predicate, if necessary. |
528c56e2 | 1549 | (unless (memq pred '(nil file-exists-p)) |
03408648 SM |
1550 | (let ((comp ()) |
1551 | (pred | |
528c56e2 | 1552 | (if (eq pred 'file-directory-p) |
03408648 SM |
1553 | ;; Brute-force speed up for directory checking: |
1554 | ;; Discard strings which don't end in a slash. | |
1555 | (lambda (s) | |
1556 | (let ((len (length s))) | |
1557 | (and (> len 0) (eq (aref s (1- len)) ?/)))) | |
1558 | ;; Must do it the hard (and slow) way. | |
528c56e2 SM |
1559 | pred))) |
1560 | (let ((default-directory (expand-file-name realdir))) | |
03408648 SM |
1561 | (dolist (tem all) |
1562 | (if (funcall pred tem) (push tem comp)))) | |
1563 | (setq all (nreverse comp)))) | |
e2947429 | 1564 | |
528c56e2 SM |
1565 | all)))))))) |
1566 | ||
1567 | (defvar read-file-name-predicate nil | |
1568 | "Current predicate used by `read-file-name-internal'.") | |
1569 | (make-obsolete-variable 'read-file-name-predicate | |
1570 | "use the regular PRED argument" "23.2") | |
1571 | ||
1572 | (defun completion--file-name-table (string pred action) | |
1573 | "Internal subroutine for `read-file-name'. Do not call this. | |
1574 | This is a completion table for file names, like `completion-file-name-table' | |
1575 | except that it passes the file name through `substitute-in-file-name'." | |
1576 | (cond | |
1577 | ((eq (car-safe action) 'boundaries) | |
1578 | ;; For the boundaries, we can't really delegate to | |
5feec8ca SM |
1579 | ;; substitute-in-file-name+completion-file-name-table and then fix |
1580 | ;; them up (as we do for the other actions), because it would | |
1581 | ;; require us to track the relationship between `str' and | |
528c56e2 | 1582 | ;; `string', which is difficult. And in any case, if |
5feec8ca SM |
1583 | ;; substitute-in-file-name turns "fo-$TO-ba" into "fo-o/b-ba", |
1584 | ;; there's no way for us to return proper boundaries info, because | |
1585 | ;; the boundary is not (yet) in `string'. | |
1586 | ;; | |
1587 | ;; FIXME: Actually there is a way to return correct boundaries | |
1588 | ;; info, at the condition of modifying the all-completions | |
1589 | ;; return accordingly. But for now, let's not bother. | |
1590 | (completion-file-name-table string pred action)) | |
34b67b0f | 1591 | |
5feec8ca | 1592 | (t |
528c56e2 SM |
1593 | (let* ((default-directory |
1594 | (if (stringp pred) | |
1595 | ;; It used to be that `pred' was abused to pass `dir' | |
1596 | ;; as an argument. | |
1597 | (prog1 (file-name-as-directory (expand-file-name pred)) | |
1598 | (setq pred nil)) | |
1599 | default-directory)) | |
1600 | (str (condition-case nil | |
1601 | (substitute-in-file-name string) | |
1602 | (error string))) | |
1603 | (comp (completion-file-name-table | |
48111a85 CY |
1604 | str |
1605 | (with-no-warnings (or pred read-file-name-predicate)) | |
1606 | action))) | |
528c56e2 SM |
1607 | |
1608 | (cond | |
1609 | ((stringp comp) | |
1610 | ;; Requote the $s before returning the completion. | |
1611 | (minibuffer--double-dollars comp)) | |
1612 | ((and (null action) comp | |
1613 | ;; Requote the $s before checking for changes. | |
1614 | (setq str (minibuffer--double-dollars str)) | |
1615 | (not (string-equal string str))) | |
1616 | ;; If there's no real completion, but substitute-in-file-name | |
1617 | ;; changed the string, then return the new string. | |
1618 | str) | |
1619 | (t comp)))))) | |
34b67b0f | 1620 | |
21622c6d | 1621 | (defalias 'read-file-name-internal |
017c22fe | 1622 | (completion-table-in-turn 'completion--embedded-envvar-table |
88893215 | 1623 | 'completion--file-name-table) |
21622c6d | 1624 | "Internal subroutine for `read-file-name'. Do not call this.") |
34b67b0f | 1625 | |
b16ac1ec LL |
1626 | (defvar read-file-name-function 'read-file-name-default |
1627 | "The function called by `read-file-name' to do its work. | |
1628 | It should accept the same arguments as `read-file-name'.") | |
dbd50d4b | 1629 | |
dbd50d4b | 1630 | (defcustom read-file-name-completion-ignore-case |
9f6336e8 | 1631 | (if (memq system-type '(ms-dos windows-nt darwin cygwin)) |
dbd50d4b SM |
1632 | t nil) |
1633 | "Non-nil means when reading a file name completion ignores case." | |
1634 | :group 'minibuffer | |
1635 | :type 'boolean | |
1636 | :version "22.1") | |
1637 | ||
1638 | (defcustom insert-default-directory t | |
1639 | "Non-nil means when reading a filename start with default dir in minibuffer. | |
1640 | ||
1641 | When the initial minibuffer contents show a name of a file or a directory, | |
1642 | typing RETURN without editing the initial contents is equivalent to typing | |
1643 | the default file name. | |
1644 | ||
1645 | If this variable is non-nil, the minibuffer contents are always | |
1646 | initially non-empty, and typing RETURN without editing will fetch the | |
1647 | default name, if one is provided. Note however that this default name | |
1648 | is not necessarily the same as initial contents inserted in the minibuffer, | |
1649 | if the initial contents is just the default directory. | |
1650 | ||
1651 | If this variable is nil, the minibuffer often starts out empty. In | |
1652 | that case you may have to explicitly fetch the next history element to | |
1653 | request the default name; typing RETURN without editing will leave | |
1654 | the minibuffer empty. | |
1655 | ||
1656 | For some commands, exiting with an empty minibuffer has a special meaning, | |
1657 | such as making the current buffer visit no file in the case of | |
1658 | `set-visited-file-name'." | |
1659 | :group 'minibuffer | |
1660 | :type 'boolean) | |
1661 | ||
4e3870f5 GM |
1662 | ;; Not always defined, but only called if next-read-file-uses-dialog-p says so. |
1663 | (declare-function x-file-dialog "xfns.c" | |
1664 | (prompt dir &optional default-filename mustmatch only-dir-p)) | |
1665 | ||
b16ac1ec | 1666 | (defun read-file-name--defaults (&optional dir initial) |
7d371eac JL |
1667 | (let ((default |
1668 | (cond | |
1669 | ;; With non-nil `initial', use `dir' as the first default. | |
1670 | ;; Essentially, this mean reversing the normal order of the | |
1671 | ;; current directory name and the current file name, i.e. | |
1672 | ;; 1. with normal file reading: | |
1673 | ;; 1.1. initial input is the current directory | |
1674 | ;; 1.2. the first default is the current file name | |
1675 | ;; 2. with non-nil `initial' (e.g. for `find-alternate-file'): | |
1676 | ;; 2.2. initial input is the current file name | |
1677 | ;; 2.1. the first default is the current directory | |
1678 | (initial (abbreviate-file-name dir)) | |
1679 | ;; In file buffers, try to get the current file name | |
1680 | (buffer-file-name | |
1681 | (abbreviate-file-name buffer-file-name)))) | |
1682 | (file-name-at-point | |
1683 | (run-hook-with-args-until-success 'file-name-at-point-functions))) | |
1684 | (when file-name-at-point | |
1685 | (setq default (delete-dups | |
1686 | (delete "" (delq nil (list file-name-at-point default)))))) | |
1687 | ;; Append new defaults to the end of existing `minibuffer-default'. | |
1688 | (append | |
1689 | (if (listp minibuffer-default) minibuffer-default (list minibuffer-default)) | |
1690 | (if (listp default) default (list default))))) | |
1691 | ||
dbd50d4b SM |
1692 | (defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate) |
1693 | "Read file name, prompting with PROMPT and completing in directory DIR. | |
1694 | Value is not expanded---you must call `expand-file-name' yourself. | |
1695 | Default name to DEFAULT-FILENAME if user exits the minibuffer with | |
1696 | the same non-empty string that was inserted by this function. | |
1697 | (If DEFAULT-FILENAME is omitted, the visited file name is used, | |
032c3399 JL |
1698 | except that if INITIAL is specified, that combined with DIR is used. |
1699 | If DEFAULT-FILENAME is a list of file names, the first file name is used.) | |
dbd50d4b SM |
1700 | If the user exits with an empty minibuffer, this function returns |
1701 | an empty string. (This can only happen if the user erased the | |
1702 | pre-inserted contents or if `insert-default-directory' is nil.) | |
846b6eba CY |
1703 | |
1704 | Fourth arg MUSTMATCH can take the following values: | |
1705 | - nil means that the user can exit with any input. | |
1706 | - t means that the user is not allowed to exit unless | |
1707 | the input is (or completes to) an existing file. | |
1708 | - `confirm' means that the user can exit with any input, but she needs | |
1709 | to confirm her choice if the input is not an existing file. | |
1710 | - `confirm-after-completion' means that the user can exit with any | |
1711 | input, but she needs to confirm her choice if she called | |
1712 | `minibuffer-complete' right before `minibuffer-complete-and-exit' | |
1713 | and the input is not an existing file. | |
1714 | - anything else behaves like t except that typing RET does not exit if it | |
1715 | does non-null completion. | |
1716 | ||
dbd50d4b | 1717 | Fifth arg INITIAL specifies text to start with. |
846b6eba | 1718 | |
dbd50d4b SM |
1719 | If optional sixth arg PREDICATE is non-nil, possible completions and |
1720 | the resulting file name must satisfy (funcall PREDICATE NAME). | |
1721 | DIR should be an absolute directory name. It defaults to the value of | |
1722 | `default-directory'. | |
1723 | ||
846b6eba CY |
1724 | If this command was invoked with the mouse, use a graphical file |
1725 | dialog if `use-dialog-box' is non-nil, and the window system or X | |
8368c14e CY |
1726 | toolkit in use provides a file dialog box, and DIR is not a |
1727 | remote file. For graphical file dialogs, any the special values | |
1728 | of MUSTMATCH; `confirm' and `confirm-after-completion' are | |
1729 | treated as equivalent to nil. | |
dbd50d4b SM |
1730 | |
1731 | See also `read-file-name-completion-ignore-case' | |
1732 | and `read-file-name-function'." | |
b16ac1ec LL |
1733 | (funcall (or read-file-name-function #'read-file-name-default) |
1734 | prompt dir default-filename mustmatch initial predicate)) | |
1735 | ||
1736 | (defun read-file-name-default (prompt &optional dir default-filename mustmatch initial predicate) | |
1737 | "Default method for reading file names. | |
1738 | See `read-file-name' for the meaning of the arguments." | |
dbd50d4b SM |
1739 | (unless dir (setq dir default-directory)) |
1740 | (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir))) | |
1741 | (unless default-filename | |
1742 | (setq default-filename (if initial (expand-file-name initial dir) | |
1743 | buffer-file-name))) | |
1744 | ;; If dir starts with user's homedir, change that to ~. | |
1745 | (setq dir (abbreviate-file-name dir)) | |
1746 | ;; Likewise for default-filename. | |
e8a5fe3e | 1747 | (if default-filename |
032c3399 JL |
1748 | (setq default-filename |
1749 | (if (consp default-filename) | |
1750 | (mapcar 'abbreviate-file-name default-filename) | |
1751 | (abbreviate-file-name default-filename)))) | |
dbd50d4b SM |
1752 | (let ((insdef (cond |
1753 | ((and insert-default-directory (stringp dir)) | |
1754 | (if initial | |
1755 | (cons (minibuffer--double-dollars (concat dir initial)) | |
1756 | (length (minibuffer--double-dollars dir))) | |
1757 | (minibuffer--double-dollars dir))) | |
1758 | (initial (cons (minibuffer--double-dollars initial) 0))))) | |
1759 | ||
03408648 SM |
1760 | (let ((completion-ignore-case read-file-name-completion-ignore-case) |
1761 | (minibuffer-completing-file-name t) | |
1762 | (pred (or predicate 'file-exists-p)) | |
1763 | (add-to-history nil)) | |
1764 | ||
1765 | (let* ((val | |
1766 | (if (or (not (next-read-file-uses-dialog-p)) | |
1767 | ;; Graphical file dialogs can't handle remote | |
1768 | ;; files (Bug#99). | |
1769 | (file-remote-p dir)) | |
1770 | ;; We used to pass `dir' to `read-file-name-internal' by | |
1771 | ;; abusing the `predicate' argument. It's better to | |
1772 | ;; just use `default-directory', but in order to avoid | |
1773 | ;; changing `default-directory' in the current buffer, | |
1774 | ;; we don't let-bind it. | |
1775 | (let ((dir (file-name-as-directory | |
1776 | (expand-file-name dir)))) | |
1777 | (minibuffer-with-setup-hook | |
1778 | (lambda () | |
1779 | (setq default-directory dir) | |
1780 | ;; When the first default in `minibuffer-default' | |
1781 | ;; duplicates initial input `insdef', | |
1782 | ;; reset `minibuffer-default' to nil. | |
1783 | (when (equal (or (car-safe insdef) insdef) | |
1784 | (or (car-safe minibuffer-default) | |
1785 | minibuffer-default)) | |
1786 | (setq minibuffer-default | |
1787 | (cdr-safe minibuffer-default))) | |
1788 | ;; On the first request on `M-n' fill | |
1789 | ;; `minibuffer-default' with a list of defaults | |
1790 | ;; relevant for file-name reading. | |
1791 | (set (make-local-variable 'minibuffer-default-add-function) | |
1792 | (lambda () | |
1793 | (with-current-buffer | |
1794 | (window-buffer (minibuffer-selected-window)) | |
b16ac1ec | 1795 | (read-file-name--defaults dir initial))))) |
03408648 SM |
1796 | (completing-read prompt 'read-file-name-internal |
1797 | pred mustmatch insdef | |
1798 | 'file-name-history default-filename))) | |
1799 | ;; If DEFAULT-FILENAME not supplied and DIR contains | |
1800 | ;; a file name, split it. | |
1801 | (let ((file (file-name-nondirectory dir)) | |
1802 | ;; When using a dialog, revert to nil and non-nil | |
1803 | ;; interpretation of mustmatch. confirm options | |
1804 | ;; need to be interpreted as nil, otherwise | |
1805 | ;; it is impossible to create new files using | |
1806 | ;; dialogs with the default settings. | |
1807 | (dialog-mustmatch | |
1808 | (not (memq mustmatch | |
1809 | '(nil confirm confirm-after-completion))))) | |
1810 | (when (and (not default-filename) | |
1811 | (not (zerop (length file)))) | |
1812 | (setq default-filename file) | |
1813 | (setq dir (file-name-directory dir))) | |
1814 | (when default-filename | |
1815 | (setq default-filename | |
1816 | (expand-file-name (if (consp default-filename) | |
1817 | (car default-filename) | |
1818 | default-filename) | |
1819 | dir))) | |
1820 | (setq add-to-history t) | |
1821 | (x-file-dialog prompt dir default-filename | |
1822 | dialog-mustmatch | |
1823 | (eq predicate 'file-directory-p))))) | |
1824 | ||
1825 | (replace-in-history (eq (car-safe file-name-history) val))) | |
1826 | ;; If completing-read returned the inserted default string itself | |
1827 | ;; (rather than a new string with the same contents), | |
1828 | ;; it has to mean that the user typed RET with the minibuffer empty. | |
1829 | ;; In that case, we really want to return "" | |
1830 | ;; so that commands such as set-visited-file-name can distinguish. | |
1831 | (when (consp default-filename) | |
1832 | (setq default-filename (car default-filename))) | |
1833 | (when (eq val default-filename) | |
1834 | ;; In this case, completing-read has not added an element | |
1835 | ;; to the history. Maybe we should. | |
1836 | (if (not replace-in-history) | |
1837 | (setq add-to-history t)) | |
1838 | (setq val "")) | |
1839 | (unless val (error "No file name specified")) | |
1840 | ||
1841 | (if (and default-filename | |
1842 | (string-equal val (if (consp insdef) (car insdef) insdef))) | |
1843 | (setq val default-filename)) | |
1844 | (setq val (substitute-in-file-name val)) | |
1845 | ||
1846 | (if replace-in-history | |
1847 | ;; Replace what Fcompleting_read added to the history | |
1848 | ;; with what we will actually return. As an exception, | |
1849 | ;; if that's the same as the second item in | |
1850 | ;; file-name-history, it's really a repeat (Bug#4657). | |
1851 | (let ((val1 (minibuffer--double-dollars val))) | |
1852 | (if history-delete-duplicates | |
1853 | (setcdr file-name-history | |
1854 | (delete val1 (cdr file-name-history)))) | |
1855 | (if (string= val1 (cadr file-name-history)) | |
1856 | (pop file-name-history) | |
1857 | (setcar file-name-history val1))) | |
1858 | (if add-to-history | |
1859 | ;; Add the value to the history--but not if it matches | |
1860 | ;; the last value already there. | |
dbd50d4b | 1861 | (let ((val1 (minibuffer--double-dollars val))) |
03408648 SM |
1862 | (unless (and (consp file-name-history) |
1863 | (equal (car file-name-history) val1)) | |
1864 | (setq file-name-history | |
1865 | (cons val1 | |
1866 | (if history-delete-duplicates | |
1867 | (delete val1 file-name-history) | |
1868 | file-name-history))))))) | |
b16ac1ec | 1869 | val)))) |
dbd50d4b | 1870 | |
8b04c0ae JL |
1871 | (defun internal-complete-buffer-except (&optional buffer) |
1872 | "Perform completion on all buffers excluding BUFFER. | |
e35b3063 | 1873 | BUFFER nil or omitted means use the current buffer. |
8b04c0ae | 1874 | Like `internal-complete-buffer', but removes BUFFER from the completion list." |
a647cb26 | 1875 | (let ((except (if (stringp buffer) buffer (buffer-name buffer)))) |
8b04c0ae JL |
1876 | (apply-partially 'completion-table-with-predicate |
1877 | 'internal-complete-buffer | |
1878 | (lambda (name) | |
1879 | (not (equal (if (consp name) (car name) name) except))) | |
1880 | nil))) | |
1881 | ||
eee6de73 | 1882 | ;;; Old-style completion, used in Emacs-21 and Emacs-22. |
19c04f39 | 1883 | |
d032d5e7 | 1884 | (defun completion-emacs21-try-completion (string table pred _point) |
19c04f39 SM |
1885 | (let ((completion (try-completion string table pred))) |
1886 | (if (stringp completion) | |
1887 | (cons completion (length completion)) | |
1888 | completion))) | |
1889 | ||
d032d5e7 | 1890 | (defun completion-emacs21-all-completions (string table pred _point) |
6138158d | 1891 | (completion-hilit-commonality |
eee6de73 | 1892 | (all-completions string table pred) |
125f7951 SM |
1893 | (length string) |
1894 | (car (completion-boundaries string table pred "")))) | |
19c04f39 | 1895 | |
19c04f39 SM |
1896 | (defun completion-emacs22-try-completion (string table pred point) |
1897 | (let ((suffix (substring string point)) | |
1898 | (completion (try-completion (substring string 0 point) table pred))) | |
1899 | (if (not (stringp completion)) | |
1900 | completion | |
1901 | ;; Merge a trailing / in completion with a / after point. | |
1902 | ;; We used to only do it for word completion, but it seems to make | |
1903 | ;; sense for all completions. | |
34200787 SM |
1904 | ;; Actually, claiming this feature was part of Emacs-22 completion |
1905 | ;; is pushing it a bit: it was only done in minibuffer-completion-word, | |
1906 | ;; which was (by default) not bound during file completion, where such | |
1907 | ;; slashes are most likely to occur. | |
1908 | (if (and (not (zerop (length completion))) | |
1909 | (eq ?/ (aref completion (1- (length completion)))) | |
19c04f39 SM |
1910 | (not (zerop (length suffix))) |
1911 | (eq ?/ (aref suffix 0))) | |
34200787 SM |
1912 | ;; This leaves point after the / . |
1913 | (setq suffix (substring suffix 1))) | |
19c04f39 SM |
1914 | (cons (concat completion suffix) (length completion))))) |
1915 | ||
1916 | (defun completion-emacs22-all-completions (string table pred point) | |
125f7951 SM |
1917 | (let ((beforepoint (substring string 0 point))) |
1918 | (completion-hilit-commonality | |
1919 | (all-completions beforepoint table pred) | |
1920 | point | |
1921 | (car (completion-boundaries beforepoint table pred ""))))) | |
19c04f39 | 1922 | |
eee6de73 SM |
1923 | ;;; Basic completion. |
1924 | ||
1925 | (defun completion--merge-suffix (completion point suffix) | |
1926 | "Merge end of COMPLETION with beginning of SUFFIX. | |
1927 | Simple generalization of the \"merge trailing /\" done in Emacs-22. | |
1928 | Return the new suffix." | |
1929 | (if (and (not (zerop (length suffix))) | |
1930 | (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix) | |
1931 | ;; Make sure we don't compress things to less | |
1932 | ;; than we started with. | |
1933 | point) | |
1934 | ;; Just make sure we didn't match some other \n. | |
1935 | (eq (match-end 1) (length completion))) | |
1936 | (substring suffix (- (match-end 1) (match-beginning 1))) | |
1937 | ;; Nothing to merge. | |
1938 | suffix)) | |
1939 | ||
00278747 SM |
1940 | (defun completion-basic--pattern (beforepoint afterpoint bounds) |
1941 | (delete | |
1942 | "" (list (substring beforepoint (car bounds)) | |
1943 | 'point | |
1944 | (substring afterpoint 0 (cdr bounds))))) | |
1945 | ||
34200787 | 1946 | (defun completion-basic-try-completion (string table pred point) |
a647cb26 SM |
1947 | (let* ((beforepoint (substring string 0 point)) |
1948 | (afterpoint (substring string point)) | |
1949 | (bounds (completion-boundaries beforepoint table pred afterpoint))) | |
86011bf2 SM |
1950 | (if (zerop (cdr bounds)) |
1951 | ;; `try-completion' may return a subtly different result | |
1952 | ;; than `all+merge', so try to use it whenever possible. | |
1953 | (let ((completion (try-completion beforepoint table pred))) | |
1954 | (if (not (stringp completion)) | |
1955 | completion | |
1956 | (cons | |
1957 | (concat completion | |
1958 | (completion--merge-suffix completion point afterpoint)) | |
1959 | (length completion)))) | |
a647cb26 SM |
1960 | (let* ((suffix (substring afterpoint (cdr bounds))) |
1961 | (prefix (substring beforepoint 0 (car bounds))) | |
1962 | (pattern (delete | |
1963 | "" (list (substring beforepoint (car bounds)) | |
1964 | 'point | |
1965 | (substring afterpoint 0 (cdr bounds))))) | |
1966 | (all (completion-pcm--all-completions prefix pattern table pred))) | |
86011bf2 SM |
1967 | (if minibuffer-completing-file-name |
1968 | (setq all (completion-pcm--filename-try-filter all))) | |
1969 | (completion-pcm--merge-try pattern all prefix suffix))))) | |
1970 | ||
1971 | (defun completion-basic-all-completions (string table pred point) | |
a647cb26 SM |
1972 | (let* ((beforepoint (substring string 0 point)) |
1973 | (afterpoint (substring string point)) | |
1974 | (bounds (completion-boundaries beforepoint table pred afterpoint)) | |
d032d5e7 | 1975 | ;; (suffix (substring afterpoint (cdr bounds))) |
a647cb26 SM |
1976 | (prefix (substring beforepoint 0 (car bounds))) |
1977 | (pattern (delete | |
1978 | "" (list (substring beforepoint (car bounds)) | |
1979 | 'point | |
1980 | (substring afterpoint 0 (cdr bounds))))) | |
1981 | (all (completion-pcm--all-completions prefix pattern table pred))) | |
125f7951 | 1982 | (completion-hilit-commonality all point (car bounds)))) |
19c04f39 | 1983 | |
34200787 SM |
1984 | ;;; Partial-completion-mode style completion. |
1985 | ||
890429cc SM |
1986 | (defvar completion-pcm--delim-wild-regex nil |
1987 | "Regular expression matching delimiters controlling the partial-completion. | |
1988 | Typically, this regular expression simply matches a delimiter, meaning | |
1989 | that completion can add something at (match-beginning 0), but if it has | |
1990 | a submatch 1, then completion can add something at (match-end 1). | |
1991 | This is used when the delimiter needs to be of size zero (e.g. the transition | |
1992 | from lowercase to uppercase characters).") | |
34200787 SM |
1993 | |
1994 | (defun completion-pcm--prepare-delim-re (delims) | |
1995 | (setq completion-pcm--delim-wild-regex (concat "[" delims "*]"))) | |
1996 | ||
365b9a62 | 1997 | (defcustom completion-pcm-word-delimiters "-_./: " |
34200787 SM |
1998 | "A string of characters treated as word delimiters for completion. |
1999 | Some arcane rules: | |
2000 | If `]' is in this string, it must come first. | |
2001 | If `^' is in this string, it must not come first. | |
2002 | If `-' is in this string, it must come first or right after `]'. | |
2003 | In other words, if S is this string, then `[S]' must be a valid Emacs regular | |
2004 | expression (not containing character ranges like `a-z')." | |
2005 | :set (lambda (symbol value) | |
2006 | (set-default symbol value) | |
2007 | ;; Refresh other vars. | |
2008 | (completion-pcm--prepare-delim-re value)) | |
2009 | :initialize 'custom-initialize-reset | |
26c548b0 | 2010 | :group 'minibuffer |
34200787 SM |
2011 | :type 'string) |
2012 | ||
79ccd68f SM |
2013 | (defcustom completion-pcm-complete-word-inserts-delimiters nil |
2014 | "Treat the SPC or - inserted by `minibuffer-complete-word' as delimiters. | |
2015 | Those chars are treated as delimiters iff this variable is non-nil. | |
2016 | I.e. if non-nil, M-x SPC will just insert a \"-\" in the minibuffer, whereas | |
2017 | if nil, it will list all possible commands in *Completions* because none of | |
2018 | the commands start with a \"-\" or a SPC." | |
2019 | :type 'boolean) | |
2020 | ||
34200787 | 2021 | (defun completion-pcm--pattern-trivial-p (pattern) |
1bba1cfc SM |
2022 | (and (stringp (car pattern)) |
2023 | ;; It can be followed by `point' and "" and still be trivial. | |
2024 | (let ((trivial t)) | |
2025 | (dolist (elem (cdr pattern)) | |
2026 | (unless (member elem '(point "")) | |
2027 | (setq trivial nil))) | |
2028 | trivial))) | |
34200787 | 2029 | |
a38313e1 SM |
2030 | (defun completion-pcm--string->pattern (string &optional point) |
2031 | "Split STRING into a pattern. | |
34200787 | 2032 | A pattern is a list where each element is either a string |
79ccd68f | 2033 | or a symbol chosen among `any', `star', `point', `prefix'." |
a38313e1 SM |
2034 | (if (and point (< point (length string))) |
2035 | (let ((prefix (substring string 0 point)) | |
2036 | (suffix (substring string point))) | |
34200787 SM |
2037 | (append (completion-pcm--string->pattern prefix) |
2038 | '(point) | |
2039 | (completion-pcm--string->pattern suffix))) | |
3e2d70fd SM |
2040 | (let* ((pattern nil) |
2041 | (p 0) | |
2042 | (p0 p)) | |
26c548b0 | 2043 | |
890429cc SM |
2044 | (while (and (setq p (string-match completion-pcm--delim-wild-regex |
2045 | string p)) | |
79ccd68f SM |
2046 | (or completion-pcm-complete-word-inserts-delimiters |
2047 | ;; If the char was added by minibuffer-complete-word, | |
2048 | ;; then don't treat it as a delimiter, otherwise | |
2049 | ;; "M-x SPC" ends up inserting a "-" rather than listing | |
2050 | ;; all completions. | |
2051 | (not (get-text-property p 'completion-try-word string)))) | |
890429cc SM |
2052 | ;; Usually, completion-pcm--delim-wild-regex matches a delimiter, |
2053 | ;; meaning that something can be added *before* it, but it can also | |
2054 | ;; match a prefix and postfix, in which case something can be added | |
2055 | ;; in-between (e.g. match [[:lower:]][[:upper:]]). | |
2056 | ;; This is determined by the presence of a submatch-1 which delimits | |
2057 | ;; the prefix. | |
2058 | (if (match-end 1) (setq p (match-end 1))) | |
a38313e1 SM |
2059 | (push (substring string p0 p) pattern) |
2060 | (if (eq (aref string p) ?*) | |
34200787 SM |
2061 | (progn |
2062 | (push 'star pattern) | |
2063 | (setq p0 (1+ p))) | |
2064 | (push 'any pattern) | |
2065 | (setq p0 p)) | |
2066 | (incf p)) | |
2067 | ||
2068 | ;; An empty string might be erroneously added at the beginning. | |
2069 | ;; It should be avoided properly, but it's so easy to remove it here. | |
a38313e1 | 2070 | (delete "" (nreverse (cons (substring string p0) pattern)))))) |
34200787 SM |
2071 | |
2072 | (defun completion-pcm--pattern->regex (pattern &optional group) | |
a38313e1 | 2073 | (let ((re |
ab22be48 SM |
2074 | (concat "\\`" |
2075 | (mapconcat | |
2076 | (lambda (x) | |
79ccd68f SM |
2077 | (cond |
2078 | ((stringp x) (regexp-quote x)) | |
8a67c70e SM |
2079 | ((if (consp group) (memq x group) group) "\\(.*?\\)") |
2080 | (t ".*?"))) | |
ab22be48 | 2081 | pattern |
15c72e1d | 2082 | "")))) |
a38313e1 SM |
2083 | ;; Avoid pathological backtracking. |
2084 | (while (string-match "\\.\\*\\?\\(?:\\\\[()]\\)*\\(\\.\\*\\?\\)" re) | |
2085 | (setq re (replace-match "" t t re 1))) | |
2086 | re)) | |
34200787 | 2087 | |
a38313e1 | 2088 | (defun completion-pcm--all-completions (prefix pattern table pred) |
34200787 | 2089 | "Find all completions for PATTERN in TABLE obeying PRED. |
26c548b0 | 2090 | PATTERN is as returned by `completion-pcm--string->pattern'." |
125f7951 SM |
2091 | ;; (assert (= (car (completion-boundaries prefix table pred "")) |
2092 | ;; (length prefix))) | |
34200787 SM |
2093 | ;; Find an initial list of possible completions. |
2094 | (if (completion-pcm--pattern-trivial-p pattern) | |
2095 | ||
2096 | ;; Minibuffer contains no delimiters -- simple case! | |
125f7951 | 2097 | (all-completions (concat prefix (car pattern)) table pred) |
26c548b0 | 2098 | |
34200787 SM |
2099 | ;; Use all-completions to do an initial cull. This is a big win, |
2100 | ;; since all-completions is written in C! | |
2101 | (let* (;; Convert search pattern to a standard regular expression. | |
2102 | (regex (completion-pcm--pattern->regex pattern)) | |
15c72e1d SM |
2103 | (case-fold-search completion-ignore-case) |
2104 | (completion-regexp-list (cons regex completion-regexp-list)) | |
34200787 | 2105 | (compl (all-completions |
a38313e1 | 2106 | (concat prefix (if (stringp (car pattern)) (car pattern) "")) |
125f7951 | 2107 | table pred))) |
34200787 SM |
2108 | (if (not (functionp table)) |
2109 | ;; The internal functions already obeyed completion-regexp-list. | |
2110 | compl | |
15c72e1d | 2111 | (let ((poss ())) |
34200787 | 2112 | (dolist (c compl) |
9f3618b5 | 2113 | (when (string-match-p regex c) (push c poss))) |
34200787 SM |
2114 | poss))))) |
2115 | ||
7372b09c SM |
2116 | (defun completion-pcm--hilit-commonality (pattern completions) |
2117 | (when completions | |
2118 | (let* ((re (completion-pcm--pattern->regex pattern '(point))) | |
1bba1cfc | 2119 | (case-fold-search completion-ignore-case)) |
1bba1cfc SM |
2120 | (mapcar |
2121 | (lambda (str) | |
2122 | ;; Don't modify the string itself. | |
2123 | (setq str (copy-sequence str)) | |
2124 | (unless (string-match re str) | |
2125 | (error "Internal error: %s does not match %s" re str)) | |
2126 | (let ((pos (or (match-beginning 1) (match-end 0)))) | |
2127 | (put-text-property 0 pos | |
2128 | 'font-lock-face 'completions-common-part | |
2129 | str) | |
2130 | (if (> (length str) pos) | |
2131 | (put-text-property pos (1+ pos) | |
2132 | 'font-lock-face 'completions-first-difference | |
2133 | str))) | |
2134 | str) | |
2135 | completions)))) | |
7372b09c | 2136 | |
eee6de73 SM |
2137 | (defun completion-pcm--find-all-completions (string table pred point |
2138 | &optional filter) | |
2139 | "Find all completions for STRING at POINT in TABLE, satisfying PRED. | |
2140 | POINT is a position inside STRING. | |
2141 | FILTER is a function applied to the return value, that can be used, e.g. to | |
2142 | filter out additional entries (because TABLE migth not obey PRED)." | |
2143 | (unless filter (setq filter 'identity)) | |
a647cb26 SM |
2144 | (let* ((beforepoint (substring string 0 point)) |
2145 | (afterpoint (substring string point)) | |
2146 | (bounds (completion-boundaries beforepoint table pred afterpoint)) | |
2147 | (prefix (substring beforepoint 0 (car bounds))) | |
2148 | (suffix (substring afterpoint (cdr bounds))) | |
2149 | firsterror) | |
f8381803 SM |
2150 | (setq string (substring string (car bounds) (+ point (cdr bounds)))) |
2151 | (let* ((relpoint (- point (car bounds))) | |
2152 | (pattern (completion-pcm--string->pattern string relpoint)) | |
a38313e1 | 2153 | (all (condition-case err |
eee6de73 SM |
2154 | (funcall filter |
2155 | (completion-pcm--all-completions | |
2156 | prefix pattern table pred)) | |
a38313e1 SM |
2157 | (error (unless firsterror (setq firsterror err)) nil)))) |
2158 | (when (and (null all) | |
2159 | (> (car bounds) 0) | |
2160 | (null (ignore-errors (try-completion prefix table pred)))) | |
2161 | ;; The prefix has no completions at all, so we should try and fix | |
2162 | ;; that first. | |
2163 | (let ((substring (substring prefix 0 -1))) | |
d032d5e7 | 2164 | (destructuring-bind (subpat suball subprefix _subsuffix) |
a38313e1 | 2165 | (completion-pcm--find-all-completions |
eee6de73 | 2166 | substring table pred (length substring) filter) |
a38313e1 SM |
2167 | (let ((sep (aref prefix (1- (length prefix)))) |
2168 | ;; Text that goes between the new submatches and the | |
2169 | ;; completion substring. | |
2170 | (between nil)) | |
2171 | ;; Eliminate submatches that don't end with the separator. | |
2172 | (dolist (submatch (prog1 suball (setq suball ()))) | |
2173 | (when (eq sep (aref submatch (1- (length submatch)))) | |
2174 | (push submatch suball))) | |
2175 | (when suball | |
2176 | ;; Update the boundaries and corresponding pattern. | |
2177 | ;; We assume that all submatches result in the same boundaries | |
2178 | ;; since we wouldn't know how to merge them otherwise anyway. | |
f8381803 SM |
2179 | ;; FIXME: COMPLETE REWRITE!!! |
2180 | (let* ((newbeforepoint | |
2181 | (concat subprefix (car suball) | |
2182 | (substring string 0 relpoint))) | |
2183 | (leftbound (+ (length subprefix) (length (car suball)))) | |
a38313e1 | 2184 | (newbounds (completion-boundaries |
f8381803 SM |
2185 | newbeforepoint table pred afterpoint))) |
2186 | (unless (or (and (eq (cdr bounds) (cdr newbounds)) | |
2187 | (eq (car newbounds) leftbound)) | |
a38313e1 SM |
2188 | ;; Refuse new boundaries if they step over |
2189 | ;; the submatch. | |
f8381803 | 2190 | (< (car newbounds) leftbound)) |
a38313e1 SM |
2191 | ;; The new completed prefix does change the boundaries |
2192 | ;; of the completed substring. | |
f8381803 SM |
2193 | (setq suffix (substring afterpoint (cdr newbounds))) |
2194 | (setq string | |
2195 | (concat (substring newbeforepoint (car newbounds)) | |
2196 | (substring afterpoint 0 (cdr newbounds)))) | |
2197 | (setq between (substring newbeforepoint leftbound | |
a38313e1 SM |
2198 | (car newbounds))) |
2199 | (setq pattern (completion-pcm--string->pattern | |
f8381803 SM |
2200 | string |
2201 | (- (length newbeforepoint) | |
2202 | (car newbounds))))) | |
a38313e1 SM |
2203 | (dolist (submatch suball) |
2204 | (setq all (nconc (mapcar | |
2205 | (lambda (s) (concat submatch between s)) | |
eee6de73 SM |
2206 | (funcall filter |
2207 | (completion-pcm--all-completions | |
2208 | (concat subprefix submatch between) | |
2209 | pattern table pred))) | |
a38313e1 | 2210 | all))) |
c63028e1 SM |
2211 | ;; FIXME: This can come in handy for try-completion, |
2212 | ;; but isn't right for all-completions, since it lists | |
2213 | ;; invalid completions. | |
2214 | ;; (unless all | |
2215 | ;; ;; Even though we found expansions in the prefix, none | |
2216 | ;; ;; leads to a valid completion. | |
2217 | ;; ;; Let's keep the expansions, tho. | |
2218 | ;; (dolist (submatch suball) | |
2219 | ;; (push (concat submatch between newsubstring) all))) | |
2220 | )) | |
a38313e1 SM |
2221 | (setq pattern (append subpat (list 'any (string sep)) |
2222 | (if between (list between)) pattern)) | |
2223 | (setq prefix subprefix))))) | |
2224 | (if (and (null all) firsterror) | |
2225 | (signal (car firsterror) (cdr firsterror)) | |
2226 | (list pattern all prefix suffix))))) | |
2227 | ||
34200787 | 2228 | (defun completion-pcm-all-completions (string table pred point) |
d032d5e7 | 2229 | (destructuring-bind (pattern all &optional prefix _suffix) |
a38313e1 | 2230 | (completion-pcm--find-all-completions string table pred point) |
d4e88786 SM |
2231 | (when all |
2232 | (nconc (completion-pcm--hilit-commonality pattern all) | |
2233 | (length prefix))))) | |
34200787 | 2234 | |
1493963b SM |
2235 | (defun completion--sreverse (str) |
2236 | "Like `reverse' but for a string STR rather than a list." | |
2237 | (apply 'string (nreverse (mapcar 'identity str)))) | |
2238 | ||
2239 | (defun completion--common-suffix (strs) | |
2240 | "Return the common suffix of the strings STRS." | |
2241 | (completion--sreverse | |
2242 | (try-completion | |
2243 | "" | |
f3ee9200 | 2244 | (mapcar 'completion--sreverse strs)))) |
1493963b | 2245 | |
34200787 SM |
2246 | (defun completion-pcm--merge-completions (strs pattern) |
2247 | "Extract the commonality in STRS, with the help of PATTERN." | |
681e0e7c SM |
2248 | ;; When completing while ignoring case, we want to try and avoid |
2249 | ;; completing "fo" to "foO" when completing against "FOO" (bug#4219). | |
2250 | ;; So we try and make sure that the string we return is all made up | |
2251 | ;; of text from the completions rather than part from the | |
2252 | ;; completions and part from the input. | |
2253 | ;; FIXME: This reduces the problems of inconsistent capitalization | |
2254 | ;; but it doesn't fully fix it: we may still end up completing | |
2255 | ;; "fo-ba" to "foo-BAR" or "FOO-bar" when completing against | |
2256 | ;; '("foo-barr" "FOO-BARD"). | |
34200787 SM |
2257 | (cond |
2258 | ((null (cdr strs)) (list (car strs))) | |
2259 | (t | |
2260 | (let ((re (completion-pcm--pattern->regex pattern 'group)) | |
2261 | (ccs ())) ;Chopped completions. | |
2262 | ||
2263 | ;; First chop each string into the parts corresponding to each | |
2264 | ;; non-constant element of `pattern', using regexp-matching. | |
2265 | (let ((case-fold-search completion-ignore-case)) | |
2266 | (dolist (str strs) | |
2267 | (unless (string-match re str) | |
2268 | (error "Internal error: %s doesn't match %s" str re)) | |
2269 | (let ((chopped ()) | |
681e0e7c SM |
2270 | (last 0) |
2271 | (i 1) | |
2272 | next) | |
2273 | (while (setq next (match-end i)) | |
2274 | (push (substring str last next) chopped) | |
2275 | (setq last next) | |
34200787 SM |
2276 | (setq i (1+ i))) |
2277 | ;; Add the text corresponding to the implicit trailing `any'. | |
681e0e7c | 2278 | (push (substring str last) chopped) |
34200787 SM |
2279 | (push (nreverse chopped) ccs)))) |
2280 | ||
2281 | ;; Then for each of those non-constant elements, extract the | |
2282 | ;; commonality between them. | |
681e0e7c SM |
2283 | (let ((res ()) |
2284 | (fixed "")) | |
2285 | ;; Make the implicit trailing `any' explicit. | |
34200787 SM |
2286 | (dolist (elem (append pattern '(any))) |
2287 | (if (stringp elem) | |
681e0e7c | 2288 | (setq fixed (concat fixed elem)) |
34200787 SM |
2289 | (let ((comps ())) |
2290 | (dolist (cc (prog1 ccs (setq ccs nil))) | |
2291 | (push (car cc) comps) | |
2292 | (push (cdr cc) ccs)) | |
681e0e7c SM |
2293 | ;; Might improve the likelihood to avoid choosing |
2294 | ;; different capitalizations in different parts. | |
2295 | ;; In practice, it doesn't seem to make any difference. | |
2296 | (setq ccs (nreverse ccs)) | |
2297 | (let* ((prefix (try-completion fixed comps)) | |
2298 | (unique (or (and (eq prefix t) (setq prefix fixed)) | |
34200787 SM |
2299 | (eq t (try-completion prefix comps))))) |
2300 | (unless (equal prefix "") (push prefix res)) | |
2301 | ;; If there's only one completion, `elem' is not useful | |
2302 | ;; any more: it can only match the empty string. | |
2303 | ;; FIXME: in some cases, it may be necessary to turn an | |
2304 | ;; `any' into a `star' because the surrounding context has | |
2305 | ;; changed such that string->pattern wouldn't add an `any' | |
2306 | ;; here any more. | |
1493963b SM |
2307 | (unless unique |
2308 | (push elem res) | |
79ccd68f | 2309 | (when (memq elem '(star point prefix)) |
1493963b | 2310 | ;; Extract common suffix additionally to common prefix. |
79ccd68f | 2311 | ;; Only do it for `point', `star', and `prefix' since for |
1493963b SM |
2312 | ;; `any' it could lead to a merged completion that |
2313 | ;; doesn't itself match the candidates. | |
2314 | (let ((suffix (completion--common-suffix comps))) | |
2315 | (assert (stringp suffix)) | |
2316 | (unless (equal suffix "") | |
2317 | (push suffix res))))) | |
681e0e7c | 2318 | (setq fixed ""))))) |
34200787 SM |
2319 | ;; We return it in reverse order. |
2320 | res))))) | |
2321 | ||
2322 | (defun completion-pcm--pattern->string (pattern) | |
2323 | (mapconcat (lambda (x) (cond | |
03408648 SM |
2324 | ((stringp x) x) |
2325 | ((eq x 'star) "*") | |
2326 | (t ""))) ;any, point, prefix. | |
34200787 SM |
2327 | pattern |
2328 | "")) | |
2329 | ||
eee6de73 SM |
2330 | ;; We want to provide the functionality of `try', but we use `all' |
2331 | ;; and then merge it. In most cases, this works perfectly, but | |
2332 | ;; if the completion table doesn't consider the same completions in | |
2333 | ;; `try' as in `all', then we have a problem. The most common such | |
2334 | ;; case is for filename completion where completion-ignored-extensions | |
2335 | ;; is only obeyed by the `try' code. We paper over the difference | |
2336 | ;; here. Note that it is not quite right either: if the completion | |
2337 | ;; table uses completion-table-in-turn, this filtering may take place | |
2338 | ;; too late to correctly fallback from the first to the | |
2339 | ;; second alternative. | |
2340 | (defun completion-pcm--filename-try-filter (all) | |
2341 | "Filter to adjust `all' file completion to the behavior of `try'." | |
03408648 | 2342 | (when all |
eee6de73 SM |
2343 | (let ((try ()) |
2344 | (re (concat "\\(?:\\`\\.\\.?/\\|" | |
2345 | (regexp-opt completion-ignored-extensions) | |
2346 | "\\)\\'"))) | |
2347 | (dolist (f all) | |
9f3618b5 | 2348 | (unless (string-match-p re f) (push f try))) |
eee6de73 | 2349 | (or try all)))) |
9f3618b5 | 2350 | |
eee6de73 SM |
2351 | |
2352 | (defun completion-pcm--merge-try (pattern all prefix suffix) | |
2353 | (cond | |
2354 | ((not (consp all)) all) | |
2355 | ((and (not (consp (cdr all))) ;Only one completion. | |
2356 | ;; Ignore completion-ignore-case here. | |
2357 | (equal (completion-pcm--pattern->string pattern) (car all))) | |
2358 | t) | |
2359 | (t | |
03408648 SM |
2360 | (let* ((mergedpat (completion-pcm--merge-completions all pattern)) |
2361 | ;; `mergedpat' is in reverse order. Place new point (by | |
2362 | ;; order of preference) either at the old point, or at | |
2363 | ;; the last place where there's something to choose, or | |
2364 | ;; at the very end. | |
2365 | (pointpat (or (memq 'point mergedpat) | |
2366 | (memq 'any mergedpat) | |
2367 | (memq 'star mergedpat) | |
2368 | ;; Not `prefix'. | |
2369 | mergedpat)) | |
2370 | ;; New pos from the start. | |
2371 | (newpos (length (completion-pcm--pattern->string pointpat))) | |
2372 | ;; Do it afterwards because it changes `pointpat' by sideeffect. | |
2373 | (merged (completion-pcm--pattern->string (nreverse mergedpat)))) | |
eee6de73 SM |
2374 | |
2375 | (setq suffix (completion--merge-suffix merged newpos suffix)) | |
03408648 | 2376 | (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) |
34200787 | 2377 | |
eee6de73 SM |
2378 | (defun completion-pcm-try-completion (string table pred point) |
2379 | (destructuring-bind (pattern all prefix suffix) | |
2380 | (completion-pcm--find-all-completions | |
2381 | string table pred point | |
2382 | (if minibuffer-completing-file-name | |
2383 | 'completion-pcm--filename-try-filter)) | |
2384 | (completion-pcm--merge-try pattern all prefix suffix))) | |
2385 | ||
00278747 SM |
2386 | ;;; Substring completion |
2387 | ;; Mostly derived from the code of `basic' completion. | |
2388 | ||
2389 | (defun completion-substring--all-completions (string table pred point) | |
2390 | (let* ((beforepoint (substring string 0 point)) | |
2391 | (afterpoint (substring string point)) | |
2392 | (bounds (completion-boundaries beforepoint table pred afterpoint)) | |
2393 | (suffix (substring afterpoint (cdr bounds))) | |
2394 | (prefix (substring beforepoint 0 (car bounds))) | |
2395 | (basic-pattern (completion-basic--pattern | |
2396 | beforepoint afterpoint bounds)) | |
2397 | (pattern (if (not (stringp (car basic-pattern))) | |
2398 | basic-pattern | |
79ccd68f | 2399 | (cons 'prefix basic-pattern))) |
00278747 SM |
2400 | (all (completion-pcm--all-completions prefix pattern table pred))) |
2401 | (list all pattern prefix suffix (car bounds)))) | |
2402 | ||
2403 | (defun completion-substring-try-completion (string table pred point) | |
d032d5e7 | 2404 | (destructuring-bind (all pattern prefix suffix _carbounds) |
00278747 SM |
2405 | (completion-substring--all-completions string table pred point) |
2406 | (if minibuffer-completing-file-name | |
2407 | (setq all (completion-pcm--filename-try-filter all))) | |
2408 | (completion-pcm--merge-try pattern all prefix suffix))) | |
2409 | ||
2410 | (defun completion-substring-all-completions (string table pred point) | |
d032d5e7 | 2411 | (destructuring-bind (all pattern prefix _suffix _carbounds) |
00278747 SM |
2412 | (completion-substring--all-completions string table pred point) |
2413 | (when all | |
2414 | (nconc (completion-pcm--hilit-commonality pattern all) | |
2415 | (length prefix))))) | |
2416 | ||
2417 | ;; Initials completion | |
fcb68f70 SM |
2418 | ;; Complete /ums to /usr/monnier/src or lch to list-command-history. |
2419 | ||
2420 | (defun completion-initials-expand (str table pred) | |
51b23c44 SM |
2421 | (let ((bounds (completion-boundaries str table pred ""))) |
2422 | (unless (or (zerop (length str)) | |
2423 | ;; Only check within the boundaries, since the | |
2424 | ;; boundary char (e.g. /) might be in delim-regexp. | |
2425 | (string-match completion-pcm--delim-wild-regex str | |
2426 | (car bounds))) | |
fcb68f70 SM |
2427 | (if (zerop (car bounds)) |
2428 | (mapconcat 'string str "-") | |
2429 | ;; If there's a boundary, it's trickier. The main use-case | |
2430 | ;; we consider here is file-name completion. We'd like | |
2431 | ;; to expand ~/eee to ~/e/e/e and /eee to /e/e/e. | |
2432 | ;; But at the same time, we don't want /usr/share/ae to expand | |
2433 | ;; to /usr/share/a/e just because we mistyped "ae" for "ar", | |
2434 | ;; so we probably don't want initials to touch anything that | |
2435 | ;; looks like /usr/share/foo. As a heuristic, we just check that | |
2436 | ;; the text before the boundary char is at most 1 char. | |
2437 | ;; This allows both ~/eee and /eee and not much more. | |
2438 | ;; FIXME: It sadly also disallows the use of ~/eee when that's | |
2439 | ;; embedded within something else (e.g. "(~/eee" in Info node | |
2440 | ;; completion or "ancestor:/eee" in bzr-revision completion). | |
2441 | (when (< (car bounds) 3) | |
2442 | (let ((sep (substring str (1- (car bounds)) (car bounds)))) | |
2443 | ;; FIXME: the above string-match checks the whole string, whereas | |
2444 | ;; we end up only caring about the after-boundary part. | |
2445 | (concat (substring str 0 (car bounds)) | |
2446 | (mapconcat 'string (substring str (car bounds)) sep)))))))) | |
2447 | ||
d032d5e7 | 2448 | (defun completion-initials-all-completions (string table pred _point) |
fcb68f70 SM |
2449 | (let ((newstr (completion-initials-expand string table pred))) |
2450 | (when newstr | |
2451 | (completion-pcm-all-completions newstr table pred (length newstr))))) | |
2452 | ||
d032d5e7 | 2453 | (defun completion-initials-try-completion (string table pred _point) |
fcb68f70 SM |
2454 | (let ((newstr (completion-initials-expand string table pred))) |
2455 | (when newstr | |
2456 | (completion-pcm-try-completion newstr table pred (length newstr))))) | |
2457 | ||
7d371eac JL |
2458 | \f |
2459 | ;; Miscellaneous | |
2460 | ||
2461 | (defun minibuffer-insert-file-name-at-point () | |
2462 | "Get a file name at point in original buffer and insert it to minibuffer." | |
2463 | (interactive) | |
2464 | (let ((file-name-at-point | |
2465 | (with-current-buffer (window-buffer (minibuffer-selected-window)) | |
2466 | (run-hook-with-args-until-success 'file-name-at-point-functions)))) | |
2467 | (when file-name-at-point | |
2468 | (insert file-name-at-point)))) | |
34200787 | 2469 | |
32bae13c | 2470 | (provide 'minibuffer) |
dc6ee347 | 2471 | |
32bae13c | 2472 | ;;; minibuffer.el ends here |