comparison lisp/minibuffer.el @ 94304:bc48ced5cf89

(completion-try-completion): Add `point' argument. Change return value. (completion-all-completions): Add `point' argument. (minibuffer-completion-help): Pass the new `point' argument. (completion--do-completion): Pass the whole field to try-completion. (completion--try-word-completion): Rewrite, making fewer assumptions. (completion-emacs21-try-completion, completion-emacs21-all-completions) (completion-emacs22-try-completion, completion-emacs22-all-completions) (completion-basic-try-completion, completion-basic-all-completions): New funs. (completion-styles-alist): Use them.

94303:e0b01f455de0

;; Names starting with "minibuffer--" are for functions and variables that
;; are meant to be for internal use only.

;;; Todo:

;; - New command minibuffer-force-complete that chooses one of all-completions.
;; - Add vc-file-name-completion-table to read-file-name-internal.
;; - A feature like completing-help.el.
;; - Make the `hide-spaces' arg of all-completions obsolete?

the second failed attempt to complete."
  :type '(choice (const nil) (const t) (const lazy))
  :group 'minibuffer)

(defvar completion-styles-alist
  '((basic try-completion all-completions)
    ;; (partial-completion
    ;;  completion-pcm--try-completion completion-pcm--all-completions)
    )
  "List of available completion styles.
Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS)

  :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x)))
                                   completion-styles-alist)))
  :group 'minibuffer
  :version "23.1")

(defun completion-try-completion (string table pred)
  ;; The property `completion-styles' indicates that this functional
  ;; completion-table claims to take care of completion styles itself.
  ;; [I.e. It will most likely call us back at some point. ]
  (if (and (symbolp table) (get table 'completion-styles))
      (funcall table string pred nil)
    (completion--some (lambda (style)
                        (funcall (nth 1 (assq style completion-styles-alist))
                                 string table pred))
                      completion-styles)))

(defun completion-all-completions (string table pred)
  ;; The property `completion-styles' indicates that this functional
  ;; completion-table claims to take care of completion styles itself.
  ;; [I.e. It will most likely call us back at some point. ]
  (let ((completion-all-completions-with-base-size t))
    (if (and (symbolp table) (get table 'no-completion-styles))
        (funcall table string pred t)
      (completion--some (lambda (style)
                          (funcall (nth 2 (assq style completion-styles-alist))
                                   string table pred))
                        completion-styles))))

(defun minibuffer--bitset (modified completions exact)
  (logior (if modified    4 0)
          (if completions 2 0)

 100  4 ??? impossible
 101  5 ??? impossible
 110  6 some completion happened
 111  7 completed to an exact completion"
  (let* ((beg (field-beginning))
         (end (point))
         (string (buffer-substring beg end))
         (completion (funcall (or try-completion-function
                                  'completion-try-completion)
                              string
                              minibuffer-completion-table
                              minibuffer-completion-predicate)))
    (cond
     ((null completion)
      (ding) (minibuffer-message "No match") (minibuffer--bitset nil nil nil))
     ((eq t completion) (minibuffer--bitset nil nil t)) ;Exact and unique match.
     (t
      ;; `completed' should be t if some completion was done, which doesn't
      ;; include simply changing the case of the entered string.  However,
      ;; for appearance, the string is rewritten if the case changes.
      (let ((completed (not (eq t (compare-strings completion nil nil
                                                   string nil nil t))))
	     (unchanged (eq t (compare-strings completion nil nil
					       string nil nil nil))))
        (unless unchanged

          ;; Insert in minibuffer the chars we got.
          (goto-char end)
          (insert completion)
          (delete-region beg end))

        (if (not (or unchanged completed))
	   ;; The case of the string changed, but that's all.  We're not sure
	   ;; whether this is a unique completion or not, so try again using
	   ;; the real case (this shouldn't recurse again, because the next
	   ;; time try-completion will return either t or the exact string).
           (completion--do-completion try-completion-function)

          ;; It did find a match.  Do we match some possibility exactly now?
          (let ((exact (test-completion (field-string)
					minibuffer-completion-table
					minibuffer-completion-predicate)))
            (unless completed
              ;; Show the completion table, if requested.
              (cond

               (exit-minibuffer)
             (minibuffer-message "Confirm")
             nil))
        (t nil))))))

(defun completion--try-word-completion (string table predicate)
  (let ((completion (completion-try-completion string table predicate)))
    (if (not (stringp completion))
        completion

      ;; If completion finds next char not unique,
      ;; consider adding a space or a hyphen.
      (when (= (length string) (length completion))
        (let ((exts '(" " "-"))
              tem)
          (while (and exts (not (stringp tem)))
            (setq tem (completion-try-completion
                       (concat string (pop exts))
                       table predicate)))
          (if (stringp tem) (setq completion tem))))

      ;; Completing a single word is actually more difficult than completing
      ;; as much as possible, because we first have to find the "current
      ;; position" in `completion' in order to find the end of the word
      ;; we're completing.  Normally, `string' is a prefix of `completion',
      ;; which makes it trivial to find the position, but with fancier
      ;; completion (plus env-var expansion, ...) `completion' might not
      ;; look anything like `string' at all.

      (when minibuffer-completing-file-name
	;; In order to minimize the problem mentioned above, let's try to
	;; reduce the different between `string' and `completion' by
	;; mirroring some of the work done in read-file-name-internal.
	(let ((substituted (condition-case nil
			       ;; Might fail when completing an env-var.
			       (substitute-in-file-name string)
			     (error string))))
	  (unless (eq string substituted)
	    (setq string substituted))))

      ;; Make buffer (before point) contain the longest match
      ;; of `string's tail and `completion's head.
      (let* ((startpos (max 0 (- (length string) (length completion))))
             (length (- (length string) startpos)))
        (while (and (> length 0)
                    (not (eq t (compare-strings string startpos nil
                                                completion 0 length
                                                completion-ignore-case))))
          (setq startpos (1+ startpos))
          (setq length (1- length)))

        (setq string (substring string startpos)))

      ;; Now `string' is a prefix of `completion'.

      ;; Otherwise cut after the first word.
      (if (string-match "\\W" completion (length string))
          ;; First find first word-break in the stuff found by completion.
          ;; i gets index in string of where to stop completing.
          (substring completion 0 (match-end 0))
        completion))))


(defun minibuffer-complete-word ()
  "Complete the minibuffer contents at most a single word.
After one word is completed as much as possible, a space or hyphen

  (message "Making completion list...")
  (let* ((string (field-string))
         (completions (completion-all-completions
                       string
                       minibuffer-completion-table
                       minibuffer-completion-predicate)))
    (message nil)
    (if (and completions
             (or (consp (cdr completions))
                 (not (equal (car completions) string))))
        (with-output-to-temp-buffer "*Completions*"

		     'internal-complete-buffer
		     (lambda (name)
		       (not (equal (if (consp name) (car name) name) except)))
		     nil)))

(provide 'minibuffer)

;; arch-tag: ef8a0a15-1080-4790-a754-04017c02f08f
;;; minibuffer.el ends here

94304:bc48ced5cf89

;; Names starting with "minibuffer--" are for functions and variables that
;; are meant to be for internal use only.

;;; Todo:

;; - Make read-file-name-predicate obsolete.
;; - New command minibuffer-force-complete that chooses one of all-completions.
;; - Add vc-file-name-completion-table to read-file-name-internal.
;; - A feature like completing-help.el.
;; - Make the `hide-spaces' arg of all-completions obsolete?

the second failed attempt to complete."
  :type '(choice (const nil) (const t) (const lazy))
  :group 'minibuffer)

(defvar completion-styles-alist
  '((basic completion-basic-try-completion completion-basic-all-completions)
    (emacs22 completion-emacs22-try-completion completion-emacs22-all-completions)
    (emacs21 completion-emacs21-try-completion completion-emacs21-all-completions)
    ;; (partial-completion
    ;;  completion-pcm--try-completion completion-pcm--all-completions)
    )
  "List of available completion styles.
Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS)

  :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x)))
                                   completion-styles-alist)))
  :group 'minibuffer
  :version "23.1")

(defun completion-try-completion (string table pred point)
  "Try to complete STRING using completion table TABLE.
Only the elements of table that satisfy predicate PRED are considered.
POINT is the position of point within STRING.
The return value can be either nil to indicate that there is no completion,
t to indicate that STRING is the only possible completion,
or a pair (STRING . NEWPOINT) of the completed result string together with
a new position for point."
  ;; The property `completion-styles' indicates that this functional
  ;; completion-table claims to take care of completion styles itself.
  ;; [I.e. It will most likely call us back at some point. ]
  (if (and (symbolp table) (get table 'completion-styles))
      ;; Extended semantics for functional completion-tables:
      ;; They accept a 4th argument `point' and when called with action=nil
      ;; and this 4th argument (a position inside `string'), they should
      ;; return instead of a string a pair (STRING . NEWPOINT).
      (funcall table string pred nil point)
    (completion--some (lambda (style)
                        (funcall (nth 1 (assq style completion-styles-alist))
                                 string table pred point))
                      completion-styles)))

(defun completion-all-completions (string table pred point)
  "List the possible completions of STRING in completion table TABLE.
Only the elements of table that satisfy predicate PRED are considered.
POINT is the position of point within STRING.
The return value is a list of completions and may contain the BASE-SIZE
in the last `cdr'."
  ;; The property `completion-styles' indicates that this functional
  ;; completion-table claims to take care of completion styles itself.
  ;; [I.e. It will most likely call us back at some point. ]
  (let ((completion-all-completions-with-base-size t))
    (if (and (symbolp table) (get table 'completion-styles))
        ;; Extended semantics for functional completion-tables:
        ;; They accept a 4th argument `point' and when called with action=t
        ;; and this 4th argument (a position inside `string'), they may
        ;; return BASE-SIZE in the last `cdr'.
        (funcall table string pred t point)
      (completion--some (lambda (style)
                          (funcall (nth 2 (assq style completion-styles-alist))
                                   string table pred point))
                        completion-styles))))

(defun minibuffer--bitset (modified completions exact)
  (logior (if modified    4 0)
          (if completions 2 0)

 100  4 ??? impossible
 101  5 ??? impossible
 110  6 some completion happened
 111  7 completed to an exact completion"
  (let* ((beg (field-beginning))
         (end (field-end))
         (string (buffer-substring beg end))
         (comp (funcall (or try-completion-function
			    'completion-try-completion)
			string
			minibuffer-completion-table
			minibuffer-completion-predicate
			(- (point) beg))))
    (cond
     ((null comp)
      (ding) (minibuffer-message "No match") (minibuffer--bitset nil nil nil))
     ((eq t comp) (minibuffer--bitset nil nil t)) ;Exact and unique match.
     (t
      ;; `completed' should be t if some completion was done, which doesn't
      ;; include simply changing the case of the entered string.  However,
      ;; for appearance, the string is rewritten if the case changes.
      (let* ((comp-pos (cdr comp))
	     (completion (car comp))
	     (completed (not (eq t (compare-strings completion nil nil
						    string nil nil t))))
	     (unchanged (eq t (compare-strings completion nil nil
					       string nil nil nil))))
        (unless unchanged

          ;; Insert in minibuffer the chars we got.
          (goto-char end)
          (insert completion)
          (delete-region beg end)
          (goto-char (+ beg comp-pos)))

        (if (not (or unchanged completed))
	   ;; The case of the string changed, but that's all.  We're not sure
	   ;; whether this is a unique completion or not, so try again using
	   ;; the real case (this shouldn't recurse again, because the next
	   ;; time try-completion will return either t or the exact string).
           (completion--do-completion try-completion-function)

          ;; It did find a match.  Do we match some possibility exactly now?
          (let ((exact (test-completion completion
					minibuffer-completion-table
					minibuffer-completion-predicate)))
            (unless completed
              ;; Show the completion table, if requested.
              (cond

               (exit-minibuffer)
             (minibuffer-message "Confirm")
             nil))
        (t nil))))))

(defun completion--try-word-completion (string table predicate point)
  (let ((comp (completion-try-completion string table predicate point)))
    (if (not (consp comp))
        comp

      ;; If completion finds next char not unique,
      ;; consider adding a space or a hyphen.
      (when (= (length string) (length (car comp)))
        (let ((exts '(" " "-"))
              (before (substring string 0 point))
              (after (substring string point))
	      tem)
	  (while (and exts (not (consp tem)))
            (setq tem (completion-try-completion
		       (concat before (pop exts) after)
		       table predicate (1+ point))))
	  (if (consp tem) (setq comp tem))))

      ;; Completing a single word is actually more difficult than completing
      ;; as much as possible, because we first have to find the "current
      ;; position" in `completion' in order to find the end of the word
      ;; we're completing.  Normally, `string' is a prefix of `completion',
      ;; which makes it trivial to find the position, but with fancier
      ;; completion (plus env-var expansion, ...) `completion' might not
      ;; look anything like `string' at all.
      (let* ((comppoint (cdr comp))
	     (completion (car comp))
	     (before (substring string 0 point))
	     (combined (concat before "\n" completion)))
        ;; Find in completion the longest text that was right before point.
        (when (string-match "\\(.+\\)\n.*?\\1" combined)
          (let* ((prefix (match-string 1 before))
                 ;; We used non-greedy match to make `rem' as long as possible.
                 (rem (substring combined (match-end 0)))
                 ;; Find in the remainder of completion the longest text
                 ;; that was right after point.
                 (after (substring string point))
                 (suffix (if (string-match "\\`\\(.+\\).*\n.*\\1"
                                           (concat after "\n" rem))
                             (match-string 1 after))))
            ;; The general idea is to try and guess what text was inserted
            ;; at point by the completion.  Problem is: if we guess wrong,
            ;; we may end up treating as "added by completion" text that was
            ;; actually painfully typed by the user.  So if we then cut
            ;; after the first word, we may throw away things the
            ;; user wrote.  So let's try to be as conservative as possible:
            ;; only cut after the first word, if we're reasonably sure that
            ;; our guess is correct.
            ;; Note: a quick survey on emacs-devel seemed to indicate that
            ;; nobody actually cares about the "word-at-a-time" feature of
            ;; minibuffer-complete-word, whose real raison-d'être is that it
            ;; tries to add "-" or " ".  One more reason to only cut after
            ;; the first word, if we're really sure we're right.
            (when (and (or suffix (zerop (length after)))
                       (string-match (concat
                                      ;; Make submatch 1 as small as possible
                                      ;; to reduce the risk of cutting
                                      ;; valuable text.
                                      ".*" (regexp-quote prefix) "\\(.*?\\)"
                                      (if suffix (regexp-quote suffix) "\\'"))
                                     completion)
                       ;; The new point in `completion' should also be just
                       ;; before the suffix, otherwise something more complex
                       ;; is going on, and we're not sure where we are.
                       (eq (match-end 1) comppoint)
                       ;; (match-beginning 1)..comppoint is now the stretch
                       ;; of text in `completion' that was completed at point.
		       (string-match "\\W" completion (match-beginning 1))
		       ;; Is there really something to cut?
		       (> comppoint (match-end 0)))
              ;; Cut after the first word.
              (let ((cutpos (match-end 0)))
                (setq completion (concat (substring completion 0 cutpos)
                                         (substring completion comppoint)))
                (setq comppoint cutpos)))))

	(cons completion comppoint)))))


(defun minibuffer-complete-word ()
  "Complete the minibuffer contents at most a single word.
After one word is completed as much as possible, a space or hyphen

  (message "Making completion list...")
  (let* ((string (field-string))
         (completions (completion-all-completions
                       string
                       minibuffer-completion-table
                       minibuffer-completion-predicate
                       (- (point) (field-beginning)))))
    (message nil)
    (if (and completions
             (or (consp (cdr completions))
                 (not (equal (car completions) string))))
        (with-output-to-temp-buffer "*Completions*"

		     'internal-complete-buffer
		     (lambda (name)
		       (not (equal (if (consp name) (car name) name) except)))
		     nil)))

;;; Old-style completion, used in Emacs-21.

(defun completion-emacs21-try-completion (string table pred point)
  (let ((completion (try-completion string table pred)))
    (if (stringp completion)
        (cons completion (length completion))
      completion)))

(defun completion-emacs21-all-completions (string table pred point)
  (all-completions string table pred t))

;;; Basic completion, used in Emacs-22.

(defun completion-emacs22-try-completion (string table pred point)
  (let ((suffix (substring string point))
        (completion (try-completion (substring string 0 point) table pred)))
    (if (not (stringp completion))
        completion
      ;; Merge a trailing / in completion with a / after point.
      ;; We used to only do it for word completion, but it seems to make
      ;; sense for all completions.
      (if (and (eq ?/ (aref completion (1- (length completion))))
               (not (zerop (length suffix)))
               (eq ?/ (aref suffix 0)))
          ;; This leaves point before the / .
          ;; Should we maybe put it after the / ?  --Stef
          (setq completion (substring completion 0 -1)))
      (cons (concat completion suffix) (length completion)))))

(defun completion-emacs22-all-completions (string table pred point)
  (all-completions (substring string 0 point) table pred t))

(defalias 'completion-basic-try-completion 'completion-emacs22-try-completion)
(defalias 'completion-basic-all-completions 'completion-emacs22-all-completions)

(provide 'minibuffer)

;; arch-tag: ef8a0a15-1080-4790-a754-04017c02f08f
;;; minibuffer.el ends here