;; are meant to be for internal use only.
;; TODO:
-;; - merge do-completion and complete-word
-;; - move all I/O out of do-completion
+;; - New command minibuffer-force-complete that chooses one of all-completions.
+;; - make the `hide-spaces' arg of all-completions obsolete?
;;; 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.
+STRING is the string to complete.
+TABLE is the completion table, which should not be a function.
+PRED is a completion predicate.
+ACTION can be one of nil, t or `lambda'."
+ ;; (assert (not (functionp table)))
+ (funcall
+ (cond
+ ((null action) 'try-completion)
+ ((eq action t) 'all-completions)
+ (t 'test-completion))
+ string table pred))
+
+(defun completion-table-dynamic (fun)
+ "Use function FUN as a dynamic completion table.
+FUN is called with one argument, the string for which completion is required,
+and it should return an alist containing all the intended possible completions.
+This alist may be a full list of possible completions so that FUN can ignore
+the value of its argument. If completion is performed in the minibuffer,
+FUN will be called in the buffer from which the minibuffer was entered.
+
+The result of the `dynamic-completion-table' form is a function
+that can be used as the ALIST argument to `try-completion' and
+`all-completions'. See Info node `(elisp)Programmed Completion'."
+ (lexical-let ((fun fun))
+ (lambda (string pred action)
+ (with-current-buffer (let ((win (minibuffer-selected-window)))
+ (if (window-live-p win) (window-buffer win)
+ (current-buffer)))
+ (complete-with-action action (funcall fun string) string pred)))))
+
+(defmacro lazy-completion-table (var fun)
+ "Initialize variable VAR as a lazy completion table.
+If the completion table VAR is used for the first time (e.g., by passing VAR
+as an argument to `try-completion'), the function FUN is called with no
+arguments. FUN must return the completion table that will be stored in VAR.
+If completion is requested in the minibuffer, FUN will be called in the buffer
+from which the minibuffer was entered. The return value of
+`lazy-completion-table' must be used to initialize the value of VAR.
+
+You should give VAR a non-nil `risky-local-variable' property."
+ (declare (debug (symbolp lambda-expr)))
+ (let ((str (make-symbol "string")))
+ `(completion-table-dynamic
+ (lambda (,str)
+ (when (functionp ,var)
+ (setq ,var (,fun)))
+ ,var))))
+
+(defun completion-table-with-context (prefix table string pred action)
+ ;; TODO: add `suffix' maybe?
+ ;; Notice that `pred' is not a predicate when called from read-file-name
+ ;; or Info-read-node-name-2.
+ (if (functionp 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)
+ (cond
+ ((eq action nil)
+ (let ((comp (try-completion string table pred)))
+ (if (eq comp t)
+ (concat string terminator)
+ (if (and (stringp comp)
+ (eq (try-completion comp table pred) t))
+ (concat comp terminator)
+ comp))))
+ ((eq action t) (all-completions string table pred))
+ ;; completion-table-with-terminator is always used for
+ ;; "sub-completions" so it's only called if the terminator is missing,
+ ;; in which case `test-completion' should return nil.
+ ((eq action 'lambda) nil)))
+
+(defun completion-table-with-predicate (table pred1 strict string pred2 action)
+ "Make a completion table equivalent to TABLE but filtered through PRED1.
+PRED1 is a function of one argument which returns non-nil iff the
+argument is an element of TABLE which should be considered for completion.
+STRING, PRED2, and ACTION are the usual arguments to completion tables,
+as described in `try-completion', `all-completions', and `test-completion'.
+If STRICT is t, the predicate always applies, if nil it only applies if
+it doesn't reduce the set of possible completions to nothing.
+Note: TABLE needs to be a proper completion table which obeys predicates."
+ (cond
+ ((and (not strict) (eq action 'lambda))
+ ;; Ignore pred1 since it doesn't really have to apply anyway.
+ (test-completion string table pred2))
+ (t
+ (or (complete-with-action action table string
+ (if (null pred2) pred1
+ (lexical-let ((pred1 pred2) (pred2 pred2))
+ (lambda (x)
+ ;; Call `pred1' first, so that `pred2'
+ ;; really can't tell that `x' is in table.
+ (if (funcall pred1 x) (funcall pred2 x))))))
+ ;; If completion failed and we're not applying pred1 strictly, try
+ ;; again without pred1.
+ (and (not strict)
+ (complete-with-action action table string pred2))))))
+
+(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))
+;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
+(define-obsolete-function-alias
+ 'complete-in-turn 'completion-table-in-turn "23.1")
+(define-obsolete-function-alias
+ 'dynamic-completion-table 'completion-table-dynamic "23.1")
+
+;;; Minibuffer completion
+
(defgroup minibuffer nil
"Controlling the behavior of the minibuffer."
:link '(custom-manual "(emacs)Minibuffer")
If ARGS are provided, then pass MESSAGE through `format'."
;; Clear out any old echo-area message to make way for our new thing.
(message nil)
- (unless (and (null args) (string-match "\\[.+\\]" message))
- (setq message (concat " [" message "]")))
+ (setq message (if (and (null args) (string-match "\\[.+\\]" message))
+ ;; Make sure we can put-text-property.
+ (copy-sequence message)
+ (concat " [" message "]")))
(when args (setq message (apply 'format message args)))
(let ((ol (make-overlay (point-max) (point-max) nil t t)))
(unwind-protect
(progn
+ (unless (zerop (length message))
+ ;; The current C cursor code doesn't know to use the overlay's
+ ;; marker's stickiness to figure out whether to place the cursor
+ ;; before or after the string, so let's spoon-feed it the pos.
+ (put-text-property 0 1 'cursor t message))
(overlay-put ol 'after-string message)
(sit-for (or minibuffer-message-timeout 1000000)))
(delete-overlay ol))))
: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 (nth 1 (assq style completion-styles-alist))
+ 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 (nth 2 (assq style completion-styles-alist))
+ string table pred hide-spaces))
+ completion-styles))))
+
(defun minibuffer--bitset (modified completions exact)
(logior (if modified 4 0)
(if completions 2 0)
111 7 completed to an exact completion"
(let* ((beg (field-beginning))
(string (buffer-substring beg (point)))
- (completion (funcall (or try-completion-function 'try-completion)
+ (completion (funcall (or try-completion-function
+ 'minibuffer-try-completion)
string
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)))
+ (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.
(t nil)))))
(defun minibuffer-try-word-completion (string table predicate)
- (let ((completion (try-completion string table predicate)))
+ (let ((completion (minibuffer-try-completion string table predicate)))
(if (not (stringp completion))
completion
(let ((exts '(" " "-"))
tem)
(while (and exts (not (stringp tem)))
- (setq tem (try-completion (concat string (pop exts))
- table predicate)))
+ (setq tem (minibuffer-try-completion (concat string (pop exts))
+ table predicate)))
(if (stringp tem) (setq completion tem))))
;; Otherwise cut after the first word.
(defvar completion-common-substring)
+(defvar completion-setup-hook nil
+ "Normal hook run at the end of setting up a completion list buffer.
+When this hook is run, the current buffer is the one in which the
+command to display the completion list buffer was run.
+The completion list buffer is available as the value of `standard-output'.
+The common prefix substring for completion may be available as the value
+of `completion-common-substring'. See also `display-completion-list'.")
+
(defun display-completion-list (completions &optional common-substring)
"Display the list of completions, COMPLETIONS, using `standard-output'.
Each element may be just a symbol or string
It can find the completion buffer in `standard-output'.
The optional second arg COMMON-SUBSTRING is a string.
It is used to put faces, `completions-first-difference' and
-`completions-common-part' on the completion buffer. The
+`completions-common-part' on the completion buffer. The
`completions-common-part' face is put on the common substring
specified by COMMON-SUBSTRING. If COMMON-SUBSTRING is nil
and the current buffer is not the minibuffer, the faces are not put.
(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)
(interactive)
(message "Making completion list...")
(let* ((string (field-string))
- (completions (all-completions
+ (completions (minibuffer-all-completions
string
minibuffer-completion-table
minibuffer-completion-predicate
t)))
(message nil)
(if (and completions
- (or (cdr completions) (not (equal (car completions) string))))
+ (or (consp (cdr completions))
+ (not (equal (car completions) string))))
(with-output-to-temp-buffer "*Completions*"
- (display-completion-list (sort completions 'string-lessp)))
+ (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.
(ding))
(exit-minibuffer))
+(defun minibuffer--double-dollars (str)
+ (replace-regexp-in-string "\\$" "$$" str))
+
+(defun completion--make-envvar-table ()
+ (mapcar (lambda (enventry)
+ (substring enventry 0 (string-match "=" enventry)))
+ process-environment))
+
+(defun completion--embedded-envvar-table (string pred action)
+ (when (string-match (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
+ "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")
+ string)
+ (let* ((beg (or (match-beginning 2) (match-beginning 1)))
+ (table (completion--make-envvar-table))
+ (prefix (substring string 0 beg)))
+ (if (eq (aref string (1- beg)) ?{)
+ (setq table (apply-partially 'completion-table-with-terminator
+ "}" table)))
+ (completion-table-with-context prefix table
+ (substring string beg)
+ pred action))))
+
+(defun completion--file-name-table (string dir action)
+ "Internal subroutine for `read-file-name'. Do not call this."
+ (setq dir (expand-file-name dir))
+ (if (and (zerop (length string)) (eq 'lambda action))
+ nil ; FIXME: why?
+ (let* ((str (condition-case nil
+ (substitute-in-file-name string)
+ (error string)))
+ (name (file-name-nondirectory str))
+ (specdir (file-name-directory str))
+ (realdir (if specdir (expand-file-name specdir dir)
+ (file-name-as-directory dir))))
+
+ (cond
+ ((null action)
+ (let ((comp (file-name-completion name realdir
+ read-file-name-predicate)))
+ (if (stringp comp)
+ ;; Requote the $s before returning the completion.
+ (minibuffer--double-dollars (concat specdir comp))
+ ;; Requote the $s before checking for changes.
+ (setq str (minibuffer--double-dollars str))
+ (if (string-equal string str)
+ comp
+ ;; 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.
+ (lambda (s)
+ (let ((len (length s)))
+ (and (> len 0) (eq (aref s (1- len)) ?/))))
+ ;; 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))))
+
+ (if (and completion-all-completions-with-base-size (consp all))
+ ;; Add base-size, but only if the list is non-empty.
+ (nconc all base-size))
+
+ all))
+
+ (t
+ ;; Only other case actually used is ACTION = lambda.
+ (let ((default-directory dir))
+ (funcall (or read-file-name-predicate 'file-exists-p) str)))))))
+
+(defalias 'read-file-name-internal
+ (completion-table-in-turn 'completion--embedded-envvar-table
+ 'completion--file-name-table)
+ "Internal subroutine for `read-file-name'. Do not call this.")
+
(provide 'minibuffer)
+
+;; arch-tag: ef8a0a15-1080-4790-a754-04017c02f08f
;;; minibuffer.el ends here
HCoop / bpt / emacs.git / blobdiff