[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to emacs/lisp/emacs-lisp/crm.el,v
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] Changes to emacs/lisp/emacs-lisp/crm.el,v |
|
Date: |
Mon, 14 Apr 2008 19:54:31 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Stefan Monnier <monnier> 08/04/14 19:54:30
Index: emacs-lisp/crm.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/emacs-lisp/crm.el,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -b -r1.17 -r1.18
--- emacs-lisp/crm.el 10 Apr 2008 14:09:49 -0000 1.17
+++ emacs-lisp/crm.el 14 Apr 2008 19:54:30 -0000 1.18
@@ -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 <address@hidden> 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 @@
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)))))
+ (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-find-current-element ()
+(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,
+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))
- -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 ()
+(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 ((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))))
- (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 ()
+(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."