comparison lisp/minibuffer.el @ 94062:9fefa536be58

* minibuffer.el (completion-all-completion-with-base-size): New var. (completion--some): New function. (completion-table-with-context, completion--file-name-table): Return the base-size if requested. (completion-table-in-turn): Generalize to multiple arguments. (complete-in-turn): Compatibility alias. (completion-styles-alist): New var. (completion-styles): New customization. (minibuffer-try-completion, minibuffer-all-completions): New functions. (minibuffer--do-completion, minibuffer-complete-and-exit) (minibuffer-try-word-completion): Use them. (display-completion-list, minibuffer-completion-help): Use them. Handle all-completions's new base-size info to set completion-base-size. * info.el (Info-read-node-name-1): Use completion-table-with-context, completion-table-with-terminator and complete-with-action. Remove the now obsolete completion-base-size-function property. * simple.el (completion-list-mode-map): Move init into declaration. (completion-list-mode): Use define-derived-mode. (completion-setup-function): Use any completion-base-size that may have been set before. Remove handling of completion-base-size-function. * loadup.el: Move abbrev.el up earlier.

94061:d4e9da5a29d5

;;; Commentary:

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

;; BUGS:
;; - envvar completion for file names breaks completion-base-size.

;;; Code:

(eval-when-compile (require 'cl))

;;; Completion table manipulation

(defun apply-partially (fun &rest args)
  (lexical-let ((fun fun) (args1 args))
    (lambda (&rest args2) (apply fun (append args1 args2)))))

(defun complete-with-action (action table string pred)
  "Perform completion ACTION.

          (setq ,var (,fun)))
        ,var))))

(defun completion-table-with-context (prefix table string pred action)
  ;; TODO: add `suffix', and think about how we should support `pred'.
  ;; Notice that `pred' is not a predicate when called from read-file-name.
  ;; (if pred (setq pred (lexical-let ((pred pred))
  ;;                       ;; FIXME: this doesn't work if `table' is an obarray.
  ;;                       (lambda (s) (funcall pred (concat prefix s))))))
  (let ((comp (complete-with-action action table string nil))) ;; pred
    (if (stringp comp)
        (concat prefix comp)
      comp)))

(defun completion-table-with-terminator (terminator table string pred action)
  (let ((comp (complete-with-action action table string pred)))
    (if (eq action nil)
        (if (eq comp t)

                   (eq (complete-with-action action table comp pred) t))
              (concat comp terminator)
            comp))
      comp)))

(defun completion-table-in-turn (a b)
  "Create a completion table that first tries completion in A and then in B.
A and B should not be costly (or side-effecting) expressions."
  (lexical-let ((a a) (b b))
    (lambda (string pred action)
      (or (complete-with-action action a string pred)
          (complete-with-action action b string pred)))))

;;; Minibuffer completion

(defgroup minibuffer nil
  "Controlling the behavior of the minibuffer."

If the value is `lazy', the *Completions* buffer is only displayed after
the second failed attempt to complete."
  :type '(choice (const nil) (const t) (const lazy))
  :group 'minibuffer)

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

 101  5 ??? impossible
 110  6 some completion happened
 111  7 completed to an exact completion"
  (let* ((beg (field-beginning))
         (string (buffer-substring beg (point)))
         (completion (funcall (or try-completion-function 'try-completion)
                              string
                              minibuffer-completion-table
                              minibuffer-completion-predicate)))
    (cond
     ((null completion)

                     minibuffer-completion-table
                     minibuffer-completion-predicate)
    (when completion-ignore-case
      ;; Fixup case of the field, if necessary.
      (let* ((string (field-string))
	     (compl (try-completion string
				    minibuffer-completion-table
				    minibuffer-completion-predicate)))
	(when (and (stringp compl)
                   ;; If it weren't for this piece of paranoia, I'd replace
                   ;; the whole thing with a call to complete-do-completion.
                   (= (length string) (length compl)))
          (let ((beg (field-beginning))

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

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

      ;; Completing a single word is actually more difficult than completing
      ;; as much as possible, because we first have to find the "current

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

      ;; Otherwise cut after the first word.
      (if (string-match "\\W" completion (length string))
          ;; First find first word-break in the stuff found by completion.

      (goto-char (point-max))
      (if (null completions)
	  (insert "There are no possible completions of what you have typed.")

	(insert "Possible completions are:\n")
	(minibuffer--insert-strings completions))))
  (let ((completion-common-substring common-substring))
    (run-hooks 'completion-setup-hook))
  nil)

(defun minibuffer-completion-help ()
  "Display a list of possible completions of the current minibuffer contents."
  (interactive)
  (message "Making completion list...")
  (let* ((string (field-string))
         (completions (all-completions
                       string
                       minibuffer-completion-table
                       minibuffer-completion-predicate
                       t)))
    (message nil)
    (if (and completions
             (or (cdr completions) (not (equal (car completions) string))))
        (with-output-to-temp-buffer "*Completions*"
          (display-completion-list (sort completions 'string-lessp)))

      ;; If there are no completions, or if the current input is already the
      ;; only possible completion, then hide (previous&stale) completions.
      (let ((window (and (get-buffer "*Completions*")
                         (get-buffer-window "*Completions*" 0))))

              ;; If there's no real completion, but substitute-in-file-name
              ;; changed the string, then return the new string.
              str))))

       ((eq action t)
        (let ((all (file-name-all-completions name realdir)))
          (if (memq read-file-name-predicate '(nil file-exists-p))
              all
            (let ((comp ())
                  (pred
                   (if (eq read-file-name-predicate 'file-directory-p)
                       ;; Brute-force speed up for directory checking:
                       ;; Discard strings which don't end in a slash.

                     ;; Must do it the hard (and slow) way.
                     read-file-name-predicate)))
              (let ((default-directory realdir))
                (dolist (tem all)
                  (if (funcall pred tem) (push tem comp))))
              (nreverse comp)))))

       (t
        ;; Only other case actually used is ACTION = lambda.
        (let ((default-directory dir))
          (funcall (or read-file-name-predicate 'file-exists-p) str)))))))

94062:9fefa536be58

;;; Commentary:

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

;; TODO:
;; - make the `hide-spaces' arg of all-completions obsolete.

;; BUGS:
;; - envvar completion for file names breaks completion-base-size.

;;; Code:

(eval-when-compile (require 'cl))

(defvar completion-all-completions-with-base-size nil
  "If non-nil, `all-completions' may return the base-size in the last cdr.
The base-size is the length of the prefix that is elided from each
element in the returned list of completions.  See `completion-base-size'.")

;;; Completion table manipulation

(defun completion--some (fun xs)
  "Apply FUN to each element of XS in turn.
Return the first non-nil returned value.
Like CL's `some'."
  (let (res)
    (while (and (not res) xs)
      (setq res (funcall fun (pop xs))))
    res))

(defun apply-partially (fun &rest args)
  "Do a \"curried\" partial application of FUN to ARGS.
ARGS is a list of the first N arguments to pass to FUN.
The result is a new function that takes the remaining arguments,
and calls FUN."
  (lexical-let ((fun fun) (args1 args))
    (lambda (&rest args2) (apply fun (append args1 args2)))))

(defun complete-with-action (action table string pred)
  "Perform completion ACTION.

          (setq ,var (,fun)))
        ,var))))

(defun completion-table-with-context (prefix table string pred action)
  ;; TODO: add `suffix', and think about how we should support `pred'.
  ;; Notice that `pred' is not a predicate when called from read-file-name
  ;; or Info-read-node-name-2.
  ;; (if pred (setq pred (lexical-let ((pred pred))
  ;;                       ;; FIXME: this doesn't work if `table' is an obarray.
  ;;                       (lambda (s) (funcall pred (concat prefix s))))))
  (let ((comp (complete-with-action action table string pred)))
    (cond
     ;; In case of try-completion, add the prefix.
     ((stringp comp) (concat prefix comp))
     ;; In case of non-empty all-completions,
     ;; add the prefix size to the base-size.
     ((consp comp)
      (let ((last (last comp)))
        (when completion-all-completions-with-base-size
          (setcdr last (+ (or (cdr last) 0) (length prefix))))
        comp))
     (t comp))))

(defun completion-table-with-terminator (terminator table string pred action)
  (let ((comp (complete-with-action action table string pred)))
    (if (eq action nil)
        (if (eq comp t)

                   (eq (complete-with-action action table comp pred) t))
              (concat comp terminator)
            comp))
      comp)))

(defun completion-table-in-turn (&rest tables)
  "Create a completion table that tries each table in TABLES in turn."
  (lexical-let ((tables tables))
    (lambda (string pred action)
      (completion--some (lambda (table)
                          (complete-with-action action table string pred))
                        tables))))

(defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
(define-obsolete-function-alias
  'complete-in-turn 'completion-table-in-turn "23.1")

;;; Minibuffer completion

(defgroup minibuffer nil
  "Controlling the behavior of the minibuffer."

If the value is `lazy', the *Completions* buffer is only displayed after
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)
where NAME is the name that should be used in `completion-styles'
TRY-COMPLETION is the function that does the completion, and
ALL-COMPLETIONS is the function that lists the completions.")

(defcustom completion-styles '(basic)
  "List of completion styles to use."
  :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x)))
                                   completion-styles-alist)))
  :group 'minibuffer
  :version "23.1")

(defun minibuffer-try-completion (string table pred)
  (if (and (symbolp table) (get table 'no-completion-styles))
      (try-completion string table pred)
    (completion--some (lambda (style)
                        (funcall (intern (concat style "try-completion"))
                                 string table pred))
                      completion-styles)))

(defun minibuffer-all-completions (string table pred &optional hide-spaces)
  (let ((completion-all-completions-with-base-size t))
    (if (and (symbolp table) (get table 'no-completion-styles))
        (all-completions string table pred hide-spaces)
      (completion--some (lambda (style)
                          (funcall (intern (concat style "all-completions"))
                                   string table pred hide-spaces))
                        completion-styles))))

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

 101  5 ??? impossible
 110  6 some completion happened
 111  7 completed to an exact completion"
  (let* ((beg (field-beginning))
         (string (buffer-substring beg (point)))
         (completion (funcall (or try-completion-function
                                  'minibuffer-try-completion)
                              string
                              minibuffer-completion-table
                              minibuffer-completion-predicate)))
    (cond
     ((null completion)

                     minibuffer-completion-table
                     minibuffer-completion-predicate)
    (when completion-ignore-case
      ;; Fixup case of the field, if necessary.
      (let* ((string (field-string))
	     (compl (minibuffer-try-completion
                     string
                     minibuffer-completion-table
                     minibuffer-completion-predicate)))
	(when (and (stringp compl)
                   ;; If it weren't for this piece of paranoia, I'd replace
                   ;; the whole thing with a call to complete-do-completion.
                   (= (length string) (length compl)))
          (let ((beg (field-beginning))

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

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

      ;; Completing a single word is actually more difficult than completing
      ;; as much as possible, because we first have to find the "current

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

      ;; Otherwise cut after the first word.
      (if (string-match "\\W" completion (length string))
          ;; First find first word-break in the stuff found by completion.

      (goto-char (point-max))
      (if (null completions)
	  (insert "There are no possible completions of what you have typed.")

	(insert "Possible completions are:\n")
        (let ((last (last completions)))
          ;; Get the base-size from the tail of the list.
          (set (make-local-variable 'completion-base-size) (or (cdr last) 0))
          (setcdr last nil)) ;Make completions a properly nil-terminated list.
	(minibuffer--insert-strings completions))))

  (let ((completion-common-substring common-substring))
    (run-hooks 'completion-setup-hook))
  nil)

(defun minibuffer-completion-help ()
  "Display a list of possible completions of the current minibuffer contents."
  (interactive)
  (message "Making completion list...")
  (let* ((string (field-string))
         (completions (minibuffer-all-completions
                       string
                       minibuffer-completion-table
                       minibuffer-completion-predicate
                       t)))
    (message nil)
    (if (and completions
             (or (consp (cdr completions))
                 (not (equal (car completions) string))))
        (with-output-to-temp-buffer "*Completions*"
          (let* ((last (last completions))
                 (base-size (cdr last)))
            ;; Remove the base-size tail because `sort' requires a properly
            ;; nil-terminated list.
            (when last (setcdr last nil))
            (display-completion-list (nconc (sort completions 'string-lessp)
                                            base-size))))

      ;; If there are no completions, or if the current input is already the
      ;; only possible completion, then hide (previous&stale) completions.
      (let ((window (and (get-buffer "*Completions*")
                         (get-buffer-window "*Completions*" 0))))

              ;; If there's no real completion, but substitute-in-file-name
              ;; changed the string, then return the new string.
              str))))

       ((eq action t)
        (let ((all (file-name-all-completions name realdir))
              ;; Actually, this is not always right in the presence of
              ;; envvars, but there's not much we can do, I think.
              (base-size (length (file-name-directory string))))

          ;; Check the predicate, if necessary.
          (unless (memq read-file-name-predicate '(nil file-exists-p))
            (let ((comp ())
                  (pred
                   (if (eq read-file-name-predicate 'file-directory-p)
                       ;; Brute-force speed up for directory checking:
                       ;; Discard strings which don't end in a slash.

                     ;; Must do it the hard (and slow) way.
                     read-file-name-predicate)))
              (let ((default-directory realdir))
                (dolist (tem all)
                  (if (funcall pred tem) (push tem comp))))
              (setq all (nreverse comp))))

          ;; Add base-size, but only if the list is non-empty.
          (if (consp all) (nconc all base-size))))

       (t
        ;; Only other case actually used is ACTION = lambda.
        (let ((default-directory dir))
          (funcall (or read-file-name-predicate 'file-exists-p) str)))))))