X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/d2925a49b44e0c95c2078dc365379480f0ff448b..b95c760067774de3d532037adc1036461068597b:/lisp/minibuffer.el diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index dbf78e0567..dea94b675d 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -25,13 +25,167 @@ ;; 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") @@ -45,12 +199,19 @@ Enclose MESSAGE in [...] if this is not yet the case. 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)))) @@ -74,6 +235,41 @@ 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 (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) @@ -96,7 +292,8 @@ E = after completion we now have an Exact match. 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))) @@ -202,9 +399,10 @@ a repetition of this command will exit." (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. @@ -237,7 +435,7 @@ a repetition of this command will exit." (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 @@ -281,8 +479,8 @@ a repetition of this command will exit." (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. @@ -363,6 +561,14 @@ It also eliminates runs of equal strings." (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 @@ -376,7 +582,7 @@ At the end, this runs the normal hook `completion-setup-hook'. 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. @@ -396,7 +602,12 @@ during running `completion-setup-hook'." (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) @@ -406,16 +617,23 @@ during running `completion-setup-hook'." (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. @@ -450,5 +668,96 @@ during running `completion-setup-hook'." (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