| 1 | ;;; minibuffer.el --- Minibuffer completion functions |
| 2 | |
| 3 | ;; Copyright (C) 2008 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> |
| 6 | |
| 7 | ;; This file is part of GNU Emacs. |
| 8 | |
| 9 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 10 | ;; it under the terms of the GNU General Public License as published by |
| 11 | ;; the Free Software Foundation, either version 3 of the License, or |
| 12 | ;; (at your option) any later version. |
| 13 | |
| 14 | ;; This program is distributed in the hope that it will be useful, |
| 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 17 | ;; GNU General Public License for more details. |
| 18 | |
| 19 | ;; You should have received a copy of the GNU General Public License |
| 20 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. |
| 21 | |
| 22 | ;;; Commentary: |
| 23 | |
| 24 | ;; Names starting with "minibuffer--" are for functions and variables that |
| 25 | ;; are meant to be for internal use only. |
| 26 | |
| 27 | ;;; Todo: |
| 28 | |
| 29 | ;; - New command minibuffer-force-complete that chooses one of all-completions. |
| 30 | ;; - Add vc-file-name-completion-table to read-file-name-internal. |
| 31 | ;; - A feature like completing-help.el. |
| 32 | ;; - Make the `hide-spaces' arg of all-completions obsolete? |
| 33 | |
| 34 | ;;; Code: |
| 35 | |
| 36 | (eval-when-compile (require 'cl)) |
| 37 | |
| 38 | (defvar completion-all-completions-with-base-size nil |
| 39 | "If non-nil, `all-completions' may return the base-size in the last cdr. |
| 40 | The base-size is the length of the prefix that is elided from each |
| 41 | element in the returned list of completions. See `completion-base-size'.") |
| 42 | |
| 43 | ;;; Completion table manipulation |
| 44 | |
| 45 | (defun completion--some (fun xs) |
| 46 | "Apply FUN to each element of XS in turn. |
| 47 | Return the first non-nil returned value. |
| 48 | Like CL's `some'." |
| 49 | (let (res) |
| 50 | (while (and (not res) xs) |
| 51 | (setq res (funcall fun (pop xs)))) |
| 52 | res)) |
| 53 | |
| 54 | (defun apply-partially (fun &rest args) |
| 55 | "Do a \"curried\" partial application of FUN to ARGS. |
| 56 | ARGS is a list of the first N arguments to pass to FUN. |
| 57 | The result is a new function that takes the remaining arguments, |
| 58 | and calls FUN." |
| 59 | (lexical-let ((fun fun) (args1 args)) |
| 60 | (lambda (&rest args2) (apply fun (append args1 args2))))) |
| 61 | |
| 62 | (defun complete-with-action (action table string pred) |
| 63 | "Perform completion ACTION. |
| 64 | STRING is the string to complete. |
| 65 | TABLE is the completion table, which should not be a function. |
| 66 | PRED is a completion predicate. |
| 67 | ACTION can be one of nil, t or `lambda'." |
| 68 | ;; (assert (not (functionp table))) |
| 69 | (funcall |
| 70 | (cond |
| 71 | ((null action) 'try-completion) |
| 72 | ((eq action t) 'all-completions) |
| 73 | (t 'test-completion)) |
| 74 | string table pred)) |
| 75 | |
| 76 | (defun completion-table-dynamic (fun) |
| 77 | "Use function FUN as a dynamic completion table. |
| 78 | FUN is called with one argument, the string for which completion is required, |
| 79 | and it should return an alist containing all the intended possible completions. |
| 80 | This alist may be a full list of possible completions so that FUN can ignore |
| 81 | the value of its argument. If completion is performed in the minibuffer, |
| 82 | FUN will be called in the buffer from which the minibuffer was entered. |
| 83 | |
| 84 | The result of the `dynamic-completion-table' form is a function |
| 85 | that can be used as the ALIST argument to `try-completion' and |
| 86 | `all-completions'. See Info node `(elisp)Programmed Completion'." |
| 87 | (lexical-let ((fun fun)) |
| 88 | (lambda (string pred action) |
| 89 | (with-current-buffer (let ((win (minibuffer-selected-window))) |
| 90 | (if (window-live-p win) (window-buffer win) |
| 91 | (current-buffer))) |
| 92 | (complete-with-action action (funcall fun string) string pred))))) |
| 93 | |
| 94 | (defmacro lazy-completion-table (var fun) |
| 95 | "Initialize variable VAR as a lazy completion table. |
| 96 | If the completion table VAR is used for the first time (e.g., by passing VAR |
| 97 | as an argument to `try-completion'), the function FUN is called with no |
| 98 | arguments. FUN must return the completion table that will be stored in VAR. |
| 99 | If completion is requested in the minibuffer, FUN will be called in the buffer |
| 100 | from which the minibuffer was entered. The return value of |
| 101 | `lazy-completion-table' must be used to initialize the value of VAR. |
| 102 | |
| 103 | You should give VAR a non-nil `risky-local-variable' property." |
| 104 | (declare (debug (symbolp lambda-expr))) |
| 105 | (let ((str (make-symbol "string"))) |
| 106 | `(completion-table-dynamic |
| 107 | (lambda (,str) |
| 108 | (when (functionp ,var) |
| 109 | (setq ,var (,fun))) |
| 110 | ,var)))) |
| 111 | |
| 112 | (defun completion-table-with-context (prefix table string pred action) |
| 113 | ;; TODO: add `suffix' maybe? |
| 114 | ;; Notice that `pred' is not a predicate when called from read-file-name |
| 115 | ;; or Info-read-node-name-2. |
| 116 | (if (functionp pred) |
| 117 | (setq pred (lexical-let ((pred pred)) |
| 118 | ;; FIXME: this doesn't work if `table' is an obarray. |
| 119 | (lambda (s) (funcall pred (concat prefix s)))))) |
| 120 | (let ((comp (complete-with-action action table string pred))) |
| 121 | (cond |
| 122 | ;; In case of try-completion, add the prefix. |
| 123 | ((stringp comp) (concat prefix comp)) |
| 124 | ;; In case of non-empty all-completions, |
| 125 | ;; add the prefix size to the base-size. |
| 126 | ((consp comp) |
| 127 | (let ((last (last comp))) |
| 128 | (when completion-all-completions-with-base-size |
| 129 | (setcdr last (+ (or (cdr last) 0) (length prefix)))) |
| 130 | comp)) |
| 131 | (t comp)))) |
| 132 | |
| 133 | (defun completion-table-with-terminator (terminator table string pred action) |
| 134 | (cond |
| 135 | ((eq action nil) |
| 136 | (let ((comp (try-completion string table pred))) |
| 137 | (if (eq comp t) |
| 138 | (concat string terminator) |
| 139 | (if (and (stringp comp) |
| 140 | (eq (try-completion comp table pred) t)) |
| 141 | (concat comp terminator) |
| 142 | comp)))) |
| 143 | ((eq action t) (all-completions string table pred)) |
| 144 | ;; completion-table-with-terminator is always used for |
| 145 | ;; "sub-completions" so it's only called if the terminator is missing, |
| 146 | ;; in which case `test-completion' should return nil. |
| 147 | ((eq action 'lambda) nil))) |
| 148 | |
| 149 | (defun completion-table-with-predicate (table pred1 strict string pred2 action) |
| 150 | "Make a completion table equivalent to TABLE but filtered through PRED1. |
| 151 | PRED1 is a function of one argument which returns non-nil iff the |
| 152 | argument is an element of TABLE which should be considered for completion. |
| 153 | STRING, PRED2, and ACTION are the usual arguments to completion tables, |
| 154 | as described in `try-completion', `all-completions', and `test-completion'. |
| 155 | If STRICT is t, the predicate always applies; if nil it only applies if |
| 156 | it does not reduce the set of possible completions to nothing. |
| 157 | Note: TABLE needs to be a proper completion table which obeys predicates." |
| 158 | (cond |
| 159 | ((and (not strict) (eq action 'lambda)) |
| 160 | ;; Ignore pred1 since it doesn't really have to apply anyway. |
| 161 | (test-completion string table pred2)) |
| 162 | (t |
| 163 | (or (complete-with-action action table string |
| 164 | (if (null pred2) pred1 |
| 165 | (lexical-let ((pred1 pred2) (pred2 pred2)) |
| 166 | (lambda (x) |
| 167 | ;; Call `pred1' first, so that `pred2' |
| 168 | ;; really can't tell that `x' is in table. |
| 169 | (if (funcall pred1 x) (funcall pred2 x)))))) |
| 170 | ;; If completion failed and we're not applying pred1 strictly, try |
| 171 | ;; again without pred1. |
| 172 | (and (not strict) |
| 173 | (complete-with-action action table string pred2)))))) |
| 174 | |
| 175 | (defun completion-table-in-turn (&rest tables) |
| 176 | "Create a completion table that tries each table in TABLES in turn." |
| 177 | (lexical-let ((tables tables)) |
| 178 | (lambda (string pred action) |
| 179 | (completion--some (lambda (table) |
| 180 | (complete-with-action action table string pred)) |
| 181 | tables)))) |
| 182 | |
| 183 | ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) |
| 184 | ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) |
| 185 | (define-obsolete-function-alias |
| 186 | 'complete-in-turn 'completion-table-in-turn "23.1") |
| 187 | (define-obsolete-function-alias |
| 188 | 'dynamic-completion-table 'completion-table-dynamic "23.1") |
| 189 | |
| 190 | ;;; Minibuffer completion |
| 191 | |
| 192 | (defgroup minibuffer nil |
| 193 | "Controlling the behavior of the minibuffer." |
| 194 | :link '(custom-manual "(emacs)Minibuffer") |
| 195 | :group 'environment) |
| 196 | |
| 197 | (defun minibuffer-message (message &rest args) |
| 198 | "Temporarily display MESSAGE at the end of the minibuffer. |
| 199 | The text is displayed for `minibuffer-message-timeout' seconds, |
| 200 | or until the next input event arrives, whichever comes first. |
| 201 | Enclose MESSAGE in [...] if this is not yet the case. |
| 202 | If ARGS are provided, then pass MESSAGE through `format'." |
| 203 | ;; Clear out any old echo-area message to make way for our new thing. |
| 204 | (message nil) |
| 205 | (setq message (if (and (null args) (string-match "\\[.+\\]" message)) |
| 206 | ;; Make sure we can put-text-property. |
| 207 | (copy-sequence message) |
| 208 | (concat " [" message "]"))) |
| 209 | (when args (setq message (apply 'format message args))) |
| 210 | (let ((ol (make-overlay (point-max) (point-max) nil t t))) |
| 211 | (unwind-protect |
| 212 | (progn |
| 213 | (unless (zerop (length message)) |
| 214 | ;; The current C cursor code doesn't know to use the overlay's |
| 215 | ;; marker's stickiness to figure out whether to place the cursor |
| 216 | ;; before or after the string, so let's spoon-feed it the pos. |
| 217 | (put-text-property 0 1 'cursor t message)) |
| 218 | (overlay-put ol 'after-string message) |
| 219 | (sit-for (or minibuffer-message-timeout 1000000))) |
| 220 | (delete-overlay ol)))) |
| 221 | |
| 222 | (defun minibuffer-completion-contents () |
| 223 | "Return the user input in a minibuffer before point as a string. |
| 224 | That is what completion commands operate on." |
| 225 | (buffer-substring (field-beginning) (point))) |
| 226 | |
| 227 | (defun delete-minibuffer-contents () |
| 228 | "Delete all user input in a minibuffer. |
| 229 | If the current buffer is not a minibuffer, erase its entire contents." |
| 230 | (delete-field)) |
| 231 | |
| 232 | (defcustom completion-auto-help t |
| 233 | "Non-nil means automatically provide help for invalid completion input. |
| 234 | If the value is t the *Completion* buffer is displayed whenever completion |
| 235 | is requested but cannot be done. |
| 236 | If the value is `lazy', the *Completions* buffer is only displayed after |
| 237 | the second failed attempt to complete." |
| 238 | :type '(choice (const nil) (const t) (const lazy)) |
| 239 | :group 'minibuffer) |
| 240 | |
| 241 | (defvar completion-styles-alist |
| 242 | '((basic try-completion all-completions) |
| 243 | ;; (partial-completion |
| 244 | ;; completion-pcm--try-completion completion-pcm--all-completions) |
| 245 | ) |
| 246 | "List of available completion styles. |
| 247 | Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS) |
| 248 | where NAME is the name that should be used in `completion-styles' |
| 249 | TRY-COMPLETION is the function that does the completion, and |
| 250 | ALL-COMPLETIONS is the function that lists the completions.") |
| 251 | |
| 252 | (defcustom completion-styles '(basic) |
| 253 | "List of completion styles to use." |
| 254 | :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x))) |
| 255 | completion-styles-alist))) |
| 256 | :group 'minibuffer |
| 257 | :version "23.1") |
| 258 | |
| 259 | (defun completion-try-completion (string table pred) |
| 260 | ;; The property `completion-styles' indicates that this functional |
| 261 | ;; completion-table claims to take care of completion styles itself. |
| 262 | ;; [I.e. It will most likely call us back at some point. ] |
| 263 | (if (and (symbolp table) (get table 'completion-styles)) |
| 264 | (funcall table string pred nil) |
| 265 | (completion--some (lambda (style) |
| 266 | (funcall (nth 1 (assq style completion-styles-alist)) |
| 267 | string table pred)) |
| 268 | completion-styles))) |
| 269 | |
| 270 | (defun completion-all-completions (string table pred) |
| 271 | ;; The property `completion-styles' indicates that this functional |
| 272 | ;; completion-table claims to take care of completion styles itself. |
| 273 | ;; [I.e. It will most likely call us back at some point. ] |
| 274 | (let ((completion-all-completions-with-base-size t)) |
| 275 | (if (and (symbolp table) (get table 'no-completion-styles)) |
| 276 | (funcall table string pred t) |
| 277 | (completion--some (lambda (style) |
| 278 | (funcall (nth 2 (assq style completion-styles-alist)) |
| 279 | string table pred)) |
| 280 | completion-styles)))) |
| 281 | |
| 282 | (defun minibuffer--bitset (modified completions exact) |
| 283 | (logior (if modified 4 0) |
| 284 | (if completions 2 0) |
| 285 | (if exact 1 0))) |
| 286 | |
| 287 | (defun completion--do-completion (&optional try-completion-function) |
| 288 | "Do the completion and return a summary of what happened. |
| 289 | M = completion was performed, the text was Modified. |
| 290 | C = there were available Completions. |
| 291 | E = after completion we now have an Exact match. |
| 292 | |
| 293 | MCE |
| 294 | 000 0 no possible completion |
| 295 | 001 1 was already an exact and unique completion |
| 296 | 010 2 no completion happened |
| 297 | 011 3 was already an exact completion |
| 298 | 100 4 ??? impossible |
| 299 | 101 5 ??? impossible |
| 300 | 110 6 some completion happened |
| 301 | 111 7 completed to an exact completion" |
| 302 | (let* ((beg (field-beginning)) |
| 303 | (end (point)) |
| 304 | (string (buffer-substring beg end)) |
| 305 | (completion (funcall (or try-completion-function |
| 306 | 'completion-try-completion) |
| 307 | string |
| 308 | minibuffer-completion-table |
| 309 | minibuffer-completion-predicate))) |
| 310 | (cond |
| 311 | ((null completion) |
| 312 | (ding) (minibuffer-message "No match") (minibuffer--bitset nil nil nil)) |
| 313 | ((eq t completion) (minibuffer--bitset nil nil t)) ;Exact and unique match. |
| 314 | (t |
| 315 | ;; `completed' should be t if some completion was done, which doesn't |
| 316 | ;; include simply changing the case of the entered string. However, |
| 317 | ;; for appearance, the string is rewritten if the case changes. |
| 318 | (let ((completed (not (eq t (compare-strings completion nil nil |
| 319 | string nil nil t)))) |
| 320 | (unchanged (eq t (compare-strings completion nil nil |
| 321 | string nil nil nil)))) |
| 322 | (unless unchanged |
| 323 | |
| 324 | ;; Insert in minibuffer the chars we got. |
| 325 | (goto-char end) |
| 326 | (insert completion) |
| 327 | (delete-region beg end)) |
| 328 | |
| 329 | (if (not (or unchanged completed)) |
| 330 | ;; The case of the string changed, but that's all. We're not sure |
| 331 | ;; whether this is a unique completion or not, so try again using |
| 332 | ;; the real case (this shouldn't recurse again, because the next |
| 333 | ;; time try-completion will return either t or the exact string). |
| 334 | (completion--do-completion try-completion-function) |
| 335 | |
| 336 | ;; It did find a match. Do we match some possibility exactly now? |
| 337 | (let ((exact (test-completion (field-string) |
| 338 | minibuffer-completion-table |
| 339 | minibuffer-completion-predicate))) |
| 340 | (unless completed |
| 341 | ;; Show the completion table, if requested. |
| 342 | (cond |
| 343 | ((not exact) |
| 344 | (if (case completion-auto-help |
| 345 | (lazy (eq this-command last-command)) |
| 346 | (t completion-auto-help)) |
| 347 | (minibuffer-completion-help) |
| 348 | (minibuffer-message "Next char not unique"))) |
| 349 | ;; If the last exact completion and this one were the same, |
| 350 | ;; it means we've already given a "Complete but not unique" |
| 351 | ;; message and the user's hit TAB again, so now we give him help. |
| 352 | ((eq this-command last-command) |
| 353 | (if completion-auto-help (minibuffer-completion-help))))) |
| 354 | |
| 355 | (minibuffer--bitset completed t exact)))))))) |
| 356 | |
| 357 | (defun minibuffer-complete () |
| 358 | "Complete the minibuffer contents as far as possible. |
| 359 | Return nil if there is no valid completion, else t. |
| 360 | If no characters can be completed, display a list of possible completions. |
| 361 | If you repeat this command after it displayed such a list, |
| 362 | scroll the window of possible completions." |
| 363 | (interactive) |
| 364 | ;; If the previous command was not this, |
| 365 | ;; mark the completion buffer obsolete. |
| 366 | (unless (eq this-command last-command) |
| 367 | (setq minibuffer-scroll-window nil)) |
| 368 | |
| 369 | (let ((window minibuffer-scroll-window)) |
| 370 | ;; If there's a fresh completion window with a live buffer, |
| 371 | ;; and this command is repeated, scroll that window. |
| 372 | (if (window-live-p window) |
| 373 | (with-current-buffer (window-buffer window) |
| 374 | (if (pos-visible-in-window-p (point-max) window) |
| 375 | ;; If end is in view, scroll up to the beginning. |
| 376 | (set-window-start window (point-min) nil) |
| 377 | ;; Else scroll down one screen. |
| 378 | (scroll-other-window)) |
| 379 | nil) |
| 380 | |
| 381 | (case (completion--do-completion) |
| 382 | (0 nil) |
| 383 | (1 (goto-char (field-end)) |
| 384 | (minibuffer-message "Sole completion") |
| 385 | t) |
| 386 | (3 (goto-char (field-end)) |
| 387 | (minibuffer-message "Complete, but not unique") |
| 388 | t) |
| 389 | (t t))))) |
| 390 | |
| 391 | (defun minibuffer-complete-and-exit () |
| 392 | "If the minibuffer contents is a valid completion then exit. |
| 393 | Otherwise try to complete it. If completion leads to a valid completion, |
| 394 | a repetition of this command will exit." |
| 395 | (interactive) |
| 396 | (let ((beg (field-beginning)) |
| 397 | (end (field-end))) |
| 398 | (cond |
| 399 | ;; Allow user to specify null string |
| 400 | ((= beg end) (exit-minibuffer)) |
| 401 | ((test-completion (buffer-substring beg end) |
| 402 | minibuffer-completion-table |
| 403 | minibuffer-completion-predicate) |
| 404 | (when completion-ignore-case |
| 405 | ;; Fixup case of the field, if necessary. |
| 406 | (let* ((string (buffer-substring beg end)) |
| 407 | (compl (try-completion |
| 408 | string |
| 409 | minibuffer-completion-table |
| 410 | minibuffer-completion-predicate))) |
| 411 | (when (and (stringp compl) |
| 412 | ;; If it weren't for this piece of paranoia, I'd replace |
| 413 | ;; the whole thing with a call to do-completion. |
| 414 | (= (length string) (length compl))) |
| 415 | (goto-char end) |
| 416 | (insert compl) |
| 417 | (delete-region beg end)))) |
| 418 | (exit-minibuffer)) |
| 419 | |
| 420 | ((eq minibuffer-completion-confirm 'confirm-only) |
| 421 | ;; The user is permitted to exit with an input that's rejected |
| 422 | ;; by test-completion, but at the condition to confirm her choice. |
| 423 | (if (eq last-command this-command) |
| 424 | (exit-minibuffer) |
| 425 | (minibuffer-message "Confirm") |
| 426 | nil)) |
| 427 | |
| 428 | (t |
| 429 | ;; Call do-completion, but ignore errors. |
| 430 | (case (condition-case nil |
| 431 | (completion--do-completion) |
| 432 | (error 1)) |
| 433 | ((1 3) (exit-minibuffer)) |
| 434 | (7 (if (not minibuffer-completion-confirm) |
| 435 | (exit-minibuffer) |
| 436 | (minibuffer-message "Confirm") |
| 437 | nil)) |
| 438 | (t nil)))))) |
| 439 | |
| 440 | (defun completion--try-word-completion (string table predicate) |
| 441 | (let ((completion (completion-try-completion string table predicate))) |
| 442 | (if (not (stringp completion)) |
| 443 | completion |
| 444 | |
| 445 | ;; If completion finds next char not unique, |
| 446 | ;; consider adding a space or a hyphen. |
| 447 | (when (= (length string) (length completion)) |
| 448 | (let ((exts '(" " "-")) |
| 449 | tem) |
| 450 | (while (and exts (not (stringp tem))) |
| 451 | (setq tem (completion-try-completion |
| 452 | (concat string (pop exts)) |
| 453 | table predicate))) |
| 454 | (if (stringp tem) (setq completion tem)))) |
| 455 | |
| 456 | ;; Completing a single word is actually more difficult than completing |
| 457 | ;; as much as possible, because we first have to find the "current |
| 458 | ;; position" in `completion' in order to find the end of the word |
| 459 | ;; we're completing. Normally, `string' is a prefix of `completion', |
| 460 | ;; which makes it trivial to find the position, but with fancier |
| 461 | ;; completion (plus env-var expansion, ...) `completion' might not |
| 462 | ;; look anything like `string' at all. |
| 463 | |
| 464 | (when minibuffer-completing-file-name |
| 465 | ;; In order to minimize the problem mentioned above, let's try to |
| 466 | ;; reduce the different between `string' and `completion' by |
| 467 | ;; mirroring some of the work done in read-file-name-internal. |
| 468 | (let ((substituted (condition-case nil |
| 469 | ;; Might fail when completing an env-var. |
| 470 | (substitute-in-file-name string) |
| 471 | (error string)))) |
| 472 | (unless (eq string substituted) |
| 473 | (setq string substituted)))) |
| 474 | |
| 475 | ;; Make buffer (before point) contain the longest match |
| 476 | ;; of `string's tail and `completion's head. |
| 477 | (let* ((startpos (max 0 (- (length string) (length completion)))) |
| 478 | (length (- (length string) startpos))) |
| 479 | (while (and (> length 0) |
| 480 | (not (eq t (compare-strings string startpos nil |
| 481 | completion 0 length |
| 482 | completion-ignore-case)))) |
| 483 | (setq startpos (1+ startpos)) |
| 484 | (setq length (1- length))) |
| 485 | |
| 486 | (setq string (substring string startpos))) |
| 487 | |
| 488 | ;; Now `string' is a prefix of `completion'. |
| 489 | |
| 490 | ;; Otherwise cut after the first word. |
| 491 | (if (string-match "\\W" completion (length string)) |
| 492 | ;; First find first word-break in the stuff found by completion. |
| 493 | ;; i gets index in string of where to stop completing. |
| 494 | (substring completion 0 (match-end 0)) |
| 495 | completion)))) |
| 496 | |
| 497 | |
| 498 | (defun minibuffer-complete-word () |
| 499 | "Complete the minibuffer contents at most a single word. |
| 500 | After one word is completed as much as possible, a space or hyphen |
| 501 | is added, provided that matches some possible completion. |
| 502 | Return nil if there is no valid completion, else t." |
| 503 | (interactive) |
| 504 | (case (completion--do-completion 'completion--try-word-completion) |
| 505 | (0 nil) |
| 506 | (1 (goto-char (field-end)) |
| 507 | (minibuffer-message "Sole completion") |
| 508 | t) |
| 509 | (3 (goto-char (field-end)) |
| 510 | (minibuffer-message "Complete, but not unique") |
| 511 | t) |
| 512 | (t t))) |
| 513 | |
| 514 | (defun completion--insert-strings (strings) |
| 515 | "Insert a list of STRINGS into the current buffer. |
| 516 | Uses columns to keep the listing readable but compact. |
| 517 | It also eliminates runs of equal strings." |
| 518 | (when (consp strings) |
| 519 | (let* ((length (apply 'max |
| 520 | (mapcar (lambda (s) |
| 521 | (if (consp s) |
| 522 | (+ (length (car s)) (length (cadr s))) |
| 523 | (length s))) |
| 524 | strings))) |
| 525 | (window (get-buffer-window (current-buffer) 0)) |
| 526 | (wwidth (if window (1- (window-width window)) 79)) |
| 527 | (columns (min |
| 528 | ;; At least 2 columns; at least 2 spaces between columns. |
| 529 | (max 2 (/ wwidth (+ 2 length))) |
| 530 | ;; Don't allocate more columns than we can fill. |
| 531 | ;; Windows can't show less than 3 lines anyway. |
| 532 | (max 1 (/ (length strings) 2)))) |
| 533 | (colwidth (/ wwidth columns)) |
| 534 | (column 0) |
| 535 | (laststring nil)) |
| 536 | ;; The insertion should be "sensible" no matter what choices were made |
| 537 | ;; for the parameters above. |
| 538 | (dolist (str strings) |
| 539 | (unless (equal laststring str) ; Remove (consecutive) duplicates. |
| 540 | (setq laststring str) |
| 541 | (unless (bolp) |
| 542 | (insert " \t") |
| 543 | (setq column (+ column colwidth)) |
| 544 | ;; Leave the space unpropertized so that in the case we're |
| 545 | ;; already past the goal column, there is still |
| 546 | ;; a space displayed. |
| 547 | (set-text-properties (- (point) 1) (point) |
| 548 | ;; We can't just set tab-width, because |
| 549 | ;; completion-setup-function will kill all |
| 550 | ;; local variables :-( |
| 551 | `(display (space :align-to ,column)))) |
| 552 | (when (< wwidth (+ (max colwidth |
| 553 | (if (consp str) |
| 554 | (+ (length (car str)) (length (cadr str))) |
| 555 | (length str))) |
| 556 | column)) |
| 557 | (delete-char -2) (insert "\n") (setq column 0)) |
| 558 | (if (not (consp str)) |
| 559 | (put-text-property (point) (progn (insert str) (point)) |
| 560 | 'mouse-face 'highlight) |
| 561 | (put-text-property (point) (progn (insert (car str)) (point)) |
| 562 | 'mouse-face 'highlight) |
| 563 | (put-text-property (point) (progn (insert (cadr str)) (point)) |
| 564 | 'mouse-face nil))))))) |
| 565 | |
| 566 | (defvar completion-common-substring) |
| 567 | |
| 568 | (defvar completion-setup-hook nil |
| 569 | "Normal hook run at the end of setting up a completion list buffer. |
| 570 | When this hook is run, the current buffer is the one in which the |
| 571 | command to display the completion list buffer was run. |
| 572 | The completion list buffer is available as the value of `standard-output'. |
| 573 | The common prefix substring for completion may be available as the value |
| 574 | of `completion-common-substring'. See also `display-completion-list'.") |
| 575 | |
| 576 | (defun display-completion-list (completions &optional common-substring) |
| 577 | "Display the list of completions, COMPLETIONS, using `standard-output'. |
| 578 | Each element may be just a symbol or string |
| 579 | or may be a list of two strings to be printed as if concatenated. |
| 580 | If it is a list of two strings, the first is the actual completion |
| 581 | alternative, the second serves as annotation. |
| 582 | `standard-output' must be a buffer. |
| 583 | The actual completion alternatives, as inserted, are given `mouse-face' |
| 584 | properties of `highlight'. |
| 585 | At the end, this runs the normal hook `completion-setup-hook'. |
| 586 | It can find the completion buffer in `standard-output'. |
| 587 | The optional second arg COMMON-SUBSTRING is a string. |
| 588 | It is used to put faces, `completions-first-difference' and |
| 589 | `completions-common-part' on the completion buffer. The |
| 590 | `completions-common-part' face is put on the common substring |
| 591 | specified by COMMON-SUBSTRING. If COMMON-SUBSTRING is nil |
| 592 | and the current buffer is not the minibuffer, the faces are not put. |
| 593 | Internally, COMMON-SUBSTRING is bound to `completion-common-substring' |
| 594 | during running `completion-setup-hook'." |
| 595 | (if (not (bufferp standard-output)) |
| 596 | ;; This *never* (ever) happens, so there's no point trying to be clever. |
| 597 | (with-temp-buffer |
| 598 | (let ((standard-output (current-buffer)) |
| 599 | (completion-setup-hook nil)) |
| 600 | (display-completion-list completions)) |
| 601 | (princ (buffer-string))) |
| 602 | |
| 603 | (with-current-buffer standard-output |
| 604 | (goto-char (point-max)) |
| 605 | (if (null completions) |
| 606 | (insert "There are no possible completions of what you have typed.") |
| 607 | |
| 608 | (insert "Possible completions are:\n") |
| 609 | (let ((last (last completions))) |
| 610 | ;; Get the base-size from the tail of the list. |
| 611 | (set (make-local-variable 'completion-base-size) (or (cdr last) 0)) |
| 612 | (setcdr last nil)) ;Make completions a properly nil-terminated list. |
| 613 | (completion--insert-strings completions)))) |
| 614 | |
| 615 | (let ((completion-common-substring common-substring)) |
| 616 | (run-hooks 'completion-setup-hook)) |
| 617 | nil) |
| 618 | |
| 619 | (defun minibuffer-completion-help () |
| 620 | "Display a list of possible completions of the current minibuffer contents." |
| 621 | (interactive) |
| 622 | (message "Making completion list...") |
| 623 | (let* ((string (field-string)) |
| 624 | (completions (completion-all-completions |
| 625 | string |
| 626 | minibuffer-completion-table |
| 627 | minibuffer-completion-predicate))) |
| 628 | (message nil) |
| 629 | (if (and completions |
| 630 | (or (consp (cdr completions)) |
| 631 | (not (equal (car completions) string)))) |
| 632 | (with-output-to-temp-buffer "*Completions*" |
| 633 | (let* ((last (last completions)) |
| 634 | (base-size (cdr last))) |
| 635 | ;; Remove the base-size tail because `sort' requires a properly |
| 636 | ;; nil-terminated list. |
| 637 | (when last (setcdr last nil)) |
| 638 | (display-completion-list (nconc (sort completions 'string-lessp) |
| 639 | base-size)))) |
| 640 | |
| 641 | ;; If there are no completions, or if the current input is already the |
| 642 | ;; only possible completion, then hide (previous&stale) completions. |
| 643 | (let ((window (and (get-buffer "*Completions*") |
| 644 | (get-buffer-window "*Completions*" 0)))) |
| 645 | (when (and (window-live-p window) (window-dedicated-p window)) |
| 646 | (condition-case () |
| 647 | (delete-window window) |
| 648 | (error (iconify-frame (window-frame window)))))) |
| 649 | (ding) |
| 650 | (minibuffer-message |
| 651 | (if completions "Sole completion" "No completions"))) |
| 652 | nil)) |
| 653 | |
| 654 | (defun exit-minibuffer () |
| 655 | "Terminate this minibuffer argument." |
| 656 | (interactive) |
| 657 | ;; If the command that uses this has made modifications in the minibuffer, |
| 658 | ;; we don't want them to cause deactivation of the mark in the original |
| 659 | ;; buffer. |
| 660 | ;; A better solution would be to make deactivate-mark buffer-local |
| 661 | ;; (or to turn it into a list of buffers, ...), but in the mean time, |
| 662 | ;; this should do the trick in most cases. |
| 663 | (setq deactivate-mark nil) |
| 664 | (throw 'exit nil)) |
| 665 | |
| 666 | (defun self-insert-and-exit () |
| 667 | "Terminate minibuffer input." |
| 668 | (interactive) |
| 669 | (if (characterp last-command-char) |
| 670 | (call-interactively 'self-insert-command) |
| 671 | (ding)) |
| 672 | (exit-minibuffer)) |
| 673 | |
| 674 | (defun minibuffer--double-dollars (str) |
| 675 | (replace-regexp-in-string "\\$" "$$" str)) |
| 676 | |
| 677 | (defun completion--make-envvar-table () |
| 678 | (mapcar (lambda (enventry) |
| 679 | (substring enventry 0 (string-match "=" enventry))) |
| 680 | process-environment)) |
| 681 | |
| 682 | (defun completion--embedded-envvar-table (string pred action) |
| 683 | (when (string-match (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" |
| 684 | "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'") |
| 685 | string) |
| 686 | (let* ((beg (or (match-beginning 2) (match-beginning 1))) |
| 687 | (table (completion--make-envvar-table)) |
| 688 | (prefix (substring string 0 beg))) |
| 689 | (if (eq (aref string (1- beg)) ?{) |
| 690 | (setq table (apply-partially 'completion-table-with-terminator |
| 691 | "}" table))) |
| 692 | (completion-table-with-context prefix table |
| 693 | (substring string beg) |
| 694 | pred action)))) |
| 695 | |
| 696 | (defun completion--file-name-table (string pred action) |
| 697 | "Internal subroutine for `read-file-name'. Do not call this." |
| 698 | (if (and (zerop (length string)) (eq 'lambda action)) |
| 699 | nil ; FIXME: why? |
| 700 | (let* ((dir (if (stringp pred) |
| 701 | ;; It used to be that `pred' was abused to pass `dir' |
| 702 | ;; as an argument. |
| 703 | (prog1 (expand-file-name pred) (setq pred nil)) |
| 704 | default-directory)) |
| 705 | (str (condition-case nil |
| 706 | (substitute-in-file-name string) |
| 707 | (error string))) |
| 708 | (name (file-name-nondirectory str)) |
| 709 | (specdir (file-name-directory str)) |
| 710 | (realdir (if specdir (expand-file-name specdir dir) |
| 711 | (file-name-as-directory dir)))) |
| 712 | |
| 713 | (cond |
| 714 | ((null action) |
| 715 | (let ((comp (file-name-completion name realdir |
| 716 | read-file-name-predicate))) |
| 717 | (if (stringp comp) |
| 718 | ;; Requote the $s before returning the completion. |
| 719 | (minibuffer--double-dollars (concat specdir comp)) |
| 720 | ;; Requote the $s before checking for changes. |
| 721 | (setq str (minibuffer--double-dollars str)) |
| 722 | (if (string-equal string str) |
| 723 | comp |
| 724 | ;; If there's no real completion, but substitute-in-file-name |
| 725 | ;; changed the string, then return the new string. |
| 726 | str)))) |
| 727 | |
| 728 | ((eq action t) |
| 729 | (let ((all (file-name-all-completions name realdir)) |
| 730 | ;; Actually, this is not always right in the presence of |
| 731 | ;; envvars, but there's not much we can do, I think. |
| 732 | (base-size (length (file-name-directory string)))) |
| 733 | |
| 734 | ;; Check the predicate, if necessary. |
| 735 | (unless (memq read-file-name-predicate '(nil file-exists-p)) |
| 736 | (let ((comp ()) |
| 737 | (pred |
| 738 | (if (eq read-file-name-predicate 'file-directory-p) |
| 739 | ;; Brute-force speed up for directory checking: |
| 740 | ;; Discard strings which don't end in a slash. |
| 741 | (lambda (s) |
| 742 | (let ((len (length s))) |
| 743 | (and (> len 0) (eq (aref s (1- len)) ?/)))) |
| 744 | ;; Must do it the hard (and slow) way. |
| 745 | read-file-name-predicate))) |
| 746 | (let ((default-directory realdir)) |
| 747 | (dolist (tem all) |
| 748 | (if (funcall pred tem) (push tem comp)))) |
| 749 | (setq all (nreverse comp)))) |
| 750 | |
| 751 | (if (and completion-all-completions-with-base-size (consp all)) |
| 752 | ;; Add base-size, but only if the list is non-empty. |
| 753 | (nconc all base-size)) |
| 754 | |
| 755 | all)) |
| 756 | |
| 757 | (t |
| 758 | ;; Only other case actually used is ACTION = lambda. |
| 759 | (let ((default-directory dir)) |
| 760 | (funcall (or read-file-name-predicate 'file-exists-p) str))))))) |
| 761 | |
| 762 | (defalias 'read-file-name-internal |
| 763 | (completion-table-in-turn 'completion--embedded-envvar-table |
| 764 | 'completion--file-name-table) |
| 765 | "Internal subroutine for `read-file-name'. Do not call this.") |
| 766 | |
| 767 | (provide 'minibuffer) |
| 768 | |
| 769 | ;; arch-tag: ef8a0a15-1080-4790-a754-04017c02f08f |
| 770 | ;;; minibuffer.el ends here |