Commit | Line | Data |
---|---|---|
32bae13c SM |
1 | ;;; minibuffer.el --- Minibuffer completion functions |
2 | ||
3 | ;; Copyright (C) 2008 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | |
6 | ||
7 | ;; This file is part of GNU Emacs. | |
8 | ||
9 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation, either version 3 of the License, or | |
12 | ;; (at your option) any later version. | |
13 | ||
14 | ;; This program is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | ;;; Commentary: | |
23 | ||
24 | ;; TODO: | |
25 | ;; - merge do-completion and complete-word | |
26 | ;; - move all I/O out of do-completion | |
27 | ||
28 | ;;; Code: | |
29 | ||
30 | (eval-when-compile (require 'cl)) | |
31 | ||
32 | (defun minibuffer-message (message &rest args) | |
33 | "Temporarily display MESSAGE at the end of the minibuffer. | |
34 | The text is displayed for `minibuffer-message-timeout' seconds, | |
35 | or until the next input event arrives, whichever comes first. | |
36 | Enclose MESSAGE in [...] if this is not yet the case. | |
37 | If ARGS are provided, then pass MESSAGE through `format'." | |
38 | ;; Clear out any old echo-area message to make way for our new thing. | |
39 | (message nil) | |
40 | (unless (string-match "\\[.+\\]" message) | |
41 | (setq message (concat " [" message "]"))) | |
42 | (when args (setq message (apply 'format message args))) | |
43 | (let ((ol (make-overlay (point-max) (point-max) nil t t))) | |
44 | (unwind-protect | |
45 | (progn | |
46 | (overlay-put ol 'after-string message) | |
47 | (sit-for (or minibuffer-message-timeout 1000000))) | |
48 | (delete-overlay ol)))) | |
49 | ||
50 | (defun minibuffer-completion-contents () | |
51 | "Return the user input in a minibuffer before point as a string. | |
52 | That is what completion commands operate on." | |
53 | (buffer-substring (field-beginning) (point))) | |
54 | ||
55 | (defun delete-minibuffer-contents () | |
56 | "Delete all user input in a minibuffer. | |
57 | If the current buffer is not a minibuffer, erase its entire contents." | |
58 | (delete-field)) | |
59 | ||
60 | (defun minibuffer--maybe-completion-help () | |
61 | (if completion-auto-help | |
62 | (minibuffer-completion-help) | |
63 | (minibuffer-message "Next char not unique"))) | |
64 | ||
65 | (defun minibuffer-do-completion () | |
66 | "Do the completion and return a summary of what happened. | |
67 | C = There were available completions. | |
68 | E = After completion we now have an exact match. | |
69 | M = Completion was performed, the text was Modified. | |
70 | ||
71 | CEM | |
72 | 000 0 no possible completion | |
73 | 010 1 was already an exact and unique completion | |
74 | 110 3 was already an exact completion | |
75 | 111 4 completed to an exact completion | |
76 | 101 5 some completion happened | |
77 | 100 6 no completion happened" | |
78 | (let* ((string (minibuffer-completion-contents)) | |
79 | (completion (try-completion (field-string) | |
80 | minibuffer-completion-table | |
81 | minibuffer-completion-predicate))) | |
82 | (setq last-exact-completion nil) | |
83 | (cond | |
84 | ((null completion) | |
85 | (ding) (minibuffer-message "No match") 0) | |
86 | ((eq t completion) 1) ;Exact and unique match. | |
87 | (t | |
88 | ;; `completed' should be t if some completion was done, which doesn't | |
89 | ;; include simply changing the case of the entered string. However, | |
90 | ;; for appearance, the string is rewritten if the case changes. | |
91 | (let ((completed (not (eq t (compare-strings completion nil nil | |
92 | string nil nil t)))) | |
93 | (unchanged (eq t (compare-strings completion nil nil | |
94 | string nil nil nil)))) | |
95 | (unless unchanged | |
96 | (let ((beg (field-beginning)) | |
97 | (end (point))) | |
98 | (insert completion) | |
99 | (delete-region beg end))) | |
100 | (if (not (or unchanged completed)) | |
101 | ;; The case of the string changed, but that's all. We're not sure | |
102 | ;; whether this is a unique completion or not, so try again using | |
103 | ;; the real case (this shouldn't recurse again, because the next | |
104 | ;; time try-completion will return either t or the exact string). | |
105 | (minibuffer-do-completion) | |
106 | ||
107 | ;; It did find a match. Do we match some possibility exactly now? | |
108 | (let ((exact (test-completion (field-string) | |
109 | minibuffer-completion-table | |
110 | minibuffer-completion-predicate))) | |
111 | (cond | |
112 | ((not exact) | |
113 | (if completed 5 | |
114 | (minibuffer--maybe-completion-help) | |
115 | 6)) | |
116 | (completed 4) | |
117 | (t | |
118 | ;; If the last exact completion and this one were the same, | |
119 | ;; it means we've already given a "Complete but not unique" | |
120 | ;; message and the user's hit TAB again, so now we give him help. | |
121 | (if (eq this-command last-command) | |
122 | (minibuffer-completion-help)) | |
123 | 3))))))))) | |
124 | ||
125 | (defun minibuffer-complete () | |
126 | "Complete the minibuffer contents as far as possible. | |
127 | Return nil if there is no valid completion, else t. | |
128 | If no characters can be completed, display a list of possible completions. | |
129 | If you repeat this command after it displayed such a list, | |
130 | scroll the window of possible completions." | |
131 | (interactive) | |
132 | ;; If the previous command was not this, | |
133 | ;; mark the completion buffer obsolete. | |
134 | (unless (eq this-command last-command) | |
135 | (setq minibuffer-scroll-window nil)) | |
136 | ||
137 | (let ((window minibuffer-scroll-window)) | |
138 | ;; If there's a fresh completion window with a live buffer, | |
139 | ;; and this command is repeated, scroll that window. | |
140 | (if (window-live-p window) | |
141 | (with-current-buffer (window-buffer window) | |
142 | (if (pos-visible-in-window-p (point-max) window) | |
143 | ;; If end is in view, scroll up to the beginning. | |
144 | (set-window-start window (point-min) nil) | |
145 | ;; Else scroll down one screen. | |
146 | (scroll-other-window)) | |
147 | nil) | |
148 | ||
149 | (let ((i (minibuffer-do-completion))) | |
150 | (case i | |
151 | (0 nil) | |
152 | (1 (goto-char (field-end)) | |
153 | (minibuffer-message "Sole completion") | |
154 | t) | |
155 | (3 (goto-char (field-end)) | |
156 | (minibuffer-message "Complete, but not unique") | |
157 | t) | |
158 | (t t)))))) | |
159 | ||
160 | (defun minibuffer-complete-and-exit () | |
161 | "If the minibuffer contents is a valid completion then exit. | |
162 | Otherwise try to complete it. If completion leads to a valid completion, | |
163 | a repetition of this command will exit." | |
164 | (interactive) | |
165 | (cond | |
166 | ;; Allow user to specify null string | |
167 | ((= (field-beginning) (field-end)) (exit-minibuffer)) | |
168 | ((test-completion (field-string) | |
169 | minibuffer-completion-table | |
170 | minibuffer-completion-predicate) | |
171 | (when completion-ignore-case | |
172 | ;; Fixup case of the field, if necessary. | |
173 | (let* ((string (field-string)) | |
174 | (compl (try-completion string | |
175 | minibuffer-completion-table | |
176 | minibuffer-completion-predicate))) | |
177 | (when (and (stringp compl) | |
178 | ;; If it weren't for this piece of paranoia, I'd replace | |
179 | ;; the whole thing with a call to complete-do-completion. | |
180 | (= (length string) (length compl))) | |
181 | (let ((beg (field-beginning)) | |
182 | (end (field-end))) | |
183 | (goto-char end) | |
184 | (insert compl) | |
185 | (delete-region beg end))))) | |
186 | (exit-minibuffer)) | |
187 | ||
188 | ((eq minibuffer-completion-confirm 'confirm-only) | |
189 | ;; The user is permitted to exit with an input that's rejected | |
190 | ;; by test-completion, but at the condition to confirm her choice. | |
191 | (if (eq last-command this-command) | |
192 | (exit-minibuffer) | |
193 | (minibuffer-message "Confirm") | |
194 | nil)) | |
195 | ||
196 | (t | |
197 | ;; Call do-completion, but ignore errors. | |
198 | (let ((i (condition-case nil | |
199 | (minibuffer-do-completion) | |
200 | (error 1)))) | |
201 | (case i | |
202 | ((1 3) (exit-minibuffer)) | |
203 | (4 (if (not minibuffer-completion-confirm) | |
204 | (exit-minibuffer) | |
205 | (minibuffer-message "Confirm") | |
206 | nil)) | |
207 | (t nil)))))) | |
208 | ||
209 | (defun minibuffer-complete-word () | |
210 | "Complete the minibuffer contents at most a single word. | |
211 | After one word is completed as much as possible, a space or hyphen | |
212 | is added, provided that matches some possible completion. | |
213 | Return nil if there is no valid completion, else t." | |
214 | (interactive) | |
215 | (let* ((beg (field-beginning)) | |
216 | (string (buffer-substring beg (point))) | |
217 | (completion (try-completion string | |
218 | minibuffer-completion-table | |
219 | minibuffer-completion-predicate))) | |
220 | (cond | |
221 | ((null completion) | |
222 | (ding) (minibuffer-message "No match") nil) | |
223 | ((eq t completion) nil) ;Exact and unique match. | |
224 | (t | |
225 | ;; Completing a single word is actually more difficult than completing | |
226 | ;; as much as possible, because we first have to find the "current | |
227 | ;; position" in `completion' in order to find the end of the word | |
228 | ;; we're completing. Normally, `string' is a prefix of `completion', | |
229 | ;; which makes it trivial to find the position, but with fancier | |
230 | ;; completion (plus env-var expansion, ...) `completion' might not | |
231 | ;; look anything like `string' at all. | |
232 | ||
233 | (when minibuffer-completing-file-name | |
234 | ;; In order to minimize the problem mentioned above, let's try to | |
235 | ;; reduce the different between `string' and `completion' by | |
236 | ;; mirroring some of the work done in read-file-name-internal. | |
237 | (let ((substituted (condition-case nil | |
238 | ;; Might fail when completing an env-var. | |
239 | (substitute-in-file-name string) | |
240 | (error string)))) | |
241 | (unless (eq string substituted) | |
242 | (setq string substituted) | |
243 | (let ((end (point))) | |
244 | (insert substituted) | |
245 | (delete-region beg end))))) | |
246 | ||
247 | ;; Make buffer (before point) contain the longest match | |
248 | ;; of `string's tail and `completion's head. | |
249 | (let* ((startpos (max 0 (- (length string) (length completion)))) | |
250 | (length (- (length string) startpos))) | |
251 | (while (and (> length 0) | |
252 | (not (eq t (compare-strings string startpos nil | |
253 | completion 0 length | |
254 | completion-ignore-case)))) | |
255 | (setq startpos (1+ startpos)) | |
256 | (setq length (1- length))) | |
257 | ||
258 | (setq string (substring string startpos)) | |
259 | (delete-region beg (+ beg startpos))) | |
260 | ||
261 | ;; Now `string' is a prefix of `completion'. | |
262 | ||
263 | ;; If completion finds next char not unique, | |
264 | ;; consider adding a space or a hyphen. | |
265 | (when (= (length string) (length completion)) | |
266 | (let ((exts '(" " "-")) | |
267 | tem) | |
268 | (while (and exts (not (stringp tem))) | |
269 | (setq tem (try-completion (concat string (pop exts)) | |
270 | minibuffer-completion-table | |
271 | minibuffer-completion-predicate))) | |
272 | (if (stringp tem) (setq completion tem)))) | |
273 | ||
274 | (if (= (length string) (length completion)) | |
275 | ;; If got no characters, print help for user. | |
276 | (progn | |
277 | (if completion-auto-help (minibuffer-completion-help)) | |
278 | nil) | |
279 | ;; Otherwise insert in minibuffer the chars we got. | |
280 | (if (string-match "\\W" completion (length string)) | |
281 | ;; First find first word-break in the stuff found by completion. | |
282 | ;; i gets index in string of where to stop completing. | |
283 | (setq completion (substring completion 0 (match-end 0)))) | |
284 | ||
285 | (if (and (eq ?/ (aref completion (1- (length completion)))) | |
286 | (eq ?/ (char-after))) | |
287 | (setq completion (substring completion 0 (1- (length completion))))) | |
288 | ||
289 | (let ((pos (point))) | |
290 | (insert completion) | |
291 | (delete-region beg pos) | |
292 | t)))))) | |
293 | ||
294 | (defun minibuffer-complete-insert-strings (strings) | |
295 | "Insert a list of STRINGS into the current buffer. | |
296 | Uses columns to keep the listing readable but compact. | |
297 | It also eliminates runs of equal strings." | |
298 | (when (consp strings) | |
299 | (let* ((length (apply 'max | |
300 | (mapcar (lambda (s) | |
301 | (if (consp s) | |
302 | (+ (length (car s)) (length (cadr s))) | |
303 | (length s))) | |
304 | strings))) | |
305 | (window (get-buffer-window (current-buffer) 0)) | |
306 | (wwidth (if window (1- (window-width window)) 79)) | |
307 | (columns (min | |
308 | ;; At least 2 columns; at least 2 spaces between columns. | |
309 | (max 2 (/ wwidth (+ 2 length))) | |
310 | ;; Don't allocate more columns than we can fill. | |
311 | ;; Windows can't show less than 3 lines anyway. | |
312 | (max 1 (/ (length strings) 2)))) | |
313 | (colwidth (/ wwidth columns)) | |
314 | (column 0) | |
315 | (laststring nil)) | |
316 | ;; The insertion should be "sensible" no matter what choices were made | |
317 | ;; for the parameters above. | |
318 | (dolist (str strings) | |
319 | (unless (equal laststring str) ; Remove (consecutive) duplicates. | |
320 | (setq laststring str) | |
321 | (unless (bolp) | |
322 | (insert " \t") | |
323 | (setq column (+ column colwidth)) | |
324 | ;; Leave the space unpropertized so that in the case we're | |
325 | ;; already past the goal column, there is still | |
326 | ;; a space displayed. | |
327 | (set-text-properties (- (point) 1) (point) | |
328 | ;; We can't just set tab-width, because | |
329 | ;; completion-setup-function will kill all | |
330 | ;; local variables :-( | |
331 | `(display (space :align-to ,column)))) | |
332 | (when (< wwidth (+ (max colwidth | |
333 | (if (consp str) | |
334 | (+ (length (car str)) (length (cadr str))) | |
335 | (length str))) | |
336 | column)) | |
337 | (delete-char -2) (insert "\n") (setq column 0)) | |
338 | (if (not (consp str)) | |
339 | (put-text-property (point) (progn (insert str) (point)) | |
340 | 'mouse-face 'highlight) | |
341 | (put-text-property (point) (progn (insert (car str)) (point)) | |
342 | 'mouse-face 'highlight) | |
343 | (put-text-property (point) (progn (insert (cadr str)) (point)) | |
344 | 'mouse-face nil))))))) | |
345 | ||
346 | (defvar completion-common-substring) | |
347 | ||
348 | (defun display-completion-list (completions &optional common-substring) | |
349 | "Display the list of completions, COMPLETIONS, using `standard-output'. | |
350 | Each element may be just a symbol or string | |
351 | or may be a list of two strings to be printed as if concatenated. | |
352 | If it is a list of two strings, the first is the actual completion | |
353 | alternative, the second serves as annotation. | |
354 | `standard-output' must be a buffer. | |
355 | The actual completion alternatives, as inserted, are given `mouse-face' | |
356 | properties of `highlight'. | |
357 | At the end, this runs the normal hook `completion-setup-hook'. | |
358 | It can find the completion buffer in `standard-output'. | |
359 | The optional second arg COMMON-SUBSTRING is a string. | |
360 | It is used to put faces, `completions-first-difference' and | |
361 | `completions-common-part' on the completion buffer. The | |
362 | `completions-common-part' face is put on the common substring | |
363 | specified by COMMON-SUBSTRING. If COMMON-SUBSTRING is nil | |
364 | and the current buffer is not the minibuffer, the faces are not put. | |
365 | Internally, COMMON-SUBSTRING is bound to `completion-common-substring' | |
366 | during running `completion-setup-hook'." | |
367 | (if (not (bufferp standard-output)) | |
368 | ;; This *never* (ever) happens, so there's no point trying to be clever. | |
369 | (with-temp-buffer | |
370 | (let ((standard-output (current-buffer)) | |
371 | (completion-setup-hook nil)) | |
372 | (display-completion-list completions)) | |
373 | (princ (buffer-string))) | |
374 | ||
375 | (with-current-buffer standard-output | |
376 | (goto-char (point-max)) | |
377 | (if (null completions) | |
378 | (insert "There are no possible completions of what you have typed.") | |
379 | ||
380 | (insert "Possible completions are:\n") | |
381 | (minibuffer-complete-insert-strings completions)))) | |
382 | (let ((completion-common-substring common-substring)) | |
383 | (run-hooks 'completion-setup-hook)) | |
384 | nil) | |
385 | ||
386 | (defun minibuffer-completion-help () | |
387 | "Display a list of possible completions of the current minibuffer contents." | |
388 | (interactive) | |
389 | (message "Making completion list...") | |
390 | (let* ((string (field-string)) | |
391 | (completions (all-completions | |
392 | string | |
393 | minibuffer-completion-table | |
394 | minibuffer-completion-predicate | |
395 | t))) | |
396 | (message nil) | |
397 | (if (and completions | |
398 | (or (cdr completions) (not (equal (car completions) string)))) | |
399 | (with-output-to-temp-buffer "*Completions*" | |
400 | (display-completion-list (sort completions 'string-lessp))) | |
401 | ||
402 | ;; If there are no completions, or if the current input is already the | |
403 | ;; only possible completion, then hide (previous&stale) completions. | |
404 | (let ((window (and (get-buffer "*Completions*") | |
405 | (get-buffer-window "*Completions*" 0)))) | |
406 | (when (and (window-live-p window) (window-dedicated-p window)) | |
407 | (condition-case () | |
408 | (delete-window window) | |
409 | (error (iconify-frame (window-frame window)))))) | |
410 | (ding) | |
411 | (minibuffer-message | |
412 | (if completions "Sole completion" "No completions"))) | |
413 | nil)) | |
414 | ||
415 | (defun exit-minibuffer () | |
416 | "Terminate this minibuffer argument." | |
417 | (interactive) | |
418 | ;; If the command that uses this has made modifications in the minibuffer, | |
419 | ;; we don't want them to cause deactivation of the mark in the original | |
420 | ;; buffer. | |
421 | ;; A better solution would be to make deactivate-mark buffer-local | |
422 | ;; (or to turn it into a list of buffers, ...), but in the mean time, | |
423 | ;; this should do the trick in most cases. | |
424 | (setq deactivate_mark nil) | |
425 | (throw 'exit nil)) | |
426 | ||
427 | (defun self-insert-and-exit () | |
428 | "Terminate minibuffer input." | |
429 | (interactive) | |
430 | (if (characterp last-command-char) | |
431 | (call-interactively 'self-insert-command) | |
432 | (ding)) | |
433 | (exit-minibuffer)) | |
434 | ||
435 | (provide 'minibuffer) | |
436 | ;;; minibuffer.el ends here |