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