Mercurial > emacs

changeset 94090:6027fc6333c9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Complete rewrite.
author Stefan Monnier <monnier@iro.umontreal.ca>
date Mon, 14 Apr 2008 19:54:30 +0000
parents 01d0ddc5bfce
children 14fafab62797
files lisp/ChangeLog lisp/emacs-lisp/crm.el
diffstat 2 files changed, 105 insertions(+), 434 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Mon Apr 14 18:44:04 2008 +0000
+++ b/lisp/ChangeLog	Mon Apr 14 19:54:30 2008 +0000
@@ -1,5 +1,7 @@
 2008-04-14  Stefan Monnier  <monnier@iro.umontreal.ca>
 
+	* emacs-lisp/crm.el: Complete rewrite.
+
 	* tmm.el (tmm-completion-delete-prompt): Don't hardcode point-min==1.
 	(tmm-add-prompt): Make sure completion-setup-hook is preserved even in
 	case of an error in display-completion-list.
--- a/lisp/emacs-lisp/crm.el	Mon Apr 14 18:44:04 2008 +0000
+++ b/lisp/emacs-lisp/crm.el	Mon Apr 14 19:54:30 2008 +0000
@@ -60,7 +60,12 @@
 ;; `completing-read'.  They should be similar -- it was intentional.
 
 ;; Some of this code started out as translation from C code in
-;; src/minibuf.c to Emacs Lisp code.
+;; src/minibuf.c to Emacs Lisp code.  After this code was rewritten in Elisp
+;; and made to operate on any field, this file was completely rewritten to
+;; just reuse that code.
+
+;; Thanks to Sen Nagata <sen@eccosys.com> for the original version of the
+;; code, and sorry for throwing it all out.  --Stef
 
 ;; Thanks to Richard Stallman for all of his help (many of the good
 ;; ideas in here are from him), Gerd Moellmann for his attention,
@@ -69,20 +74,23 @@
 
 ;;; Questions and Thoughts:
 
-;; -the author has gone through a number of test-and-fix cycles w/
-;;  this code, so it should be usable.  please let me know if you find
-;;  any problems.
-
 ;; -should `completing-read-multiple' allow a trailing separator in
 ;; a return value when REQUIRE-MATCH is t?  if not, should beep when a user
 ;; tries to exit the minibuffer via RET?
 
-;; -TODO: possibly make return values from `crm-do-completion' into constants
+;; -tip: use M-f and M-b for ease of navigation among elements.
 
-;; -TODO: find out whether there is an appropriate way to distinguish between
-;;        functions intended for internal use and those that aren't.
-
-;; -tip: use M-f and M-b for ease of navigation among elements.
+;; - the difference between minibuffer-completion-table and
+;;   crm-completion-table is just crm--collection-fn.  In most cases it
+;;   shouldn't make any difference.  But if a non-CRM completion function
+;;   happens to be used, it will use minibuffer-completion-table and
+;;   crm--collection-fn will try to make it do "more or less the right
+;;   thing" by making it complete on the last element, which is about as
+;;   good as we can hope for right now.
+;;   I'm not sure if it's important or not.  Maybe we could just throw away
+;;   crm-completion-table and crm--collection-fn, but there doesn't seem to
+;;   be a pressing need for it, and since Sen did bother to write it, we may
+;;   as well keep it, in case it helps.
 
 ;;; History:
 ;;
@@ -100,12 +108,26 @@
 completion candidates.  Modify this value to make `completing-read-multiple'
 use a separator other than `crm-default-separator'.")
 
-;; actual filling in of these maps occurs below via `crm-init-keymaps'
-(defvar crm-local-completion-map nil
+(defvar crm-local-completion-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map minibuffer-local-completion-map)
+    (define-key map [remap minibuffer-complete] #'crm-complete)
+    (define-key map [remap minibuffer-complete-word] #'crm-complete-word)
+    (define-key map [remap minibuffer-completion-help] #'crm-completion-help)
+    map)
   "Local keymap for minibuffer multiple input with completion.
 Analog of `minibuffer-local-completion-map'.")
 
-(defvar crm-local-must-match-map nil
+(defvar crm-local-must-match-map
+  (let ((map (make-sparse-keymap)))
+    ;; We'd want to have multiple inheritance here.
+    (set-keymap-parent map minibuffer-local-must-match-map)
+    (define-key map [remap minibuffer-complete] #'crm-complete)
+    (define-key map [remap minibuffer-complete-word] #'crm-complete-word)
+    (define-key map [remap minibuffer-completion-help] #'crm-completion-help)
+    (define-key map [remap minibuffer-complete-and-exit]
+      #'crm-complete-and-exit)
+    map)
   "Local keymap for minibuffer multiple input with exact match completion.
 Analog of `minibuffer-local-must-match-map' for crm.")
 
@@ -114,38 +136,8 @@
 This is a table used for completion by `completing-read-multiple' and its
 supporting functions.")
 
-;; this is supposed to be analogous to last_exact_completion in src/minibuf.c
-(defvar crm-last-exact-completion nil
-  "Completion string if last attempt reported \"Complete, but not unique\".")
-
-(defvar crm-left-of-element nil
-  "String to the left of the current element.")
-
-(defvar crm-current-element nil
-  "The current element.")
-
-(defvar crm-right-of-element nil
-  "String to the right of the current element.")
-
-(defvar crm-beginning-of-element nil
-  "Buffer position representing the beginning of the current element.")
-
-(defvar crm-end-of-element nil
-  "Buffer position representing the end of the current element.")
-
-;; emulates temp_echo_area_glyphs from src/minibuf.c
-(defun crm-temp-echo-area-glyphs (message-string)
-  "Temporarily display MESSAGE-STRING in echo area.
-After user-input or 2 seconds, erase the displayed string."
-  (save-excursion
-    (goto-char (point-max))
-    (insert message-string)
-    (sit-for 2)
-    (backward-char (length message-string))
-    (delete-char (length message-string))))
-
 ;; this function evolved from a posting by Stefan Monnier
-(defun crm-collection-fn (string predicate flag)
+(defun crm--collection-fn (string predicate flag)
   "Function used by `completing-read-multiple' to compute completion values.
 The value of STRING is the string to be completed.
 
@@ -159,407 +151,84 @@
 For more information on STRING, PREDICATE, and FLAG, see the Elisp
 Reference sections on 'Programmed Completion' and 'Basic Completion
 Functions'."
-  (let ((lead ""))
-    (when (string-match (concat ".*" crm-separator) string)
-      (setq lead (substring string 0 (match-end 0)))
-      (setq string (substring string (match-end 0))))
-    (if (eq flag 'lambda)
-	;; return t for exact match, nil otherwise
-	(let ((result (try-completion string crm-completion-table predicate)))
-	  (if (stringp result)
-	      nil
-	    (if result
-		t
-	      nil))))
-      (if flag
-	  ;; called via (all-completions string 'crm-completion-fn predicate)?
-	  (all-completions string crm-completion-table predicate)
-	;; called via (try-completion string 'crm-completion-fn predicate)?
-	(let ((result (try-completion string crm-completion-table predicate)))
-	  (if (stringp result)
-	      (concat lead result)
-	    result)))))
-
-(defun crm-find-current-element ()
-  "Parse the minibuffer to find the current element.
-If no element can be found, return nil.
-
-If an element is found, bind:
-
-  -the variable `crm-current-element' to the current element,
-
-  -the variables `crm-left-of-element' and `crm-right-of-element' to
-   the strings to the left and right of the current element,
-   respectively, and
-
-  -the variables `crm-beginning-of-element' and `crm-end-of-element' to
-   the buffer positions of the beginning and end of the current element
-   respectively,
+  (let ((beg 0))
+    (while (string-match crm-separator string beg)
+      (setq beg (match-end 0)))
+    (completion-table-with-context (substring string 0 beg)
+                                   crm-completion-table
+                                   (substring string beg)
+                                   predicate
+                                   flag)))
 
-and return t."
-  (let* ((prompt-end (minibuffer-prompt-end))
-	 (minibuffer-string (buffer-substring prompt-end (point-max)))
-	 (end-index (or (string-match "," minibuffer-string (- (point) prompt-end))
-			(- (point-max) prompt-end)))
-	 (target-string (substring minibuffer-string 0 end-index))
-	 (index (or (string-match
-		     (concat crm-separator "\\([^" crm-separator "]*\\)$")
-		     target-string)
-		    (string-match
-		     (concat "^\\([^" crm-separator "]*\\)$")
-		     target-string))))
-    (if (not (numberp index))
-	;; no candidate found
-	nil
-      (progn
-	;;
-	(setq crm-beginning-of-element (match-beginning 1))
-	(setq crm-end-of-element (+ end-index prompt-end))
-	;; string to the left of the current element
-	(setq crm-left-of-element
-	      (substring target-string 0 (match-beginning 1)))
-	;; the current element
-	(setq crm-current-element (match-string 1 target-string))
-	;; string to the right of the current element
-	(setq crm-right-of-element (substring minibuffer-string end-index))
-	t))))
+(defun crm--select-current-element ()
+  "Parse the minibuffer to find the current element.
+Place an overlay on the element, with a `field' property, and return it."
+  (let* ((bob (minibuffer-prompt-end))
+         (start (save-excursion
+                  (if (re-search-backward crm-separator bob t)
+                      (match-end 0)
+                    bob)))
+         (end (save-excursion
+                (if (re-search-forward crm-separator nil t)
+                    (match-beginning 0)
+                  (point-max))))
+         (ol (make-overlay start end nil nil t)))
+    (overlay-put ol 'field (make-symbol "crm"))
+    ol))
 
-(defun crm-test-completion (candidate)
-  "Return t if CANDIDATE is an exact match for a valid completion."
-  (let ((completions
-	 ;; TODO: verify whether the arguments are appropriate
-	 (all-completions
-	  candidate crm-completion-table minibuffer-completion-predicate)))
-    (if (member candidate completions)
-	t
-      nil)))
-
-(defun crm-minibuffer-completion-help ()
+(defun crm-completion-help ()
   "Display a list of possible completions of the current minibuffer element."
   (interactive)
-  (message "Making completion list...")
-  (if (not (crm-find-current-element))
-      nil
-    (let ((completions (all-completions crm-current-element
-					minibuffer-completion-table
-					minibuffer-completion-predicate)))
-      (message nil)
-      (if (null completions)
-	  (crm-temp-echo-area-glyphs " [No completions]")
-	(with-output-to-temp-buffer "*Completions*"
-	  (display-completion-list
-	   (sort completions 'string-lessp)
-	   crm-current-element)))))
+  (let ((ol (crm-select-current-element)))
+    (unwind-protect
+        (minibuffer-completion-help)
+      (delete-overlay ol)))
   nil)
 
-(defun crm-do-completion ()
-  "This is the internal completion engine.
-This function updates the text in the minibuffer
-to complete the current string, and returns a number between 0 and 6.
-The meanings of the return values are:
-
-    0 - the string has no possible completion
-    1 - the string is already a valid and unique match
-    2 - not used
-    3 - the string is already a valid match (but longer matches exist too)
-    4 - the string was completed to a valid match
-    5 - some completion has been done, but the result is not a match
-    6 - no completion was done, and the string is not an exact match"
-
-  (if (not (crm-find-current-element))
-      nil
-    (let (last completion completedp)
-      (setq completion
-	    (try-completion crm-current-element
-			    minibuffer-completion-table
-			    minibuffer-completion-predicate))
-      (setq last crm-last-exact-completion)
-      (setq crm-last-exact-completion nil)
-
-      (catch 'crm-exit
-
-	(if (null completion) ; no possible completion
-	    (progn
-	      (crm-temp-echo-area-glyphs " [No match]")
-	      (throw 'crm-exit 0)))
-
-	(if (eq completion t) ; was already an exact and unique completion
-	    (throw 'crm-exit 1))
-
-	(setq completedp
-	      (null (string-equal completion crm-current-element)))
-
-	(if completedp
-	    (progn
-	      (delete-region (minibuffer-prompt-end) (point-max))
-	      (insert crm-left-of-element completion)
-	      ;;		(if crm-complete-up-to-point
-	      ;;		    (insert crm-separator))
-	      (insert crm-right-of-element)
-	      (backward-char (length crm-right-of-element))
-	      ;; TODO: is this correct?
-	      (setq crm-current-element completion)))
-
-	(if (null (crm-test-completion crm-current-element))
-	    (progn
-	      (if completedp ; some completion happened
-		  (throw 'crm-exit 5)
-		(if completion-auto-help
-		    (crm-minibuffer-completion-help)
-		  (crm-temp-echo-area-glyphs " [Next char not unique]")))
-	      (throw 'crm-exit 6))
-	  (if completedp
-	      (throw 'crm-exit 4)))
-
-	(setq crm-last-exact-completion completion)
-	(if (not (null last))
-	    (progn
-	      (if (not (null (equal crm-current-element last)))
-		  (crm-minibuffer-completion-help))))
-
-	;; returning -- was already an exact completion
-	(throw 'crm-exit 3)))))
-
-(defun crm-minibuffer-complete ()
+(defun crm-complete ()
   "Complete the current element.
 If no characters can be completed, display a list of possible completions.
 
 Return t if the current element is now a valid match; otherwise return nil."
   (interactive)
-  ;; take care of scrolling if necessary -- completely cribbed from minibuf.c
-  (if (not (eq last-command this-command))
-      ;; ok?
-      (setq minibuffer-scroll-window nil))
-  (let ((window minibuffer-scroll-window))
-    (if (and (not (null window))
-	     ;; ok?
-	     (not (null (window-buffer window))))
-	(let (tem)
-	  (set-buffer (window-buffer window))
-	  ;; ok?
-	  (setq tem (pos-visible-in-window-p (point-max) window))
-	  (if (not (null tem))
-	      ;; ok?
-	      (set-window-start window (point-min) nil)
-	    (scroll-other-window nil))
-	  ;; reaching here means exiting the function w/ return value of nil
-	  nil)
-
-      (let* (
-	     ;(crm-end-of-element nil)
-	     (result (crm-do-completion)))
-	(cond
-	((eq 0 result)
-	 nil)
-	((eq 1 result)
-	 ;; adapted from Emacs 21
-	 (if (not (eq (point) crm-end-of-element))
-	     (goto-char (+ 1 crm-end-of-element)))
-	 (crm-temp-echo-area-glyphs " [Sole completion]")
-	 t)
-	((eq 3 result)
-	 ;; adapted from Emacs 21
-	 (if (not (eq (point) crm-end-of-element))
-	     (goto-char (+ 1 crm-end-of-element)))
-	 (crm-temp-echo-area-glyphs " [Complete, but not unique]")
-	 t))))))
-
-;; i love traffic lights...but only when they're green
-(defun crm-find-longest-completable-substring (string)
-  "Determine the longest completable (left-anchored) substring of STRING.
-The description \"left-anchored\" means the positions of the characters
-in the substring must be the same as those of the corresponding characters
-in STRING.  Anchoring is what `^' does in a regular expression.
-
-The table and predicate used for completion are
-`minibuffer-completion-table' and `minibuffer-completion-predicate',
-respectively.
-
-A non-nil return value means that there is some substring which is
-completable.  A return value of t means that STRING itself is
-completable.  If a string value is returned it is the longest
-completable proper substring of STRING.  If nil is returned, STRING
-does not have any non-empty completable substrings.
+  (let ((ol (crm-select-current-element)))
+    (unwind-protect
+        (minibuffer-complete)
+      (delete-overlay ol))))
 
-Remember: \"left-anchored\" substring"
-  (let* ((length-of-string (length string))
-	 (index length-of-string)
-	 (done (if (> length-of-string 0)
-		   nil
-		 t))
-	 (first t) ; ugh, special handling for first time through...
-	 goal-string
-	 result)
-    ;; loop through left-anchored substrings in order of descending length,
-    ;; find the first substring that is completable
-    (while (not done)
-      (setq result (try-completion (substring string 0 index)
-				   minibuffer-completion-table
-				   minibuffer-completion-predicate))
-      (if result
-	  ;; found completable substring
-	  (progn
-	    (setq done t)
-	    (if (and (eq result t) first)
-		;; exactly matching string first time through
-		(setq goal-string t)
-	      ;; fully-completed proper substring
-	      (setq goal-string (substring string 0 index)))))
-      (setq index (1- index))
-      (if first
-	  (setq first nil))
-      (if (<= index 0)
-	  (setq done t)))
-    ;; possible values include: t, nil, some string
-    goal-string))
+(defun crm-complete-word ()
+  "Complete the current element at most a single word.
+Like `minibuffer-complete-word' but for `completing-read-multiple'."
+  (interactive)
+  (let ((ol (crm-select-current-element)))
+    (unwind-protect
+        (minibuffer-complete-word)
+      (delete-overlay ol))))
 
-;; TODO: decide whether trailing separator is allowed.  current
-;;       implementation appears to allow it
-(defun crm-strings-completed-p (separated-string)
-  "Verify that strings in SEPARATED-STRING are completed strings.
-A return value of t means that all strings were verified.  A number is
-returned if verification was unsuccessful.  This number represents the
-position in SEPARATED-STRING up to where completion was successful."
-  (let ((strings (split-string separated-string crm-separator))
-	;; buffers start at 1, not 0
-	(current-position 1)
-	current-string
-	result
-	done)
-    (while (and strings (not done))
-      (setq current-string (car strings)
-	    result (try-completion current-string
-				   minibuffer-completion-table
-				   minibuffer-completion-predicate))
-      (if (eq result t)
-	  (setq strings (cdr strings)
-		current-position (+ current-position
-				    (length current-string)
-				    ;; automatically adding 1 for separator
-				    ;; character
-				    1))
-	;; still one more case of a match
-	(if (stringp result)
-	    (let ((string-list
-		   (all-completions result
-				    minibuffer-completion-table
-				    minibuffer-completion-predicate)))
-	      (if (member result string-list)
-		  ;; ho ho, code duplication...
-		  (setq strings (cdr strings)
-			current-position (+ current-position
-					    (length current-string)
-					    1))
-		(progn
-		  (setq done t)
-		  ;; current-string is a partially-completed string
-		  (setq current-position (+ current-position
-					    (length current-string))))))
-	  ;; current-string cannot be completed
-	  (let ((completable-substring
-		 (crm-find-longest-completable-substring current-string)))
-	    (setq done t)
-	    (setq current-position (+ current-position
-				      (length completable-substring)))))))
-    ;; return our result
-    (if (null strings)
-	t
-      current-position)))
-
-;; try to complete candidate, then check all separated strings.  move
-;; point to problem position if checking fails for some string.  if
-;; checking succeeds for all strings, exit.
-(defun crm-minibuffer-complete-and-exit ()
+(defun crm-complete-and-exit ()
   "If all of the minibuffer elements are valid completions then exit.
 All elements in the minibuffer must match.  If there is a mismatch, move point
 to the location of mismatch and do not exit.
 
-This function is modeled after `minibuffer_complete_and_exit' in src/minibuf.c"
+This function is modeled after `minibuffer-complete-and-exit'."
   (interactive)
-
-  (if (not (crm-find-current-element))
-      nil
-    (let (result)
-
-      (setq result
-	    (catch 'crm-exit
-
-	      (if (eq (minibuffer-prompt-end) (point-max))
-		  (throw 'crm-exit t))
-
-	      ;; TODO: this test is suspect?
-	      (if (not (null (crm-test-completion crm-current-element)))
-		  (throw 'crm-exit "check"))
-
-	      ;; TODO: determine how to detect errors
-	      (let ((result (crm-do-completion)))
-
-		(cond
-		 ((or (eq 1 result)
-		      (eq 3 result))
-		  (throw 'crm-exit "check"))
-		 ((eq 4 result)
-		  (if (not (null minibuffer-completion-confirm))
-		      (progn
-			(crm-temp-echo-area-glyphs " [Confirm]")
-			nil)
-		    (throw 'crm-exit "check")))
-		 (nil)))))
-
-      (if (null result)
-	  nil
-	(if (equal result "check")
-	    (let ((check-strings
-		   (crm-strings-completed-p
-		    (buffer-substring (minibuffer-prompt-end) (point-max)))))
-	      ;; check all of minibuffer
-	      (if (eq check-strings t)
-		  (throw 'exit nil)
-		(if (numberp check-strings)
-		    (progn
-		      (goto-char check-strings)
-		      (crm-temp-echo-area-glyphs " [An element did not match]"))
-		  (message "Unexpected error"))))
-	  (if (eq result t)
-	      (throw 'exit nil)
-	    (message "Unexpected error")))))))
-
-(defun crm-init-keymaps ()
-  "Initialize the keymaps used by `completing-read-multiple'.
-Two keymaps are used depending on the value of the REQUIRE-MATCH
-argument of the function `completing-read-multiple'.
-
-If REQUIRE-MATCH is nil, the keymap `crm-local-completion-map' is used.
-This keymap inherits from the keymap named `minibuffer-local-completion-map'.
-The only difference is that TAB is bound to `crm-minibuffer-complete' in
-the inheriting keymap.
-
-If REQUIRE-MATCH is non-nil, the keymap `crm-local-must-match-map' is used.
-This keymap inherits from the keymap named `minibuffer-local-must-match-map'.
-The inheriting keymap binds RET to `crm-minibuffer-complete-and-exit'
-and TAB to `crm-minibuffer-complete'."
-  (unless crm-local-completion-map
-    (setq crm-local-completion-map (make-sparse-keymap))
-    (set-keymap-parent crm-local-completion-map
-		       minibuffer-local-completion-map)
-    ;; key definitions
-    (define-key crm-local-completion-map
-      (kbd "TAB")
-      (function crm-minibuffer-complete)))
-
-  (unless crm-local-must-match-map
-    (setq crm-local-must-match-map (make-sparse-keymap))
-    (set-keymap-parent crm-local-must-match-map
-		       minibuffer-local-must-match-map)
-    ;; key definitions
-    (define-key crm-local-must-match-map
-      (kbd "RET")
-      (function crm-minibuffer-complete-and-exit))
-    (define-key crm-local-must-match-map
-      (kbd "TAB")
-      (function crm-minibuffer-complete))))
-
-(crm-init-keymaps)
+  (let ((doexit t))
+    (goto-char (minibuffer-prompt-end))
+    (while
+        (and doexit
+             (let ((ol (crm-select-current-element)))
+               (goto-char (overlay-end ol))
+               (unwind-protect
+                   (catch 'exit
+                     (minibuffer-complete-and-exit)
+                     ;; This did not throw `exit', so there was a problem.
+                     (setq doexit nil))
+                 (goto-char (overlay-end ol))
+                 (delete-overlay ol))
+               (not (eobp))))
+      ;; Skip to the next element.
+      (forward-char 1))
+    (if doexit (exit-minibuffer))))
 
 ;; superemulates behavior of completing_read in src/minibuf.c
 ;;;###autoload
@@ -592,18 +261,12 @@
 See the documentation for `completing-read' for details on the arguments:
 PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-INPUT, HIST, DEF, and
 INHERIT-INPUT-METHOD."
-  (let* ((minibuffer-completion-table (function crm-collection-fn))
+  (let* ((minibuffer-completion-table #'crm--collection-fn)
 	 (minibuffer-completion-predicate predicate)
 	 ;; see completing_read in src/minibuf.c
 	 (minibuffer-completion-confirm
 	  (unless (eq require-match t) require-match))
 	 (crm-completion-table table)
-	 crm-last-exact-completion
-	 crm-current-element
-	 crm-left-of-element
-	 crm-right-of-element
-	 crm-beginning-of-element
-	 crm-end-of-element
 	 (map (if require-match
 		  crm-local-must-match-map
 		crm-local-completion-map))
@@ -615,6 +278,12 @@
     (and def (string-equal input "") (setq input def))
     (split-string input crm-separator)))
 
+(define-obsolete-function-alias 'crm-minibuffer-complete 'crm-complete "23.1")
+(define-obsolete-function-alias
+  'crm-minibuffer-completion-help 'crm-completion-help "23.1")
+(define-obsolete-function-alias
+  'crm-minibuffer-complete-and-exit 'crm-complete-and-exit "23.1")
+
 ;; testing and debugging
 ;; (defun crm-init-test-environ ()
 ;;   "Set up some variables for testing."