Merged from miles@gnu.org--gnu-2005 (patch 169-173, 671-676)
[bpt/emacs.git] / lisp / emacs-lisp / crm.el
1 ;;; crm.el --- read multiple strings with completion
2
3 ;; Copyright (C) 1985, 1986, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 ;; 2000, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
5
6 ;; Author: Sen Nagata <sen@eccosys.com>
7 ;; Keywords: completion, minibuffer, multiple elements
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
25
26 ;;; Commentary:
27
28 ;; This code defines a function, `completing-read-multiple', which
29 ;; provides the ability to read multiple strings in the minibuffer,
30 ;; with completion.
31
32 ;; By using this functionality, a user may specify multiple strings at
33 ;; a single prompt, optionally using completion.
34
35 ;; Multiple strings are specified by separating each of the strings
36 ;; with a prespecified separator character. For example, if the
37 ;; separator character is a comma, the strings 'alice', 'bob', and
38 ;; 'eve' would be specified as 'alice,bob,eve'.
39
40 ;; The default value for the separator character is the value of
41 ;; `crm-default-separator' (comma). The separator character may be
42 ;; changed by modifying the value of `crm-separator'.
43
44 ;; Contiguous strings of non-separator-characters are referred to as
45 ;; 'elements'. In the aforementioned example, the elements are:
46 ;; 'alice', 'bob', and 'eve'.
47
48 ;; Completion is available on a per-element basis. For example, if
49 ;; the contents of the minibuffer are 'alice,bob,eve' and point is
50 ;; between 'l' and 'i', pressing TAB operates on the element 'alice'.
51
52 ;; For the moment, I have decided to not bind any special behavior to
53 ;; the separator key. In the future, the separator key might be used
54 ;; to provide completion in certain circumstances. One of the reasons
55 ;; why this functionality is not yet provided is that it is unclear to
56 ;; the author what the precise circumstances are, under which
57 ;; separator-invoked completion should be provided.
58
59 ;; Design note: `completing-read-multiple' is modeled after
60 ;; `completing-read'. They should be similar -- it was intentional.
61
62 ;; Some of this code started out as translation from C code in
63 ;; src/minibuf.c to Emacs Lisp code.
64
65 ;; Thanks to Richard Stallman for all of his help (many of the good
66 ;; ideas in here are from him), Gerd Moellmann for his attention,
67 ;; Stefan Monnier for responding with a code sample and comments very
68 ;; early on, and Kai Grossjohann & Soren Dayton for valuable feedback.
69
70 ;;; Questions and Thoughts:
71
72 ;; -the author has gone through a number of test-and-fix cycles w/
73 ;; this code, so it should be usable. please let me know if you find
74 ;; any problems.
75
76 ;; -should `completing-read-multiple' allow a trailing separator in
77 ;; a return value when REQUIRE-MATCH is t? if not, should beep when a user
78 ;; tries to exit the minibuffer via RET?
79
80 ;; -TODO: possibly make return values from `crm-do-completion' into constants
81
82 ;; -TODO: find out whether there is an appropriate way to distinguish between
83 ;; functions intended for internal use and those that aren't.
84
85 ;; -tip: use M-f and M-b for ease of navigation among elements.
86
87 ;;; History:
88 ;;
89 ;; 2000-04-10:
90 ;;
91 ;; first revamped version
92
93 ;;; Code:
94 (defconst crm-default-separator ","
95 "Default separator for `completing-read-multiple'.")
96
97 (defvar crm-separator crm-default-separator
98 "Separator used for separating strings in `completing-read-multiple'.
99 It should be a single character string that doesn't appear in the list of
100 completion candidates. Modify this value to make `completing-read-multiple'
101 use a separator other than `crm-default-separator'.")
102
103 ;; actual filling in of these maps occurs below via `crm-init-keymaps'
104 (defvar crm-local-completion-map nil
105 "Local keymap for minibuffer multiple input with completion.
106 Analog of `minibuffer-local-completion-map'.")
107
108 (defvar crm-local-must-match-map nil
109 "Local keymap for minibuffer multiple input with exact match completion.
110 Analog of `minibuffer-local-must-match-map' for crm.")
111
112 (defvar crm-completion-table nil
113 "An alist whose elements' cars are strings, or an obarray.
114 This is a table used for completion by `completing-read-multiple' and its
115 supporting functions.")
116
117 ;; this is supposed to be analogous to last_exact_completion in src/minibuf.c
118 (defvar crm-last-exact-completion nil
119 "Completion string if last attempt reported \"Complete, but not unique\".")
120
121 (defvar crm-left-of-element nil
122 "String to the left of the current element.")
123
124 (defvar crm-current-element nil
125 "The current element.")
126
127 (defvar crm-right-of-element nil
128 "String to the right of the current element.")
129
130 (defvar crm-beginning-of-element nil
131 "Buffer position representing the beginning of the current element.")
132
133 (defvar crm-end-of-element nil
134 "Buffer position representing the end of the current element.")
135
136 ;; emulates temp_echo_area_glyphs from src/minibuf.c
137 (defun crm-temp-echo-area-glyphs (message-string)
138 "Temporarily display MESSAGE-STRING in echo area.
139 After user-input or 2 seconds, erase the displayed string."
140 (save-excursion
141 (goto-char (point-max))
142 (insert message-string)
143 (sit-for 2)
144 (backward-char (length message-string))
145 (delete-char (length message-string))))
146
147 ;; this function evolved from a posting by Stefan Monnier
148 (defun crm-collection-fn (string predicate flag)
149 "Function used by `completing-read-multiple' to compute completion values.
150 The value of STRING is the string to be completed.
151
152 The value of PREDICATE is a function to filter possible matches, or
153 nil if none.
154
155 The value of FLAG is used to specify the type of completion operation.
156 A value of nil specifies `try-completion'. A value of t specifies
157 `all-completions'. A value of lambda specifes a test for an exact match.
158
159 For more information on STRING, PREDICATE, and FLAG, see the Elisp
160 Reference sections on 'Programmed Completion' and 'Basic Completion
161 Functions'."
162 (let ((lead ""))
163 (when (string-match (concat ".*" crm-separator) string)
164 (setq lead (substring string 0 (match-end 0)))
165 (setq string (substring string (match-end 0))))
166 (if (eq flag 'lambda)
167 ;; return t for exact match, nil otherwise
168 (let ((result (try-completion string crm-completion-table predicate)))
169 (if (stringp result)
170 nil
171 (if result
172 t
173 nil))))
174 (if flag
175 ;; called via (all-completions string 'crm-completion-fn predicate)?
176 (all-completions string crm-completion-table predicate)
177 ;; called via (try-completion string 'crm-completion-fn predicate)?
178 (let ((result (try-completion string crm-completion-table predicate)))
179 (if (stringp result)
180 (concat lead result)
181 result)))))
182
183 (defun crm-find-current-element ()
184 "Parse the minibuffer to find the current element.
185 If no element can be found, return nil.
186
187 If an element is found, bind:
188
189 -the variable `crm-current-element' to the current element,
190
191 -the variables `crm-left-of-element' and `crm-right-of-element' to
192 the strings to the left and right of the current element,
193 respectively, and
194
195 -the variables `crm-beginning-of-element' and `crm-end-of-element' to
196 the buffer positions of the beginning and end of the current element
197 respectively,
198
199 and return t."
200 (let* ((prompt-end (minibuffer-prompt-end))
201 (minibuffer-string (buffer-substring prompt-end (point-max)))
202 (end-index (or (string-match "," minibuffer-string (- (point) prompt-end))
203 (- (point-max) prompt-end)))
204 (target-string (substring minibuffer-string 0 end-index))
205 (index (or (string-match
206 (concat crm-separator "\\([^" crm-separator "]*\\)$")
207 target-string)
208 (string-match
209 (concat "^\\([^" crm-separator "]*\\)$")
210 target-string))))
211 (if (not (numberp index))
212 ;; no candidate found
213 nil
214 (progn
215 ;;
216 (setq crm-beginning-of-element (match-beginning 1))
217 (setq crm-end-of-element (+ end-index prompt-end))
218 ;; string to the left of the current element
219 (setq crm-left-of-element
220 (substring target-string 0 (match-beginning 1)))
221 ;; the current element
222 (setq crm-current-element (match-string 1 target-string))
223 ;; string to the right of the current element
224 (setq crm-right-of-element (substring minibuffer-string end-index))
225 t))))
226
227 (defun crm-test-completion (candidate)
228 "Return t if CANDIDATE is an exact match for a valid completion."
229 (let ((completions
230 ;; TODO: verify whether the arguments are appropriate
231 (all-completions
232 candidate crm-completion-table minibuffer-completion-predicate)))
233 (if (member candidate completions)
234 t
235 nil)))
236
237 (defun crm-minibuffer-completion-help ()
238 "Display a list of possible completions of the current minibuffer element."
239 (interactive)
240 (message "Making completion list...")
241 (if (not (crm-find-current-element))
242 nil
243 (let ((completions (all-completions crm-current-element
244 minibuffer-completion-table
245 minibuffer-completion-predicate)))
246 (message nil)
247 (if (null completions)
248 (crm-temp-echo-area-glyphs " [No completions]")
249 (with-output-to-temp-buffer "*Completions*"
250 (display-completion-list
251 (sort completions 'string-lessp)
252 crm-current-element)))))
253 nil)
254
255 (defun crm-do-completion ()
256 "This is the internal completion engine.
257 This function updates the text in the minibuffer
258 to complete the current string, and returns a number between 0 and 6.
259 The meanings of the return values are:
260
261 0 - the string has no possible completion
262 1 - the string is already a valid and unique match
263 2 - not used
264 3 - the string is already a valid match (but longer matches exist too)
265 4 - the string was completed to a valid match
266 5 - some completion has been done, but the result is not a match
267 6 - no completion was done, and the string is not an exact match"
268
269 (if (not (crm-find-current-element))
270 nil
271 (let (last completion completedp)
272 (setq completion
273 (try-completion crm-current-element
274 minibuffer-completion-table
275 minibuffer-completion-predicate))
276 (setq last crm-last-exact-completion)
277 (setq crm-last-exact-completion nil)
278
279 (catch 'crm-exit
280
281 (if (null completion) ; no possible completion
282 (progn
283 (crm-temp-echo-area-glyphs " [No match]")
284 (throw 'crm-exit 0)))
285
286 (if (eq completion t) ; was already an exact and unique completion
287 (throw 'crm-exit 1))
288
289 (setq completedp
290 (null (string-equal completion crm-current-element)))
291
292 (if completedp
293 (progn
294 (delete-region (minibuffer-prompt-end) (point-max))
295 (insert crm-left-of-element completion)
296 ;; (if crm-complete-up-to-point
297 ;; (insert crm-separator))
298 (insert crm-right-of-element)
299 (backward-char (length crm-right-of-element))
300 ;; TODO: is this correct?
301 (setq crm-current-element completion)))
302
303 (if (null (crm-test-completion crm-current-element))
304 (progn
305 (if completedp ; some completion happened
306 (throw 'crm-exit 5)
307 (if completion-auto-help
308 (crm-minibuffer-completion-help)
309 (crm-temp-echo-area-glyphs " [Next char not unique]")))
310 (throw 'crm-exit 6))
311 (if completedp
312 (throw 'crm-exit 4)))
313
314 (setq crm-last-exact-completion completion)
315 (if (not (null last))
316 (progn
317 (if (not (null (equal crm-current-element last)))
318 (crm-minibuffer-completion-help))))
319
320 ;; returning -- was already an exact completion
321 (throw 'crm-exit 3)))))
322
323 (defun crm-minibuffer-complete ()
324 "Complete the current element.
325 If no characters can be completed, display a list of possible completions.
326
327 Return t if the current element is now a valid match; otherwise return nil."
328 (interactive)
329 ;; take care of scrolling if necessary -- completely cribbed from minibuf.c
330 (if (not (eq last-command this-command))
331 ;; ok?
332 (setq minibuffer-scroll-window nil))
333 (let ((window minibuffer-scroll-window))
334 (if (and (not (null window))
335 ;; ok?
336 (not (null (window-buffer window))))
337 (let (tem)
338 (set-buffer (window-buffer window))
339 ;; ok?
340 (setq tem (pos-visible-in-window-p (point-max) window))
341 (if (not (null tem))
342 ;; ok?
343 (set-window-start window (point-min) nil)
344 (scroll-other-window nil))
345 ;; reaching here means exiting the function w/ return value of nil
346 nil)
347
348 (let* (
349 ;(crm-end-of-element nil)
350 (result (crm-do-completion)))
351 (cond
352 ((eq 0 result)
353 nil)
354 ((eq 1 result)
355 ;; adapted from Emacs 21
356 (if (not (eq (point) crm-end-of-element))
357 (goto-char (+ 1 crm-end-of-element)))
358 (crm-temp-echo-area-glyphs " [Sole completion]")
359 t)
360 ((eq 3 result)
361 ;; adapted from Emacs 21
362 (if (not (eq (point) crm-end-of-element))
363 (goto-char (+ 1 crm-end-of-element)))
364 (crm-temp-echo-area-glyphs " [Complete, but not unique]")
365 t))))))
366
367 ;; i love traffic lights...but only when they're green
368 (defun crm-find-longest-completable-substring (string)
369 "Determine the longest completable (left-anchored) substring of STRING.
370 The description \"left-anchored\" means the positions of the characters
371 in the substring must be the same as those of the corresponding characters
372 in STRING. Anchoring is what `^' does in a regular expression.
373
374 The table and predicate used for completion are
375 `minibuffer-completion-table' and `minibuffer-completion-predicate',
376 respectively.
377
378 A non-nil return value means that there is some substring which is
379 completable. A return value of t means that STRING itself is
380 completable. If a string value is returned it is the longest
381 completable proper substring of STRING. If nil is returned, STRING
382 does not have any non-empty completable substrings.
383
384 Remember: \"left-anchored\" substring"
385 (let* ((length-of-string (length string))
386 (index length-of-string)
387 (done (if (> length-of-string 0)
388 nil
389 t))
390 (first t) ; ugh, special handling for first time through...
391 goal-string
392 result)
393 ;; loop through left-anchored substrings in order of descending length,
394 ;; find the first substring that is completable
395 (while (not done)
396 (setq result (try-completion (substring string 0 index)
397 minibuffer-completion-table
398 minibuffer-completion-predicate))
399 (if result
400 ;; found completable substring
401 (progn
402 (setq done t)
403 (if (and (eq result t) first)
404 ;; exactly matching string first time through
405 (setq goal-string t)
406 ;; fully-completed proper substring
407 (setq goal-string (substring string 0 index)))))
408 (setq index (1- index))
409 (if first
410 (setq first nil))
411 (if (<= index 0)
412 (setq done t)))
413 ;; possible values include: t, nil, some string
414 goal-string))
415
416 ;; TODO: decide whether trailing separator is allowed. current
417 ;; implementation appears to allow it
418 (defun crm-strings-completed-p (separated-string)
419 "Verify that strings in SEPARATED-STRING are completed strings.
420 A return value of t means that all strings were verified. A number is
421 returned if verification was unsuccessful. This number represents the
422 position in SEPARATED-STRING up to where completion was successful."
423 (let ((strings (split-string separated-string crm-separator))
424 ;; buffers start at 1, not 0
425 (current-position 1)
426 current-string
427 result
428 done)
429 (while (and strings (not done))
430 (setq current-string (car strings)
431 result (try-completion current-string
432 minibuffer-completion-table
433 minibuffer-completion-predicate))
434 (if (eq result t)
435 (setq strings (cdr strings)
436 current-position (+ current-position
437 (length current-string)
438 ;; automatically adding 1 for separator
439 ;; character
440 1))
441 ;; still one more case of a match
442 (if (stringp result)
443 (let ((string-list
444 (all-completions result
445 minibuffer-completion-table
446 minibuffer-completion-predicate)))
447 (if (member result string-list)
448 ;; ho ho, code duplication...
449 (setq strings (cdr strings)
450 current-position (+ current-position
451 (length current-string)
452 1))
453 (progn
454 (setq done t)
455 ;; current-string is a partially-completed string
456 (setq current-position (+ current-position
457 (length current-string))))))
458 ;; current-string cannot be completed
459 (let ((completable-substring
460 (crm-find-longest-completable-substring current-string)))
461 (setq done t)
462 (setq current-position (+ current-position
463 (length completable-substring)))))))
464 ;; return our result
465 (if (null strings)
466 t
467 current-position)))
468
469 ;; try to complete candidate, then check all separated strings. move
470 ;; point to problem position if checking fails for some string. if
471 ;; checking succeeds for all strings, exit.
472 (defun crm-minibuffer-complete-and-exit ()
473 "If all of the minibuffer elements are valid completions then exit.
474 All elements in the minibuffer must match. If there is a mismatch, move point
475 to the location of mismatch and do not exit.
476
477 This function is modeled after `minibuffer_complete_and_exit' in src/minibuf.c"
478 (interactive)
479
480 (if (not (crm-find-current-element))
481 nil
482 (let (result)
483
484 (setq result
485 (catch 'crm-exit
486
487 (if (eq (minibuffer-prompt-end) (point-max))
488 (throw 'crm-exit t))
489
490 ;; TODO: this test is suspect?
491 (if (not (null (crm-test-completion crm-current-element)))
492 (throw 'crm-exit "check"))
493
494 ;; TODO: determine how to detect errors
495 (let ((result (crm-do-completion)))
496
497 (cond
498 ((or (eq 1 result)
499 (eq 3 result))
500 (throw 'crm-exit "check"))
501 ((eq 4 result)
502 (if (not (null minibuffer-completion-confirm))
503 (progn
504 (crm-temp-echo-area-glyphs " [Confirm]")
505 nil)
506 (throw 'crm-exit "check")))
507 (nil)))))
508
509 (if (null result)
510 nil
511 (if (equal result "check")
512 (let ((check-strings
513 (crm-strings-completed-p
514 (buffer-substring (minibuffer-prompt-end) (point-max)))))
515 ;; check all of minibuffer
516 (if (eq check-strings t)
517 (throw 'exit nil)
518 (if (numberp check-strings)
519 (progn
520 (goto-char check-strings)
521 (crm-temp-echo-area-glyphs " [An element did not match]"))
522 (message "Unexpected error"))))
523 (if (eq result t)
524 (throw 'exit nil)
525 (message "Unexpected error")))))))
526
527 (defun crm-init-keymaps ()
528 "Initialize the keymaps used by `completing-read-multiple'.
529 Two keymaps are used depending on the value of the REQUIRE-MATCH
530 argument of the function `completing-read-multiple'.
531
532 If REQUIRE-MATCH is nil, the keymap `crm-local-completion-map' is used.
533 This keymap inherits from the keymap named `minibuffer-local-completion-map'.
534 The only difference is that TAB is bound to `crm-minibuffer-complete' in
535 the inheriting keymap.
536
537 If REQUIRE-MATCH is non-nil, the keymap `crm-local-must-match-map' is used.
538 This keymap inherits from the keymap named `minibuffer-local-must-match-map'.
539 The inheriting keymap binds RET to `crm-minibuffer-complete-and-exit'
540 and TAB to `crm-minibuffer-complete'."
541 (unless crm-local-completion-map
542 (setq crm-local-completion-map (make-sparse-keymap))
543 (set-keymap-parent crm-local-completion-map
544 minibuffer-local-completion-map)
545 ;; key definitions
546 (define-key crm-local-completion-map
547 (kbd "TAB")
548 (function crm-minibuffer-complete)))
549
550 (unless crm-local-must-match-map
551 (setq crm-local-must-match-map (make-sparse-keymap))
552 (set-keymap-parent crm-local-must-match-map
553 minibuffer-local-must-match-map)
554 ;; key definitions
555 (define-key crm-local-must-match-map
556 (kbd "RET")
557 (function crm-minibuffer-complete-and-exit))
558 (define-key crm-local-must-match-map
559 (kbd "TAB")
560 (function crm-minibuffer-complete))))
561
562 (crm-init-keymaps)
563
564 ;; superemulates behavior of completing_read in src/minibuf.c
565 ;;;###autoload
566 (defun completing-read-multiple
567 (prompt table &optional predicate require-match initial-input
568 hist def inherit-input-method)
569 "Read multiple strings in the minibuffer, with completion.
570 By using this functionality, a user may specify multiple strings at a
571 single prompt, optionally using completion.
572
573 Multiple strings are specified by separating each of the strings with
574 a prespecified separator character. For example, if the separator
575 character is a comma, the strings 'alice', 'bob', and 'eve' would be
576 specified as 'alice,bob,eve'.
577
578 The default value for the separator character is the value of
579 `crm-default-separator' (comma). The separator character may be
580 changed by modifying the value of `crm-separator'.
581
582 Contiguous strings of non-separator-characters are referred to as
583 'elements'. In the aforementioned example, the elements are: 'alice',
584 'bob', and 'eve'.
585
586 Completion is available on a per-element basis. For example, if the
587 contents of the minibuffer are 'alice,bob,eve' and point is between
588 'l' and 'i', pressing TAB operates on the element 'alice'.
589
590 The return value of this function is a list of the read strings.
591
592 See the documentation for `completing-read' for details on the arguments:
593 PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, HIST, DEF, and
594 INHERIT-INPUT-METHOD."
595 (let ((minibuffer-completion-table (function crm-collection-fn))
596 (minibuffer-completion-predicate predicate)
597 ;; see completing_read in src/minibuf.c
598 (minibuffer-completion-confirm
599 (unless (eq require-match t) require-match))
600 (crm-completion-table table)
601 crm-last-exact-completion
602 crm-current-element
603 crm-left-of-element
604 crm-right-of-element
605 crm-beginning-of-element
606 crm-end-of-element
607 (map (if require-match
608 crm-local-must-match-map
609 crm-local-completion-map)))
610 (split-string (read-from-minibuffer
611 prompt initial-input map
612 nil hist def inherit-input-method)
613 crm-separator)))
614
615 ;; testing and debugging
616 ;; (defun crm-init-test-environ ()
617 ;; "Set up some variables for testing."
618 ;; (interactive)
619 ;; (setq my-prompt "Prompt: ")
620 ;; (setq my-table
621 ;; '(("hi") ("there") ("man") ("may") ("mouth") ("ma")
622 ;; ("a") ("ab") ("abc") ("abd") ("abf") ("zab") ("acb")
623 ;; ("da") ("dab") ("dabc") ("dabd") ("dabf") ("dzab") ("dacb")
624 ;; ("fda") ("fdab") ("fdabc") ("fdabd") ("fdabf") ("fdzab") ("fdacb")
625 ;; ("gda") ("gdab") ("gdabc") ("gdabd") ("gdabf") ("gdzab") ("gdacb")
626 ;; ))
627 ;; (setq my-separator ","))
628
629 ;(completing-read-multiple my-prompt my-table)
630 ;(completing-read-multiple my-prompt my-table nil t)
631 ;(completing-read-multiple my-prompt my-table nil "match")
632 ;(completing-read my-prompt my-table nil t)
633 ;(completing-read my-prompt my-table nil "match")
634
635 (provide 'crm)
636
637 ;;; arch-tag: db1911d9-86c6-4a42-b32a-4910701b15a6
638 ;;; crm.el ends here