Complete rewrite.

2 files changed, 108 insertions, 437 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index a43325c7b5b..c6102575cf6 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -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.
diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el
index 4b0dcb32d58..85372771853 100644
--- a/lisp/emacs-lisp/crm.el
+++ b/lisp/emacs-lisp/crm.el
@@ -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,21 +74,24 @@
 
 ;;; 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
-
-;; -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:
 ;;
 ;; 2000-04-10:
@@ -100,12 +108,26 @@ It should be a single character string that doesn't appear in the list of
 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 @@ Analog of `minibuffer-local-must-match-map' for crm.")
 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 @@ A value of nil specifies `try-completion'.  A value of t specifies
 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 ()
+  (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)))
+
+(defun crm--select-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,
-
-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-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 ()
+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-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.
-
-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))
-
-;; 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 ()
+  (let ((ol (crm-select-current-element)))
+    (unwind-protect
+        (minibuffer-complete)
+      (delete-overlay ol))))
+
+(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))))
+
+(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 @@ The return value of this function is a list of the read strings.
 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 @@ INHERIT-INPUT-METHOD."
     (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."