| 1 | ;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*- |
| 2 | |
| 3 | ;; Copyright (C) 2008-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> |
| 6 | ;; Package: emacs |
| 7 | |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | |
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 11 | ;; it under the terms of the GNU General Public License as published by |
| 12 | ;; the Free Software Foundation, either version 3 of the License, or |
| 13 | ;; (at your option) any later version. |
| 14 | |
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;; GNU General Public License for more details. |
| 19 | |
| 20 | ;; You should have received a copy of the GNU General Public License |
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 22 | |
| 23 | ;;; Commentary: |
| 24 | |
| 25 | ;; Names with "--" are for functions and variables that are meant to be for |
| 26 | ;; internal use only. |
| 27 | |
| 28 | ;; Functional completion tables have an extended calling conventions: |
| 29 | ;; The `action' can be (additionally to nil, t, and lambda) of the form |
| 30 | ;; - (boundaries . SUFFIX) in which case it should return |
| 31 | ;; (boundaries START . END). See `completion-boundaries'. |
| 32 | ;; Any other return value should be ignored (so we ignore values returned |
| 33 | ;; from completion tables that don't know about this new `action' form). |
| 34 | ;; - `metadata' in which case it should return (metadata . ALIST) where |
| 35 | ;; ALIST is the metadata of this table. See `completion-metadata'. |
| 36 | ;; Any other return value should be ignored (so we ignore values returned |
| 37 | ;; from completion tables that don't know about this new `action' form). |
| 38 | |
| 39 | ;;; Bugs: |
| 40 | |
| 41 | ;; - completion-all-sorted-completions lists all the completions, whereas |
| 42 | ;; it should only lists the ones that `try-completion' would consider. |
| 43 | ;; E.g. it should honor completion-ignored-extensions. |
| 44 | ;; - choose-completion can't automatically figure out the boundaries |
| 45 | ;; corresponding to the displayed completions because we only |
| 46 | ;; provide the start info but not the end info in |
| 47 | ;; completion-base-position. |
| 48 | ;; - C-x C-f ~/*/sr ? should not list "~/./src". |
| 49 | ;; - minibuffer-force-complete completes ~/src/emacs/t<!>/lisp/minibuffer.el |
| 50 | ;; to ~/src/emacs/trunk/ and throws away lisp/minibuffer.el. |
| 51 | |
| 52 | ;;; Todo: |
| 53 | |
| 54 | ;; - Make *Completions* readable even if some of the completion |
| 55 | ;; entries have LF chars or spaces in them (including at |
| 56 | ;; beginning/end) or are very long. |
| 57 | ;; - for M-x, cycle-sort commands that have no key binding first. |
| 58 | ;; - Make things like icomplete-mode or lightning-completion work with |
| 59 | ;; completion-in-region-mode. |
| 60 | ;; - extend `metadata': |
| 61 | ;; - indicate how to turn all-completion's output into |
| 62 | ;; try-completion's output: e.g. completion-ignored-extensions. |
| 63 | ;; maybe that could be merged with the "quote" operation. |
| 64 | ;; - indicate that `all-completions' doesn't do prefix-completion |
| 65 | ;; but just returns some list that relates in some other way to |
| 66 | ;; the provided string (as is the case in filecache.el), in which |
| 67 | ;; case partial-completion (for example) doesn't make any sense |
| 68 | ;; and neither does the completions-first-difference highlight. |
| 69 | ;; - indicate how to display the completions in *Completions* (turn |
| 70 | ;; \n into something else, add special boundaries between |
| 71 | ;; completions). E.g. when completing from the kill-ring. |
| 72 | |
| 73 | ;; - case-sensitivity currently confuses two issues: |
| 74 | ;; - whether or not a particular completion table should be case-sensitive |
| 75 | ;; (i.e. whether strings that differ only by case are semantically |
| 76 | ;; equivalent) |
| 77 | ;; - whether the user wants completion to pay attention to case. |
| 78 | ;; e.g. we may want to make it possible for the user to say "first try |
| 79 | ;; completion case-sensitively, and if that fails, try to ignore case". |
| 80 | ;; Maybe the trick is that we should distinguish completion-ignore-case in |
| 81 | ;; try/all-completions (obey user's preference) from its use in |
| 82 | ;; test-completion (obey the underlying object's semantics). |
| 83 | |
| 84 | ;; - add support for ** to pcm. |
| 85 | ;; - Add vc-file-name-completion-table to read-file-name-internal. |
| 86 | ;; - A feature like completing-help.el. |
| 87 | |
| 88 | ;;; Code: |
| 89 | |
| 90 | (eval-when-compile (require 'cl-lib)) |
| 91 | |
| 92 | (defun minibuf-conform-representation (string basis) |
| 93 | (cond |
| 94 | ((eq (multibyte-string-p string) (multibyte-string-p basis)) |
| 95 | string) |
| 96 | ((multibyte-string-p string) |
| 97 | (string-make-unibyte string)) |
| 98 | (t |
| 99 | (string-make-multibyte string)))) |
| 100 | |
| 101 | (defun try-completion (string collection &optional predicate) |
| 102 | "Return common substring of all completions of STRING in COLLECTION. |
| 103 | Test each possible completion specified by COLLECTION |
| 104 | to see if it begins with STRING. The possible completions may be |
| 105 | strings or symbols. Symbols are converted to strings before testing, |
| 106 | see `symbol-name'. |
| 107 | All that match STRING are compared together; the longest initial sequence |
| 108 | common to all these matches is the return value. |
| 109 | If there is no match at all, the return value is nil. |
| 110 | For a unique match which is exact, the return value is t. |
| 111 | |
| 112 | If COLLECTION is an alist, the keys (cars of elements) are the |
| 113 | possible completions. If an element is not a cons cell, then the |
| 114 | element itself is the possible completion. |
| 115 | If COLLECTION is a hash-table, all the keys that are strings or symbols |
| 116 | are the possible completions. |
| 117 | If COLLECTION is an obarray, the names of all symbols in the obarray |
| 118 | are the possible completions. |
| 119 | |
| 120 | COLLECTION can also be a function to do the completion itself. |
| 121 | It receives three arguments: the values STRING, PREDICATE and nil. |
| 122 | Whatever it returns becomes the value of `try-completion'. |
| 123 | |
| 124 | If optional third argument PREDICATE is non-nil, |
| 125 | it is used to test each possible match. |
| 126 | The match is a candidate only if PREDICATE returns non-nil. |
| 127 | The argument given to PREDICATE is the alist element |
| 128 | or the symbol from the obarray. If COLLECTION is a hash-table, |
| 129 | predicate is called with two arguments: the key and the value. |
| 130 | Additionally to this predicate, `completion-regexp-list' |
| 131 | is used to further constrain the set of candidates." |
| 132 | (catch 'return |
| 133 | (let (bestmatch |
| 134 | eltstring |
| 135 | ;; Size in bytes of BESTMATCH. |
| 136 | (bestmatchsize 0) |
| 137 | ;; These are in bytes, too. |
| 138 | (compare 0) |
| 139 | (matchsize 0) |
| 140 | (type (cond |
| 141 | ((hash-table-p collection) 'hash-table) |
| 142 | ((vectorp collection) 'obarray) |
| 143 | ((or (null collection) |
| 144 | (and (consp collection) |
| 145 | (not (functionp collection)))) |
| 146 | 'list) |
| 147 | (t 'function))) |
| 148 | (matchcount 0)) |
| 149 | ;;(cl-check-type string string) |
| 150 | (when (eq type 'function) |
| 151 | (throw 'return |
| 152 | (funcall collection string predicate nil))) |
| 153 | (catch 'break |
| 154 | (funcall |
| 155 | (cond |
| 156 | ((eq type 'hash-table) #'maphash) |
| 157 | ((eq type 'list) #'mapc) |
| 158 | ((eq type 'obarray) #'mapatoms)) |
| 159 | (lambda (elt &optional hash-value) |
| 160 | (catch 'continue |
| 161 | ;; Is this element a possible completion? |
| 162 | (setq eltstring (if (and (eq type 'list) (consp elt)) |
| 163 | (car elt) |
| 164 | elt)) |
| 165 | (when (symbolp eltstring) |
| 166 | (setq eltstring (symbol-name eltstring))) |
| 167 | (when (and (stringp eltstring) |
| 168 | (<= (length string) (length eltstring)) |
| 169 | (eq t (compare-strings eltstring |
| 170 | 0 |
| 171 | (length string) |
| 172 | string |
| 173 | 0 |
| 174 | nil |
| 175 | completion-ignore-case))) |
| 176 | ;; Yes. |
| 177 | (let ((case-fold-search completion-ignore-case)) |
| 178 | (let ((regexps completion-regexp-list)) |
| 179 | (while (consp regexps) |
| 180 | (when (null (string-match (car regexps) eltstring 0)) |
| 181 | (throw 'continue nil)) |
| 182 | (setq regexps (cdr regexps))))) |
| 183 | ;; Ignore this element if there is a predicate and the |
| 184 | ;; predicate doesn't like it. |
| 185 | (unless (cond |
| 186 | ((null predicate) t) |
| 187 | ((eq predicate 'commandp) |
| 188 | (commandp elt nil)) |
| 189 | ((eq type 'hash-table) |
| 190 | (funcall predicate elt hash-value)) |
| 191 | (t (funcall predicate elt))) |
| 192 | (throw 'continue nil)) |
| 193 | ;; Update computation of how much all possible completions match |
| 194 | (if (null bestmatch) |
| 195 | (setq matchcount 1 |
| 196 | bestmatch eltstring |
| 197 | bestmatchsize (length eltstring)) |
| 198 | (setq compare (min bestmatchsize (length eltstring)) |
| 199 | matchsize |
| 200 | (let ((tem (compare-strings bestmatch |
| 201 | 0 |
| 202 | compare |
| 203 | eltstring |
| 204 | 0 |
| 205 | compare |
| 206 | completion-ignore-case))) |
| 207 | (if (eq tem t) compare (1- (abs tem))))) |
| 208 | (when completion-ignore-case |
| 209 | ;; If this is an exact match except for case, use it as |
| 210 | ;; the best match rather than one that is not an exact |
| 211 | ;; match. This way, we get the case pattern of the actual |
| 212 | ;; match. |
| 213 | (when (or (and (eql matchsize (length eltstring)) |
| 214 | (< matchsize (length bestmatch))) |
| 215 | ;; If there is more than one exact match |
| 216 | ;; ignoring case, and one of them is exact |
| 217 | ;; including case, prefer that one. If there is |
| 218 | ;; no exact match ignoring case, prefer a match |
| 219 | ;; that does not change the case of the input. |
| 220 | (and (eql (eql matchsize (length eltstring)) |
| 221 | (eql matchsize (length bestmatch))) |
| 222 | (eq t (compare-strings eltstring |
| 223 | 0 |
| 224 | (length string) |
| 225 | string |
| 226 | 0 |
| 227 | nil |
| 228 | nil)) |
| 229 | (not (eq t (compare-strings bestmatch |
| 230 | 0 |
| 231 | (length string) |
| 232 | string |
| 233 | 0 |
| 234 | nil |
| 235 | nil))))) |
| 236 | (setq bestmatch eltstring))) |
| 237 | (when (or (not (eql bestmatchsize (length eltstring))) |
| 238 | (not (eql bestmatchsize matchsize))) |
| 239 | ;; Don't count the same string multiple times. |
| 240 | (if (<= matchcount 1) |
| 241 | (setq matchcount (+ matchcount 1)))) |
| 242 | (setq bestmatchsize matchsize) |
| 243 | (when (and (<= matchsize (length string)) |
| 244 | ;; If completion-ignore-case is non-nil, don't |
| 245 | ;; short-circuit because we want to find the |
| 246 | ;; best possible match *including* case |
| 247 | ;; differences. |
| 248 | (not completion-ignore-case) |
| 249 | (> matchcount 1)) |
| 250 | ;; No need to look any further. |
| 251 | (throw 'break nil)))))) |
| 252 | collection)) |
| 253 | (cond |
| 254 | ;; No completions found. |
| 255 | ((null bestmatch) |
| 256 | nil) |
| 257 | ;; If we are ignoring case, and there is no exact match, and no |
| 258 | ;; additional text was supplied, don't change the case of what the |
| 259 | ;; user typed. |
| 260 | ((and completion-ignore-case |
| 261 | (eql bestmatchsize (length string)) |
| 262 | (> (length bestmatch) bestmatchsize)) |
| 263 | (minibuf-conform-representation string bestmatch)) |
| 264 | ;; Return t if the supplied string is an exact match (counting |
| 265 | ;; case); it does not require any change to be made. |
| 266 | ((and (eql matchcount 1) (equal bestmatch string)) |
| 267 | t) |
| 268 | ;; Else extract the part in which all completions agree. |
| 269 | (t (substring bestmatch 0 bestmatchsize)))))) |
| 270 | |
| 271 | (defun all-completions (string collection &optional predicate hide-spaces) |
| 272 | "Search for partial matches to STRING in COLLECTION. |
| 273 | Test each of the possible completions specified by COLLECTION |
| 274 | to see if it begins with STRING. The possible completions may be |
| 275 | strings or symbols. Symbols are converted to strings before testing, |
| 276 | see `symbol-name'. |
| 277 | The value is a list of all the possible completions that match STRING. |
| 278 | |
| 279 | If COLLECTION is an alist, the keys (cars of elements) are the |
| 280 | possible completions. If an element is not a cons cell, then the |
| 281 | element itself is the possible completion. |
| 282 | If COLLECTION is a hash-table, all the keys that are strings or symbols |
| 283 | are the possible completions. |
| 284 | If COLLECTION is an obarray, the names of all symbols in the obarray |
| 285 | are the possible completions. |
| 286 | |
| 287 | COLLECTION can also be a function to do the completion itself. |
| 288 | It receives three arguments: the values STRING, PREDICATE and t. |
| 289 | Whatever it returns becomes the value of `all-completions'. |
| 290 | |
| 291 | If optional third argument PREDICATE is non-nil, |
| 292 | it is used to test each possible match. |
| 293 | The match is a candidate only if PREDICATE returns non-nil. |
| 294 | The argument given to PREDICATE is the alist element |
| 295 | or the symbol from the obarray. If COLLECTION is a hash-table, |
| 296 | predicate is called with two arguments: the key and the value. |
| 297 | Additionally to this predicate, `completion-regexp-list' |
| 298 | is used to further constrain the set of candidates. |
| 299 | |
| 300 | An obsolete optional fourth argument HIDE-SPACES is still accepted for |
| 301 | backward compatibility. If non-nil, strings in COLLECTION that start |
| 302 | with a space are ignored unless STRING itself starts with a space." |
| 303 | (catch 'return |
| 304 | (let (eltstring |
| 305 | allmatches |
| 306 | (type (cond ((hash-table-p collection) 'hash-table) |
| 307 | ((vectorp collection) 'obarray) |
| 308 | ((or (null collection) |
| 309 | (and (consp collection) |
| 310 | (not (functionp collection)))) |
| 311 | 'list) |
| 312 | (t 'function)))) |
| 313 | ;;(cl-check-type string string) |
| 314 | (when (eq type 'function) |
| 315 | (throw 'return |
| 316 | (funcall collection string predicate t))) |
| 317 | (catch 'break |
| 318 | (funcall |
| 319 | (cond |
| 320 | ((eq type 'hash-table) #'maphash) |
| 321 | ((eq type 'obarray) #'mapatoms) |
| 322 | ((eq type 'list) #'mapc)) |
| 323 | (lambda (elt &optional hash-value) |
| 324 | (catch 'continue |
| 325 | (setq eltstring (if (and (eq type 'list) (consp elt)) |
| 326 | (car elt) |
| 327 | elt)) |
| 328 | ;; Is this element a possible completion? |
| 329 | (when (symbolp eltstring) |
| 330 | (setq eltstring (symbol-name eltstring))) |
| 331 | (when (and (stringp eltstring) |
| 332 | (<= (length string) (length eltstring)) |
| 333 | ;; If HIDE_SPACES, reject alternatives that start |
| 334 | ;; with space unless the input starts with space. |
| 335 | (or (not hide-spaces) |
| 336 | (and (> (length string) 0) |
| 337 | (eql (aref string 0) ?\ )) |
| 338 | (eql (aref eltstring 0) ?\ )) |
| 339 | (eq t (compare-strings eltstring 0 |
| 340 | (length string) |
| 341 | string 0 |
| 342 | (length string) |
| 343 | completion-ignore-case))) |
| 344 | (let ((case-fold-search completion-ignore-case)) |
| 345 | (let ((regexps completion-regexp-list)) |
| 346 | (while (consp regexps) |
| 347 | (unless (string-match (car regexps) eltstring 0) |
| 348 | (throw 'continue nil)) |
| 349 | (setq regexps (cdr regexps))))) |
| 350 | ;; Ignore this element if there is a predicate and the |
| 351 | ;; predicate doesn't like it. |
| 352 | (unless (cond |
| 353 | ((not predicate) t) |
| 354 | ((eq predicate 'commandp) (commandp elt nil)) |
| 355 | ((eq type 'hash-table) (funcall predicate elt hash-value)) |
| 356 | (t (funcall predicate elt))) |
| 357 | (throw 'continue nil)) |
| 358 | ;; Ok => put it on the list. |
| 359 | (setq allmatches (cons eltstring allmatches))))) |
| 360 | collection)) |
| 361 | (nreverse allmatches)))) |
| 362 | |
| 363 | (set-advertised-calling-convention |
| 364 | 'all-completions '(string collection &optional predicate) "23.1") |
| 365 | |
| 366 | (defun test-completion (string collection &optional predicate) |
| 367 | "Return non-nil if STRING is a valid completion. |
| 368 | Takes the same arguments as `all-completions' and `try-completion'. |
| 369 | If COLLECTION is a function, it is called with three arguments: |
| 370 | the values STRING, PREDICATE and `lambda'." |
| 371 | (catch 'return |
| 372 | (let (tem) |
| 373 | ;; check-string string |
| 374 | (cond |
| 375 | ((or (null collection) |
| 376 | (and (consp collection) |
| 377 | (not (functionp collection)))) |
| 378 | (setq tem (assoc-string string collection completion-ignore-case)) |
| 379 | (unless tem |
| 380 | (throw 'return nil))) |
| 381 | ((vectorp collection) |
| 382 | (setq tem (intern-soft string collection)) ; XXX nil |
| 383 | (unless tem |
| 384 | (let ((string (if (multibyte-string-p string) |
| 385 | (string-make-unibyte string) |
| 386 | (string-make-multibyte string)))) |
| 387 | (setq tem (intern-soft string collection)))) |
| 388 | (when (and completion-ignore-case (not tem)) |
| 389 | (catch 'break |
| 390 | (mapatoms |
| 391 | #'(lambda (symbol) |
| 392 | (if (eq t (compare-strings string 0 nil |
| 393 | (symbol-name symbol) 0 nil |
| 394 | t)) |
| 395 | (setq tem symbol) |
| 396 | (throw 'break nil))) |
| 397 | collection))) |
| 398 | (unless tem |
| 399 | (throw 'return nil))) |
| 400 | ((hash-table-p collection) |
| 401 | (let ((unique (cons nil nil))) |
| 402 | (let ((x (gethash string collection unique))) |
| 403 | (if (not (eq x unique)) |
| 404 | (setq tem x) |
| 405 | (catch 'break |
| 406 | (maphash |
| 407 | #'(lambda (key value) |
| 408 | value ; ignore |
| 409 | (let ((key (if (symbolp key) (symbol-name key) key))) |
| 410 | (when (and (stringp key) |
| 411 | (eq t (compare-strings string 0 nil |
| 412 | key 0 nil |
| 413 | completion-ignore-case))) |
| 414 | (setq tem key) |
| 415 | (throw 'break nil)))) |
| 416 | collection))) |
| 417 | (unless (stringp tem) |
| 418 | (throw 'return nil))))) |
| 419 | (t (throw 'return (funcall collection string predicate 'lambda)))) |
| 420 | ;; Reject this element if it fails to match all the regexps. |
| 421 | (when (consp completion-regexp-list) |
| 422 | (let ((case-fold-search completion-ignore-case)) |
| 423 | (let ((regexps completion-regexp-list)) |
| 424 | (while (consp regexps) |
| 425 | (unless (string-match (car regexps) |
| 426 | (if (symbolp tem) string tem) |
| 427 | nil) |
| 428 | (throw 'return nil)) |
| 429 | (setq regexps (cdr regexps)))))) |
| 430 | ;; Finally, check the predicate. |
| 431 | (if predicate |
| 432 | (if (hash-table-p collection) |
| 433 | (funcall predicate tem (gethash tem collection)) |
| 434 | (funcall predicate tem)) |
| 435 | t)))) |
| 436 | |
| 437 | (defun internal-complete-buffer (string predicate flag) |
| 438 | "Perform completion on buffer names. |
| 439 | STRING and PREDICATE have the same meanings as in `try-completion', |
| 440 | `all-completions', and `test-completion'. |
| 441 | |
| 442 | If FLAG is nil, invoke `try-completion'; if it is t, invoke |
| 443 | `all-completions'; otherwise invoke `test-completion'." |
| 444 | (let ((buffer-alist (mapcar #'(lambda (buf) |
| 445 | (cons (buffer-name buf) buf)) |
| 446 | (buffer-list)))) |
| 447 | (cond |
| 448 | ((not flag) |
| 449 | (try-completion string buffer-alist predicate)) |
| 450 | ((eq flag t) |
| 451 | (let ((res (all-completions string buffer-alist predicate nil))) |
| 452 | (if (> (length string) 0) |
| 453 | res |
| 454 | ;; Strip out internal buffers. |
| 455 | (let ((bufs res)) |
| 456 | ;; First, look for a non-internal buffer in `res'. |
| 457 | (while (and (consp bufs) |
| 458 | (eql (aref (car bufs) 0) ?\ )) |
| 459 | (setq bufs (cdr bufs))) |
| 460 | (if (null bufs) |
| 461 | (if (eql (length res) (length buffer-alist)) |
| 462 | ;; If all bufs are internal don't strip them out. |
| 463 | res |
| 464 | bufs) |
| 465 | (setq res bufs) |
| 466 | (while (consp (cdr bufs)) |
| 467 | (if (eql (aref (cadr bufs) 0) ?\ ) |
| 468 | (rplacd bufs (cddr bufs)) |
| 469 | (setq bufs (cdr bufs)))) |
| 470 | res))))) |
| 471 | ((eq flag 'lambda) |
| 472 | (test-completion string buffer-alist predicate)) |
| 473 | ((eq flag 'metadata) |
| 474 | (list 'metadata (cons 'category 'buffer))) |
| 475 | (t nil)))) |
| 476 | |
| 477 | ;;; Completion table manipulation |
| 478 | |
| 479 | ;; New completion-table operation. |
| 480 | (defun completion-boundaries (string table pred suffix) |
| 481 | "Return the boundaries of the completions returned by TABLE for STRING. |
| 482 | STRING is the string on which completion will be performed. |
| 483 | SUFFIX is the string after point. |
| 484 | The result is of the form (START . END) where START is the position |
| 485 | in STRING of the beginning of the completion field and END is the position |
| 486 | in SUFFIX of the end of the completion field. |
| 487 | E.g. for simple completion tables, the result is always (0 . (length SUFFIX)) |
| 488 | and for file names the result is the positions delimited by |
| 489 | the closest directory separators." |
| 490 | (let ((boundaries (if (functionp table) |
| 491 | (funcall table string pred |
| 492 | (cons 'boundaries suffix))))) |
| 493 | (if (not (eq (car-safe boundaries) 'boundaries)) |
| 494 | (setq boundaries nil)) |
| 495 | (cons (or (cadr boundaries) 0) |
| 496 | (or (cddr boundaries) (length suffix))))) |
| 497 | |
| 498 | (defun completion-metadata (string table pred) |
| 499 | "Return the metadata of elements to complete at the end of STRING. |
| 500 | This metadata is an alist. Currently understood keys are: |
| 501 | - `category': the kind of objects returned by `all-completions'. |
| 502 | Used by `completion-category-overrides'. |
| 503 | - `annotation-function': function to add annotations in *Completions*. |
| 504 | Takes one argument (STRING), which is a possible completion and |
| 505 | returns a string to append to STRING. |
| 506 | - `display-sort-function': function to sort entries in *Completions*. |
| 507 | Takes one argument (COMPLETIONS) and should return a new list |
| 508 | of completions. Can operate destructively. |
| 509 | - `cycle-sort-function': function to sort entries when cycling. |
| 510 | Works like `display-sort-function'. |
| 511 | The metadata of a completion table should be constant between two boundaries." |
| 512 | (let ((metadata (if (functionp table) |
| 513 | (funcall table string pred 'metadata)))) |
| 514 | (if (eq (car-safe metadata) 'metadata) |
| 515 | metadata |
| 516 | '(metadata)))) |
| 517 | |
| 518 | (defun completion--field-metadata (field-start) |
| 519 | (completion-metadata (buffer-substring-no-properties field-start (point)) |
| 520 | minibuffer-completion-table |
| 521 | minibuffer-completion-predicate)) |
| 522 | |
| 523 | (defun completion-metadata-get (metadata prop) |
| 524 | (cdr (assq prop metadata))) |
| 525 | |
| 526 | (defun completion--some (fun xs) |
| 527 | "Apply FUN to each element of XS in turn. |
| 528 | Return the first non-nil returned value. |
| 529 | Like CL's `some'." |
| 530 | (let ((firsterror nil) |
| 531 | res) |
| 532 | (while (and (not res) xs) |
| 533 | (condition-case-unless-debug err |
| 534 | (setq res (funcall fun (pop xs))) |
| 535 | (error (unless firsterror (setq firsterror err)) nil))) |
| 536 | (or res |
| 537 | (if firsterror (signal (car firsterror) (cdr firsterror)))))) |
| 538 | |
| 539 | (defun complete-with-action (action table string pred) |
| 540 | "Perform completion ACTION. |
| 541 | STRING is the string to complete. |
| 542 | TABLE is the completion table. |
| 543 | PRED is a completion predicate. |
| 544 | ACTION can be one of nil, t or `lambda'." |
| 545 | (cond |
| 546 | ((functionp table) (funcall table string pred action)) |
| 547 | ((eq (car-safe action) 'boundaries) nil) |
| 548 | ((eq action 'metadata) nil) |
| 549 | (t |
| 550 | (funcall |
| 551 | (cond |
| 552 | ((null action) 'try-completion) |
| 553 | ((eq action t) 'all-completions) |
| 554 | (t 'test-completion)) |
| 555 | string table pred)))) |
| 556 | |
| 557 | (defun completion-table-dynamic (fun) |
| 558 | "Use function FUN as a dynamic completion table. |
| 559 | FUN is called with one argument, the string for which completion is required, |
| 560 | and it should return an alist containing all the intended possible completions. |
| 561 | This alist may be a full list of possible completions so that FUN can ignore |
| 562 | the value of its argument. If completion is performed in the minibuffer, |
| 563 | FUN will be called in the buffer from which the minibuffer was entered. |
| 564 | |
| 565 | The result of the `completion-table-dynamic' form is a function |
| 566 | that can be used as the COLLECTION argument to `try-completion' and |
| 567 | `all-completions'. See Info node `(elisp)Programmed Completion'. |
| 568 | |
| 569 | See also the related function `completion-table-with-cache'." |
| 570 | (lambda (string pred action) |
| 571 | (if (or (eq (car-safe action) 'boundaries) (eq action 'metadata)) |
| 572 | ;; `fun' is not supposed to return another function but a plain old |
| 573 | ;; completion table, whose boundaries are always trivial. |
| 574 | nil |
| 575 | (with-current-buffer (let ((win (minibuffer-selected-window))) |
| 576 | (if (window-live-p win) (window-buffer win) |
| 577 | (current-buffer))) |
| 578 | (complete-with-action action (funcall fun string) string pred))))) |
| 579 | |
| 580 | (defun completion-table-with-cache (fun &optional ignore-case) |
| 581 | "Create dynamic completion table from function FUN, with cache. |
| 582 | This is a wrapper for `completion-table-dynamic' that saves the last |
| 583 | argument-result pair from FUN, so that several lookups with the |
| 584 | same argument (or with an argument that starts with the first one) |
| 585 | only need to call FUN once. This can be useful when FUN performs a |
| 586 | relatively slow operation, such as calling an external process. |
| 587 | |
| 588 | When IGNORE-CASE is non-nil, FUN is expected to be case-insensitive." |
| 589 | ;; See eg bug#11906. |
| 590 | (let* (last-arg last-result |
| 591 | (new-fun |
| 592 | (lambda (arg) |
| 593 | (if (and last-arg (string-prefix-p last-arg arg ignore-case)) |
| 594 | last-result |
| 595 | (prog1 |
| 596 | (setq last-result (funcall fun arg)) |
| 597 | (setq last-arg arg)))))) |
| 598 | (completion-table-dynamic new-fun))) |
| 599 | |
| 600 | (defmacro lazy-completion-table (var fun) |
| 601 | "Initialize variable VAR as a lazy completion table. |
| 602 | If the completion table VAR is used for the first time (e.g., by passing VAR |
| 603 | as an argument to `try-completion'), the function FUN is called with no |
| 604 | arguments. FUN must return the completion table that will be stored in VAR. |
| 605 | If completion is requested in the minibuffer, FUN will be called in the buffer |
| 606 | from which the minibuffer was entered. The return value of |
| 607 | `lazy-completion-table' must be used to initialize the value of VAR. |
| 608 | |
| 609 | You should give VAR a non-nil `risky-local-variable' property." |
| 610 | (declare (debug (symbolp lambda-expr))) |
| 611 | (let ((str (make-symbol "string"))) |
| 612 | `(completion-table-dynamic |
| 613 | (lambda (,str) |
| 614 | (when (functionp ,var) |
| 615 | (setq ,var (funcall #',fun))) |
| 616 | ,var)))) |
| 617 | |
| 618 | (defun completion-table-case-fold (table &optional dont-fold) |
| 619 | "Return new completion TABLE that is case insensitive. |
| 620 | If DONT-FOLD is non-nil, return a completion table that is |
| 621 | case sensitive instead." |
| 622 | (lambda (string pred action) |
| 623 | (let ((completion-ignore-case (not dont-fold))) |
| 624 | (complete-with-action action table string pred)))) |
| 625 | |
| 626 | (defun completion-table-subvert (table s1 s2) |
| 627 | "Return a completion table from TABLE with S1 replaced by S2. |
| 628 | The result is a completion table which completes strings of the |
| 629 | form (concat S1 S) in the same way as TABLE completes strings of |
| 630 | the form (concat S2 S)." |
| 631 | (lambda (string pred action) |
| 632 | (let* ((str (if (string-prefix-p s1 string completion-ignore-case) |
| 633 | (concat s2 (substring string (length s1))))) |
| 634 | (res (if str (complete-with-action action table str pred)))) |
| 635 | (when res |
| 636 | (cond |
| 637 | ((eq (car-safe action) 'boundaries) |
| 638 | (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0))) |
| 639 | `(boundaries |
| 640 | ,(max (length s1) |
| 641 | (+ beg (- (length s1) (length s2)))) |
| 642 | . ,(and (eq (car-safe res) 'boundaries) (cddr res))))) |
| 643 | ((stringp res) |
| 644 | (if (string-prefix-p s2 string completion-ignore-case) |
| 645 | (concat s1 (substring res (length s2))))) |
| 646 | ((eq action t) |
| 647 | (let ((bounds (completion-boundaries str table pred ""))) |
| 648 | (if (>= (car bounds) (length s2)) |
| 649 | res |
| 650 | (let ((re (concat "\\`" |
| 651 | (regexp-quote (substring s2 (car bounds)))))) |
| 652 | (delq nil |
| 653 | (mapcar (lambda (c) |
| 654 | (if (string-match re c) |
| 655 | (substring c (match-end 0)))) |
| 656 | res)))))) |
| 657 | ;; E.g. action=nil and it's the only completion. |
| 658 | (res)))))) |
| 659 | |
| 660 | (defun completion-table-with-context (prefix table string pred action) |
| 661 | ;; TODO: add `suffix' maybe? |
| 662 | (let ((pred |
| 663 | (if (not (functionp pred)) |
| 664 | ;; Notice that `pred' may not be a function in some abusive cases. |
| 665 | pred |
| 666 | ;; Predicates are called differently depending on the nature of |
| 667 | ;; the completion table :-( |
| 668 | (cond |
| 669 | ((vectorp table) ;Obarray. |
| 670 | (lambda (sym) (funcall pred (concat prefix (symbol-name sym))))) |
| 671 | ((hash-table-p table) |
| 672 | (lambda (s _v) (funcall pred (concat prefix s)))) |
| 673 | ((functionp table) |
| 674 | (lambda (s) (funcall pred (concat prefix s)))) |
| 675 | (t ;Lists and alists. |
| 676 | (lambda (s) |
| 677 | (funcall pred (concat prefix (if (consp s) (car s) s))))))))) |
| 678 | (if (eq (car-safe action) 'boundaries) |
| 679 | (let* ((len (length prefix)) |
| 680 | (bound (completion-boundaries string table pred (cdr action)))) |
| 681 | `(boundaries ,(+ (car bound) len) . ,(cdr bound))) |
| 682 | (let ((comp (complete-with-action action table string pred))) |
| 683 | (cond |
| 684 | ;; In case of try-completion, add the prefix. |
| 685 | ((stringp comp) (concat prefix comp)) |
| 686 | (t comp)))))) |
| 687 | |
| 688 | (defun completion-table-with-terminator (terminator table string pred action) |
| 689 | "Construct a completion table like TABLE but with an extra TERMINATOR. |
| 690 | This is meant to be called in a curried way by first passing TERMINATOR |
| 691 | and TABLE only (via `apply-partially'). |
| 692 | TABLE is a completion table, and TERMINATOR is a string appended to TABLE's |
| 693 | completion if it is complete. TERMINATOR is also used to determine the |
| 694 | completion suffix's boundary. |
| 695 | TERMINATOR can also be a cons cell (TERMINATOR . TERMINATOR-REGEXP) |
| 696 | in which case TERMINATOR-REGEXP is a regular expression whose submatch |
| 697 | number 1 should match TERMINATOR. This is used when there is a need to |
| 698 | distinguish occurrences of the TERMINATOR strings which are really terminators |
| 699 | from others (e.g. escaped). In this form, the car of TERMINATOR can also be, |
| 700 | instead of a string, a function that takes the completion and returns the |
| 701 | \"terminated\" string." |
| 702 | ;; FIXME: This implementation is not right since it only adds the terminator |
| 703 | ;; in try-completion, so any completion-style that builds the completion via |
| 704 | ;; all-completions won't get the terminator, and selecting an entry in |
| 705 | ;; *Completions* won't get the terminator added either. |
| 706 | (cond |
| 707 | ((eq (car-safe action) 'boundaries) |
| 708 | (let* ((suffix (cdr action)) |
| 709 | (bounds (completion-boundaries string table pred suffix)) |
| 710 | (terminator-regexp (if (consp terminator) |
| 711 | (cdr terminator) (regexp-quote terminator))) |
| 712 | (max (and terminator-regexp |
| 713 | (string-match terminator-regexp suffix)))) |
| 714 | `(boundaries ,(car bounds) |
| 715 | . ,(min (cdr bounds) (or max (length suffix)))))) |
| 716 | ((eq action nil) |
| 717 | (let ((comp (try-completion string table pred))) |
| 718 | (if (consp terminator) (setq terminator (car terminator))) |
| 719 | (if (eq comp t) |
| 720 | (if (functionp terminator) |
| 721 | (funcall terminator string) |
| 722 | (concat string terminator)) |
| 723 | (if (and (stringp comp) (not (zerop (length comp))) |
| 724 | ;; Try to avoid the second call to try-completion, since |
| 725 | ;; it may be very inefficient (because `comp' made us |
| 726 | ;; jump to a new boundary, so we complete in that |
| 727 | ;; boundary with an empty start string). |
| 728 | (let ((newbounds (completion-boundaries comp table pred ""))) |
| 729 | (< (car newbounds) (length comp))) |
| 730 | (eq (try-completion comp table pred) t)) |
| 731 | (if (functionp terminator) |
| 732 | (funcall terminator comp) |
| 733 | (concat comp terminator)) |
| 734 | comp)))) |
| 735 | ;; completion-table-with-terminator is always used for |
| 736 | ;; "sub-completions" so it's only called if the terminator is missing, |
| 737 | ;; in which case `test-completion' should return nil. |
| 738 | ((eq action 'lambda) nil) |
| 739 | (t |
| 740 | ;; FIXME: We generally want the `try' and `all' behaviors to be |
| 741 | ;; consistent so pcm can merge the `all' output to get the `try' output, |
| 742 | ;; but that sometimes clashes with the need for `all' output to look |
| 743 | ;; good in *Completions*. |
| 744 | ;; (mapcar (lambda (s) (concat s terminator)) |
| 745 | ;; (all-completions string table pred)))) |
| 746 | (complete-with-action action table string pred)))) |
| 747 | |
| 748 | (defun completion-table-with-predicate (table pred1 strict string pred2 action) |
| 749 | "Make a completion table equivalent to TABLE but filtered through PRED1. |
| 750 | PRED1 is a function of one argument which returns non-nil if and only if the |
| 751 | argument is an element of TABLE which should be considered for completion. |
| 752 | STRING, PRED2, and ACTION are the usual arguments to completion tables, |
| 753 | as described in `try-completion', `all-completions', and `test-completion'. |
| 754 | If STRICT is t, the predicate always applies; if nil it only applies if |
| 755 | it does not reduce the set of possible completions to nothing. |
| 756 | Note: TABLE needs to be a proper completion table which obeys predicates." |
| 757 | (cond |
| 758 | ((and (not strict) (eq action 'lambda)) |
| 759 | ;; Ignore pred1 since it doesn't really have to apply anyway. |
| 760 | (test-completion string table pred2)) |
| 761 | (t |
| 762 | (or (complete-with-action action table string |
| 763 | (if (not (and pred1 pred2)) |
| 764 | (or pred1 pred2) |
| 765 | (lambda (x) |
| 766 | ;; Call `pred1' first, so that `pred2' |
| 767 | ;; really can't tell that `x' is in table. |
| 768 | (and (funcall pred1 x) (funcall pred2 x))))) |
| 769 | ;; If completion failed and we're not applying pred1 strictly, try |
| 770 | ;; again without pred1. |
| 771 | (and (not strict) pred1 pred2 |
| 772 | (complete-with-action action table string pred2)))))) |
| 773 | |
| 774 | (defun completion-table-in-turn (&rest tables) |
| 775 | "Create a completion table that tries each table in TABLES in turn." |
| 776 | ;; FIXME: the boundaries may come from TABLE1 even when the completion list |
| 777 | ;; is returned by TABLE2 (because TABLE1 returned an empty list). |
| 778 | ;; Same potential problem if any of the tables use quoting. |
| 779 | (lambda (string pred action) |
| 780 | (completion--some (lambda (table) |
| 781 | (complete-with-action action table string pred)) |
| 782 | tables))) |
| 783 | |
| 784 | (defun completion-table-merge (&rest tables) |
| 785 | "Create a completion table that collects completions from all TABLES." |
| 786 | ;; FIXME: same caveats as in `completion-table-in-turn'. |
| 787 | (lambda (string pred action) |
| 788 | (cond |
| 789 | ((null action) |
| 790 | (let ((retvals (mapcar (lambda (table) |
| 791 | (try-completion string table pred)) |
| 792 | tables))) |
| 793 | (if (member string retvals) |
| 794 | string |
| 795 | (try-completion string |
| 796 | (mapcar (lambda (value) |
| 797 | (if (eq value t) string value)) |
| 798 | (delq nil retvals)) |
| 799 | pred)))) |
| 800 | ((eq action t) |
| 801 | (apply #'append (mapcar (lambda (table) |
| 802 | (all-completions string table pred)) |
| 803 | tables))) |
| 804 | (t |
| 805 | (completion--some (lambda (table) |
| 806 | (complete-with-action action table string pred)) |
| 807 | tables))))) |
| 808 | |
| 809 | (defun completion-table-with-quoting (table unquote requote) |
| 810 | ;; A difficult part of completion-with-quoting is to map positions in the |
| 811 | ;; quoted string to equivalent positions in the unquoted string and |
| 812 | ;; vice-versa. There is no efficient and reliable algorithm that works for |
| 813 | ;; arbitrary quote and unquote functions. |
| 814 | ;; So to map from quoted positions to unquoted positions, we simply assume |
| 815 | ;; that `concat' and `unquote' commute (which tends to be the case). |
| 816 | ;; And we ask `requote' to do the work of mapping from unquoted positions |
| 817 | ;; back to quoted positions. |
| 818 | ;; FIXME: For some forms of "quoting" such as the truncation behavior of |
| 819 | ;; substitute-in-file-name, it would be desirable not to requote completely. |
| 820 | "Return a new completion table operating on quoted text. |
| 821 | TABLE operates on the unquoted text. |
| 822 | UNQUOTE is a function that takes a string and returns a new unquoted string. |
| 823 | REQUOTE is a function of 2 args (UPOS QSTR) where |
| 824 | QSTR is a string entered by the user (and hence indicating |
| 825 | the user's preferred form of quoting); and |
| 826 | UPOS is a position within the unquoted form of QSTR. |
| 827 | REQUOTE should return a pair (QPOS . QFUN) such that QPOS is the |
| 828 | position corresponding to UPOS but in QSTR, and QFUN is a function |
| 829 | of one argument (a string) which returns that argument appropriately quoted |
| 830 | for use at QPOS." |
| 831 | ;; FIXME: One problem with the current setup is that `qfun' doesn't know if |
| 832 | ;; its argument is "the end of the completion", so if the quoting used double |
| 833 | ;; quotes (for example), we end up completing "fo" to "foobar and throwing |
| 834 | ;; away the closing double quote. |
| 835 | (lambda (string pred action) |
| 836 | (cond |
| 837 | ((eq action 'metadata) |
| 838 | (append (completion-metadata string table pred) |
| 839 | '((completion--unquote-requote . t)))) |
| 840 | |
| 841 | ((eq action 'lambda) ;;test-completion |
| 842 | (let ((ustring (funcall unquote string))) |
| 843 | (test-completion ustring table pred))) |
| 844 | |
| 845 | ((eq (car-safe action) 'boundaries) |
| 846 | (let* ((ustring (funcall unquote string)) |
| 847 | (qsuffix (cdr action)) |
| 848 | (ufull (if (zerop (length qsuffix)) ustring |
| 849 | (funcall unquote (concat string qsuffix)))) |
| 850 | (_ (cl-assert (string-prefix-p ustring ufull))) |
| 851 | (usuffix (substring ufull (length ustring))) |
| 852 | (boundaries (completion-boundaries ustring table pred usuffix)) |
| 853 | (qlboundary (car (funcall requote (car boundaries) string))) |
| 854 | (qrboundary (if (zerop (cdr boundaries)) 0 ;Common case. |
| 855 | (let* ((urfullboundary |
| 856 | (+ (cdr boundaries) (length ustring)))) |
| 857 | (- (car (funcall requote urfullboundary |
| 858 | (concat string qsuffix))) |
| 859 | (length string)))))) |
| 860 | `(boundaries ,qlboundary . ,qrboundary))) |
| 861 | |
| 862 | ;; In "normal" use a c-t-with-quoting completion table should never be |
| 863 | ;; called with action in (t nil) because `completion--unquote' should have |
| 864 | ;; been called before and would have returned a different completion table |
| 865 | ;; to apply to the unquoted text. But there's still a lot of code around |
| 866 | ;; that likes to use all/try-completions directly, so we do our best to |
| 867 | ;; handle those calls as well as we can. |
| 868 | |
| 869 | ((eq action nil) ;;try-completion |
| 870 | (let* ((ustring (funcall unquote string)) |
| 871 | (completion (try-completion ustring table pred))) |
| 872 | ;; Most forms of quoting allow several ways to quote the same string. |
| 873 | ;; So here we could simply requote `completion' in a kind of |
| 874 | ;; "canonical" quoted form without paying attention to the way |
| 875 | ;; `string' was quoted. But since we have to solve the more complex |
| 876 | ;; problems of "pay attention to the original quoting" for |
| 877 | ;; all-completions, we may as well use it here, since it provides |
| 878 | ;; a nicer behavior. |
| 879 | (if (not (stringp completion)) completion |
| 880 | (car (completion--twq-try |
| 881 | string ustring completion 0 unquote requote))))) |
| 882 | |
| 883 | ((eq action t) ;;all-completions |
| 884 | ;; When all-completions is used for completion-try/all-completions |
| 885 | ;; (e.g. for `pcm' style), we can't do the job properly here because |
| 886 | ;; the caller will match our output against some pattern derived from |
| 887 | ;; the user's (quoted) input, and we don't have access to that |
| 888 | ;; pattern, so we can't know how to requote our output so that it |
| 889 | ;; matches the quoting used in the pattern. It is to fix this |
| 890 | ;; fundamental problem that we have to introduce the new |
| 891 | ;; unquote-requote method so that completion-try/all-completions can |
| 892 | ;; pass the unquoted string to the style functions. |
| 893 | (pcase-let* |
| 894 | ((ustring (funcall unquote string)) |
| 895 | (completions (all-completions ustring table pred)) |
| 896 | (boundary (car (completion-boundaries ustring table pred ""))) |
| 897 | (completions |
| 898 | (completion--twq-all |
| 899 | string ustring completions boundary unquote requote)) |
| 900 | (last (last completions))) |
| 901 | (when (consp last) (setcdr last nil)) |
| 902 | completions)) |
| 903 | |
| 904 | ((eq action 'completion--unquote) |
| 905 | ;; PRED is really a POINT in STRING. |
| 906 | ;; We should return a new set (STRING TABLE POINT REQUOTE) |
| 907 | ;; where STRING is a new (unquoted) STRING to match against the new TABLE |
| 908 | ;; using a new POINT inside it, and REQUOTE is a requoting function which |
| 909 | ;; should reverse the unquoting, (i.e. it receives the completion result |
| 910 | ;; of using the new TABLE and should turn it into the corresponding |
| 911 | ;; quoted result). |
| 912 | (let* ((qpos pred) |
| 913 | (ustring (funcall unquote string)) |
| 914 | (uprefix (funcall unquote (substring string 0 qpos))) |
| 915 | ;; FIXME: we really should pass `qpos' to `unquote' and have that |
| 916 | ;; function give us the corresponding `uqpos'. But for now we |
| 917 | ;; presume (more or less) that `concat' and `unquote' commute. |
| 918 | (uqpos (if (string-prefix-p uprefix ustring) |
| 919 | ;; Yay!! They do seem to commute! |
| 920 | (length uprefix) |
| 921 | ;; They don't commute this time! :-( |
| 922 | ;; Maybe qpos is in some text that disappears in the |
| 923 | ;; ustring (bug#17239). Let's try a second chance guess. |
| 924 | (let ((usuffix (funcall unquote (substring string qpos)))) |
| 925 | (if (string-suffix-p usuffix ustring) |
| 926 | ;; Yay!! They still "commute" in a sense! |
| 927 | (- (length ustring) (length usuffix)) |
| 928 | ;; Still no luck! Let's just choose *some* position |
| 929 | ;; within ustring. |
| 930 | (/ (+ (min (length uprefix) (length ustring)) |
| 931 | (max (- (length ustring) (length usuffix)) 0)) |
| 932 | 2)))))) |
| 933 | (list ustring table uqpos |
| 934 | (lambda (unquoted-result op) |
| 935 | (pcase op |
| 936 | (1 ;;try |
| 937 | (if (not (stringp (car-safe unquoted-result))) |
| 938 | unquoted-result |
| 939 | (completion--twq-try |
| 940 | string ustring |
| 941 | (car unquoted-result) (cdr unquoted-result) |
| 942 | unquote requote))) |
| 943 | (2 ;;all |
| 944 | (let* ((last (last unquoted-result)) |
| 945 | (base (or (cdr last) 0))) |
| 946 | (when last |
| 947 | (setcdr last nil) |
| 948 | (completion--twq-all string ustring |
| 949 | unquoted-result base |
| 950 | unquote requote)))))))))))) |
| 951 | |
| 952 | (defun completion--twq-try (string ustring completion point |
| 953 | unquote requote) |
| 954 | ;; Basically two cases: either the new result is |
| 955 | ;; - commonprefix1 <point> morecommonprefix <qpos> suffix |
| 956 | ;; - commonprefix <qpos> newprefix <point> suffix |
| 957 | (pcase-let* |
| 958 | ((prefix (fill-common-string-prefix ustring completion)) |
| 959 | (suffix (substring completion (max point (length prefix)))) |
| 960 | (`(,qpos . ,qfun) (funcall requote (length prefix) string)) |
| 961 | (qstr1 (if (> point (length prefix)) |
| 962 | (funcall qfun (substring completion (length prefix) point)))) |
| 963 | (qsuffix (funcall qfun suffix)) |
| 964 | (qstring (concat (substring string 0 qpos) qstr1 qsuffix)) |
| 965 | (qpoint |
| 966 | (cond |
| 967 | ((zerop point) 0) |
| 968 | ((> point (length prefix)) (+ qpos (length qstr1))) |
| 969 | (t (car (funcall requote point string)))))) |
| 970 | ;; Make sure `requote' worked. |
| 971 | (if (equal (funcall unquote qstring) completion) |
| 972 | (cons qstring qpoint) |
| 973 | ;; If requote failed (e.g. because sifn-requote did not handle |
| 974 | ;; Tramp's "/foo:/bar//baz -> /foo:/baz" truncation), then at least |
| 975 | ;; try requote properly. |
| 976 | (let ((qstr (funcall qfun completion))) |
| 977 | (cons qstr (length qstr)))))) |
| 978 | |
| 979 | (defun completion--string-equal-p (s1 s2) |
| 980 | (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case))) |
| 981 | |
| 982 | (defun completion--twq-all (string ustring completions boundary |
| 983 | _unquote requote) |
| 984 | (when completions |
| 985 | (pcase-let* |
| 986 | ((prefix |
| 987 | (let ((completion-regexp-list nil)) |
| 988 | (try-completion "" (cons (substring ustring boundary) |
| 989 | completions)))) |
| 990 | (`(,qfullpos . ,qfun) |
| 991 | (funcall requote (+ boundary (length prefix)) string)) |
| 992 | (qfullprefix (substring string 0 qfullpos)) |
| 993 | ;; FIXME: This assertion can be wrong, e.g. in Cygwin, where |
| 994 | ;; (unquote "c:\bin") => "/usr/bin" but (unquote "c:\") => "/". |
| 995 | ;;(cl-assert (completion--string-equal-p |
| 996 | ;; (funcall unquote qfullprefix) |
| 997 | ;; (concat (substring ustring 0 boundary) prefix)) |
| 998 | ;; t)) |
| 999 | (qboundary (car (funcall requote boundary string))) |
| 1000 | (_ (cl-assert (<= qboundary qfullpos))) |
| 1001 | ;; FIXME: this split/quote/concat business messes up the carefully |
| 1002 | ;; placed completions-common-part and completions-first-difference |
| 1003 | ;; faces. We could try within the mapcar loop to search for the |
| 1004 | ;; boundaries of those faces, pass them to `requote' to find their |
| 1005 | ;; equivalent positions in the quoted output and re-add the faces: |
| 1006 | ;; this might actually lead to correct results but would be |
| 1007 | ;; pretty expensive. |
| 1008 | ;; The better solution is to not quote the *Completions* display, |
| 1009 | ;; which nicely circumvents the problem. The solution I used here |
| 1010 | ;; instead is to hope that `qfun' preserves the text-properties and |
| 1011 | ;; presume that the `first-difference' is not within the `prefix'; |
| 1012 | ;; this presumption is not always true, but at least in practice it is |
| 1013 | ;; true in most cases. |
| 1014 | (qprefix (propertize (substring qfullprefix qboundary) |
| 1015 | 'face 'completions-common-part))) |
| 1016 | |
| 1017 | ;; Here we choose to quote all elements returned, but a better option |
| 1018 | ;; would be to return unquoted elements together with a function to |
| 1019 | ;; requote them, so that *Completions* can show nicer unquoted values |
| 1020 | ;; which only get quoted when needed by choose-completion. |
| 1021 | (nconc |
| 1022 | (mapcar (lambda (completion) |
| 1023 | (cl-assert (string-prefix-p prefix completion 'ignore-case) t) |
| 1024 | (let* ((new (substring completion (length prefix))) |
| 1025 | (qnew (funcall qfun new)) |
| 1026 | (qprefix |
| 1027 | (if (not completion-ignore-case) |
| 1028 | qprefix |
| 1029 | ;; Make qprefix inherit the case from `completion'. |
| 1030 | (let* ((rest (substring completion |
| 1031 | 0 (length prefix))) |
| 1032 | (qrest (funcall qfun rest))) |
| 1033 | (if (completion--string-equal-p qprefix qrest) |
| 1034 | (propertize qrest 'face |
| 1035 | 'completions-common-part) |
| 1036 | qprefix)))) |
| 1037 | (qcompletion (concat qprefix qnew))) |
| 1038 | ;; FIXME: Similarly here, Cygwin's mapping trips this |
| 1039 | ;; assertion. |
| 1040 | ;;(cl-assert |
| 1041 | ;; (completion--string-equal-p |
| 1042 | ;; (funcall unquote |
| 1043 | ;; (concat (substring string 0 qboundary) |
| 1044 | ;; qcompletion)) |
| 1045 | ;; (concat (substring ustring 0 boundary) |
| 1046 | ;; completion)) |
| 1047 | ;; t) |
| 1048 | qcompletion)) |
| 1049 | completions) |
| 1050 | qboundary)))) |
| 1051 | |
| 1052 | ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) |
| 1053 | ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) |
| 1054 | (define-obsolete-function-alias |
| 1055 | 'complete-in-turn 'completion-table-in-turn "23.1") |
| 1056 | (define-obsolete-function-alias |
| 1057 | 'dynamic-completion-table 'completion-table-dynamic "23.1") |
| 1058 | |
| 1059 | ;;; Minibuffer completion |
| 1060 | |
| 1061 | (defgroup minibuffer nil |
| 1062 | "Controlling the behavior of the minibuffer." |
| 1063 | :link '(custom-manual "(emacs)Minibuffer") |
| 1064 | :group 'environment) |
| 1065 | |
| 1066 | (defun minibuffer-message (message &rest args) |
| 1067 | "Temporarily display MESSAGE at the end of the minibuffer. |
| 1068 | The text is displayed for `minibuffer-message-timeout' seconds, |
| 1069 | or until the next input event arrives, whichever comes first. |
| 1070 | Enclose MESSAGE in [...] if this is not yet the case. |
| 1071 | If ARGS are provided, then pass MESSAGE through `format'." |
| 1072 | (if (not (minibufferp (current-buffer))) |
| 1073 | (progn |
| 1074 | (if args |
| 1075 | (apply 'message message args) |
| 1076 | (message "%s" message)) |
| 1077 | (prog1 (sit-for (or minibuffer-message-timeout 1000000)) |
| 1078 | (message nil))) |
| 1079 | ;; Clear out any old echo-area message to make way for our new thing. |
| 1080 | (message nil) |
| 1081 | (setq message (if (and (null args) |
| 1082 | (string-match-p "\\` *\\[.+\\]\\'" message)) |
| 1083 | ;; Make sure we can put-text-property. |
| 1084 | (copy-sequence message) |
| 1085 | (concat " [" message "]"))) |
| 1086 | (when args (setq message (apply 'format message args))) |
| 1087 | (let ((ol (make-overlay (point-max) (point-max) nil t t)) |
| 1088 | ;; A quit during sit-for normally only interrupts the sit-for, |
| 1089 | ;; but since minibuffer-message is used at the end of a command, |
| 1090 | ;; at a time when the command has virtually finished already, a C-g |
| 1091 | ;; should really cause an abort-recursive-edit instead (i.e. as if |
| 1092 | ;; the C-g had been typed at top-level). Binding inhibit-quit here |
| 1093 | ;; is an attempt to get that behavior. |
| 1094 | (inhibit-quit t)) |
| 1095 | (unwind-protect |
| 1096 | (progn |
| 1097 | (unless (zerop (length message)) |
| 1098 | ;; The current C cursor code doesn't know to use the overlay's |
| 1099 | ;; marker's stickiness to figure out whether to place the cursor |
| 1100 | ;; before or after the string, so let's spoon-feed it the pos. |
| 1101 | (put-text-property 0 1 'cursor t message)) |
| 1102 | (overlay-put ol 'after-string message) |
| 1103 | (sit-for (or minibuffer-message-timeout 1000000))) |
| 1104 | (delete-overlay ol))))) |
| 1105 | |
| 1106 | (defun minibuffer-completion-contents () |
| 1107 | "Return the user input in a minibuffer before point as a string. |
| 1108 | In Emacs-22, that was what completion commands operated on." |
| 1109 | (declare (obsolete nil "24.4")) |
| 1110 | (buffer-substring (minibuffer-prompt-end) (point))) |
| 1111 | |
| 1112 | (defun delete-minibuffer-contents () |
| 1113 | "Delete all user input in a minibuffer. |
| 1114 | If the current buffer is not a minibuffer, erase its entire contents." |
| 1115 | (interactive) |
| 1116 | ;; We used to do `delete-field' here, but when file name shadowing |
| 1117 | ;; is on, the field doesn't cover the entire minibuffer contents. |
| 1118 | (delete-region (minibuffer-prompt-end) (point-max))) |
| 1119 | |
| 1120 | (defvar completion-show-inline-help t |
| 1121 | "If non-nil, print helpful inline messages during completion.") |
| 1122 | |
| 1123 | (defcustom completion-auto-help t |
| 1124 | "Non-nil means automatically provide help for invalid completion input. |
| 1125 | If the value is t the *Completion* buffer is displayed whenever completion |
| 1126 | is requested but cannot be done. |
| 1127 | If the value is `lazy', the *Completions* buffer is only displayed after |
| 1128 | the second failed attempt to complete." |
| 1129 | :type '(choice (const nil) (const t) (const lazy))) |
| 1130 | |
| 1131 | (defconst completion-styles-alist |
| 1132 | '((emacs21 |
| 1133 | completion-emacs21-try-completion completion-emacs21-all-completions |
| 1134 | "Simple prefix-based completion. |
| 1135 | I.e. when completing \"foo_bar\" (where _ is the position of point), |
| 1136 | it will consider all completions candidates matching the glob |
| 1137 | pattern \"foobar*\".") |
| 1138 | (emacs22 |
| 1139 | completion-emacs22-try-completion completion-emacs22-all-completions |
| 1140 | "Prefix completion that only operates on the text before point. |
| 1141 | I.e. when completing \"foo_bar\" (where _ is the position of point), |
| 1142 | it will consider all completions candidates matching the glob |
| 1143 | pattern \"foo*\" and will add back \"bar\" to the end of it.") |
| 1144 | (basic |
| 1145 | completion-basic-try-completion completion-basic-all-completions |
| 1146 | "Completion of the prefix before point and the suffix after point. |
| 1147 | I.e. when completing \"foo_bar\" (where _ is the position of point), |
| 1148 | it will consider all completions candidates matching the glob |
| 1149 | pattern \"foo*bar*\".") |
| 1150 | (partial-completion |
| 1151 | completion-pcm-try-completion completion-pcm-all-completions |
| 1152 | "Completion of multiple words, each one taken as a prefix. |
| 1153 | I.e. when completing \"l-co_h\" (where _ is the position of point), |
| 1154 | it will consider all completions candidates matching the glob |
| 1155 | pattern \"l*-co*h*\". |
| 1156 | Furthermore, for completions that are done step by step in subfields, |
| 1157 | the method is applied to all the preceding fields that do not yet match. |
| 1158 | E.g. C-x C-f /u/mo/s TAB could complete to /usr/monnier/src. |
| 1159 | Additionally the user can use the char \"*\" as a glob pattern.") |
| 1160 | (substring |
| 1161 | completion-substring-try-completion completion-substring-all-completions |
| 1162 | "Completion of the string taken as a substring. |
| 1163 | I.e. when completing \"foo_bar\" (where _ is the position of point), |
| 1164 | it will consider all completions candidates matching the glob |
| 1165 | pattern \"*foo*bar*\".") |
| 1166 | (initials |
| 1167 | completion-initials-try-completion completion-initials-all-completions |
| 1168 | "Completion of acronyms and initialisms. |
| 1169 | E.g. can complete M-x lch to list-command-history |
| 1170 | and C-x C-f ~/sew to ~/src/emacs/work.")) |
| 1171 | "List of available completion styles. |
| 1172 | Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS DOC): |
| 1173 | where NAME is the name that should be used in `completion-styles', |
| 1174 | TRY-COMPLETION is the function that does the completion (it should |
| 1175 | follow the same calling convention as `completion-try-completion'), |
| 1176 | ALL-COMPLETIONS is the function that lists the completions (it should |
| 1177 | follow the calling convention of `completion-all-completions'), |
| 1178 | and DOC describes the way this style of completion works.") |
| 1179 | |
| 1180 | (defconst completion--styles-type |
| 1181 | `(repeat :tag "insert a new menu to add more styles" |
| 1182 | (choice ,@(mapcar (lambda (x) (list 'const (car x))) |
| 1183 | completion-styles-alist)))) |
| 1184 | (defconst completion--cycling-threshold-type |
| 1185 | '(choice (const :tag "No cycling" nil) |
| 1186 | (const :tag "Always cycle" t) |
| 1187 | (integer :tag "Threshold"))) |
| 1188 | |
| 1189 | (defcustom completion-styles |
| 1190 | ;; First, use `basic' because prefix completion has been the standard |
| 1191 | ;; for "ever" and works well in most cases, so using it first |
| 1192 | ;; ensures that we obey previous behavior in most cases. |
| 1193 | '(basic |
| 1194 | ;; Then use `partial-completion' because it has proven to |
| 1195 | ;; be a very convenient extension. |
| 1196 | partial-completion |
| 1197 | ;; Finally use `emacs22' so as to maintain (in many/most cases) |
| 1198 | ;; the previous behavior that when completing "foobar" with point |
| 1199 | ;; between "foo" and "bar" the completion try to complete "foo" |
| 1200 | ;; and simply add "bar" to the end of the result. |
| 1201 | emacs22) |
| 1202 | "List of completion styles to use. |
| 1203 | The available styles are listed in `completion-styles-alist'. |
| 1204 | |
| 1205 | Note that `completion-category-overrides' may override these |
| 1206 | styles for specific categories, such as files, buffers, etc." |
| 1207 | :type completion--styles-type |
| 1208 | :version "23.1") |
| 1209 | |
| 1210 | (defcustom completion-category-overrides |
| 1211 | '((buffer (styles . (basic substring)))) |
| 1212 | "List of `completion-styles' overrides for specific categories. |
| 1213 | Each override has the shape (CATEGORY . ALIST) where ALIST is |
| 1214 | an association list that can specify properties such as: |
| 1215 | - `styles': the list of `completion-styles' to use for that category. |
| 1216 | - `cycle': the `completion-cycle-threshold' to use for that category. |
| 1217 | Categories are symbols such as `buffer' and `file', used when |
| 1218 | completing buffer and file names, respectively." |
| 1219 | :version "24.1" |
| 1220 | :type `(alist :key-type (choice :tag "Category" |
| 1221 | (const buffer) |
| 1222 | (const file) |
| 1223 | (const unicode-name) |
| 1224 | (const bookmark) |
| 1225 | symbol) |
| 1226 | :value-type |
| 1227 | (set :tag "Properties to override" |
| 1228 | (cons :tag "Completion Styles" |
| 1229 | (const :tag "Select a style from the menu;" styles) |
| 1230 | ,completion--styles-type) |
| 1231 | (cons :tag "Completion Cycling" |
| 1232 | (const :tag "Select one value from the menu." cycle) |
| 1233 | ,completion--cycling-threshold-type)))) |
| 1234 | |
| 1235 | (defun completion--styles (metadata) |
| 1236 | (let* ((cat (completion-metadata-get metadata 'category)) |
| 1237 | (over (assq 'styles (cdr (assq cat completion-category-overrides))))) |
| 1238 | (if over |
| 1239 | (delete-dups (append (cdr over) (copy-sequence completion-styles))) |
| 1240 | completion-styles))) |
| 1241 | |
| 1242 | (defun completion--nth-completion (n string table pred point metadata) |
| 1243 | "Call the Nth method of completion styles." |
| 1244 | (unless metadata |
| 1245 | (setq metadata |
| 1246 | (completion-metadata (substring string 0 point) table pred))) |
| 1247 | ;; We provide special support for quoting/unquoting here because it cannot |
| 1248 | ;; reliably be done within the normal completion-table routines: Completion |
| 1249 | ;; styles such as `substring' or `partial-completion' need to match the |
| 1250 | ;; output of all-completions with the user's input, and since most/all |
| 1251 | ;; quoting mechanisms allow several equivalent quoted forms, the |
| 1252 | ;; completion-style can't do this matching (e.g. `substring' doesn't know |
| 1253 | ;; that "\a\b\e" is a valid (quoted) substring of "label"). |
| 1254 | ;; The quote/unquote function needs to come from the completion table (rather |
| 1255 | ;; than from completion-extra-properties) because it may apply only to some |
| 1256 | ;; part of the string (e.g. substitute-in-file-name). |
| 1257 | (let ((requote |
| 1258 | (when (completion-metadata-get metadata 'completion--unquote-requote) |
| 1259 | (cl-assert (functionp table)) |
| 1260 | (let ((new (funcall table string point 'completion--unquote))) |
| 1261 | (setq string (pop new)) |
| 1262 | (setq table (pop new)) |
| 1263 | (setq point (pop new)) |
| 1264 | (cl-assert (<= point (length string))) |
| 1265 | (pop new)))) |
| 1266 | (result |
| 1267 | (completion--some (lambda (style) |
| 1268 | (funcall (nth n (assq style |
| 1269 | completion-styles-alist)) |
| 1270 | string table pred point)) |
| 1271 | (completion--styles metadata)))) |
| 1272 | (if requote |
| 1273 | (funcall requote result n) |
| 1274 | result))) |
| 1275 | |
| 1276 | (defun completion-try-completion (string table pred point &optional metadata) |
| 1277 | "Try to complete STRING using completion table TABLE. |
| 1278 | Only the elements of table that satisfy predicate PRED are considered. |
| 1279 | POINT is the position of point within STRING. |
| 1280 | The return value can be either nil to indicate that there is no completion, |
| 1281 | t to indicate that STRING is the only possible completion, |
| 1282 | or a pair (NEWSTRING . NEWPOINT) of the completed result string together with |
| 1283 | a new position for point." |
| 1284 | (completion--nth-completion 1 string table pred point metadata)) |
| 1285 | |
| 1286 | (defun completion-all-completions (string table pred point &optional metadata) |
| 1287 | "List the possible completions of STRING in completion table TABLE. |
| 1288 | Only the elements of table that satisfy predicate PRED are considered. |
| 1289 | POINT is the position of point within STRING. |
| 1290 | The return value is a list of completions and may contain the base-size |
| 1291 | in the last `cdr'." |
| 1292 | ;; FIXME: We need to additionally return the info needed for the |
| 1293 | ;; second part of completion-base-position. |
| 1294 | (completion--nth-completion 2 string table pred point metadata)) |
| 1295 | |
| 1296 | (defun minibuffer--bitset (modified completions exact) |
| 1297 | (logior (if modified 4 0) |
| 1298 | (if completions 2 0) |
| 1299 | (if exact 1 0))) |
| 1300 | |
| 1301 | (defun completion--replace (beg end newtext) |
| 1302 | "Replace the buffer text between BEG and END with NEWTEXT. |
| 1303 | Moves point to the end of the new text." |
| 1304 | ;; The properties on `newtext' include things like |
| 1305 | ;; completions-first-difference, which we don't want to include |
| 1306 | ;; upon insertion. |
| 1307 | (set-text-properties 0 (length newtext) nil newtext) |
| 1308 | ;; Maybe this should be in subr.el. |
| 1309 | ;; You'd think this is trivial to do, but details matter if you want |
| 1310 | ;; to keep markers "at the right place" and be robust in the face of |
| 1311 | ;; after-change-functions that may themselves modify the buffer. |
| 1312 | (let ((prefix-len 0)) |
| 1313 | ;; Don't touch markers in the shared prefix (if any). |
| 1314 | (while (and (< prefix-len (length newtext)) |
| 1315 | (< (+ beg prefix-len) end) |
| 1316 | (eq (char-after (+ beg prefix-len)) |
| 1317 | (aref newtext prefix-len))) |
| 1318 | (setq prefix-len (1+ prefix-len))) |
| 1319 | (unless (zerop prefix-len) |
| 1320 | (setq beg (+ beg prefix-len)) |
| 1321 | (setq newtext (substring newtext prefix-len)))) |
| 1322 | (let ((suffix-len 0)) |
| 1323 | ;; Don't touch markers in the shared suffix (if any). |
| 1324 | (while (and (< suffix-len (length newtext)) |
| 1325 | (< beg (- end suffix-len)) |
| 1326 | (eq (char-before (- end suffix-len)) |
| 1327 | (aref newtext (- (length newtext) suffix-len 1)))) |
| 1328 | (setq suffix-len (1+ suffix-len))) |
| 1329 | (unless (zerop suffix-len) |
| 1330 | (setq end (- end suffix-len)) |
| 1331 | (setq newtext (substring newtext 0 (- suffix-len)))) |
| 1332 | (goto-char beg) |
| 1333 | (let ((length (- end beg))) ;Read `end' before we insert the text. |
| 1334 | (insert-and-inherit newtext) |
| 1335 | (delete-region (point) (+ (point) length))) |
| 1336 | (forward-char suffix-len))) |
| 1337 | |
| 1338 | (defcustom completion-cycle-threshold nil |
| 1339 | "Number of completion candidates below which cycling is used. |
| 1340 | Depending on this setting `completion-in-region' may use cycling, |
| 1341 | like `minibuffer-force-complete'. |
| 1342 | If nil, cycling is never used. |
| 1343 | If t, cycling is always used. |
| 1344 | If an integer, cycling is used so long as there are not more |
| 1345 | completion candidates than this number." |
| 1346 | :version "24.1" |
| 1347 | :type completion--cycling-threshold-type) |
| 1348 | |
| 1349 | (defun completion--cycle-threshold (metadata) |
| 1350 | (let* ((cat (completion-metadata-get metadata 'category)) |
| 1351 | (over (assq 'cycle (cdr (assq cat completion-category-overrides))))) |
| 1352 | (if over (cdr over) completion-cycle-threshold))) |
| 1353 | |
| 1354 | (defvar-local completion-all-sorted-completions nil) |
| 1355 | (defvar-local completion--all-sorted-completions-location nil) |
| 1356 | (defvar completion-cycling nil) |
| 1357 | |
| 1358 | (defvar completion-fail-discreetly nil |
| 1359 | "If non-nil, stay quiet when there is no match.") |
| 1360 | |
| 1361 | (defun completion--message (msg) |
| 1362 | (if completion-show-inline-help |
| 1363 | (minibuffer-message msg))) |
| 1364 | |
| 1365 | (defun completion--do-completion (beg end &optional |
| 1366 | try-completion-function expect-exact) |
| 1367 | "Do the completion and return a summary of what happened. |
| 1368 | M = completion was performed, the text was Modified. |
| 1369 | C = there were available Completions. |
| 1370 | E = after completion we now have an Exact match. |
| 1371 | |
| 1372 | MCE |
| 1373 | 000 0 no possible completion |
| 1374 | 001 1 was already an exact and unique completion |
| 1375 | 010 2 no completion happened |
| 1376 | 011 3 was already an exact completion |
| 1377 | 100 4 ??? impossible |
| 1378 | 101 5 ??? impossible |
| 1379 | 110 6 some completion happened |
| 1380 | 111 7 completed to an exact completion |
| 1381 | |
| 1382 | TRY-COMPLETION-FUNCTION is a function to use in place of `try-completion'. |
| 1383 | EXPECT-EXACT, if non-nil, means that there is no need to tell the user |
| 1384 | when the buffer's text is already an exact match." |
| 1385 | (let* ((string (buffer-substring beg end)) |
| 1386 | (md (completion--field-metadata beg)) |
| 1387 | (comp (funcall (or try-completion-function |
| 1388 | 'completion-try-completion) |
| 1389 | string |
| 1390 | minibuffer-completion-table |
| 1391 | minibuffer-completion-predicate |
| 1392 | (- (point) beg) |
| 1393 | md))) |
| 1394 | (cond |
| 1395 | ((null comp) |
| 1396 | (minibuffer-hide-completions) |
| 1397 | (unless completion-fail-discreetly |
| 1398 | (ding) |
| 1399 | (completion--message "No match")) |
| 1400 | (minibuffer--bitset nil nil nil)) |
| 1401 | ((eq t comp) |
| 1402 | (minibuffer-hide-completions) |
| 1403 | (goto-char end) |
| 1404 | (completion--done string 'finished |
| 1405 | (unless expect-exact "Sole completion")) |
| 1406 | (minibuffer--bitset nil nil t)) ;Exact and unique match. |
| 1407 | (t |
| 1408 | ;; `completed' should be t if some completion was done, which doesn't |
| 1409 | ;; include simply changing the case of the entered string. However, |
| 1410 | ;; for appearance, the string is rewritten if the case changes. |
| 1411 | (let* ((comp-pos (cdr comp)) |
| 1412 | (completion (car comp)) |
| 1413 | (completed (not (eq t (compare-strings completion nil nil |
| 1414 | string nil nil t)))) |
| 1415 | (unchanged (eq t (compare-strings completion nil nil |
| 1416 | string nil nil nil)))) |
| 1417 | (if unchanged |
| 1418 | (goto-char end) |
| 1419 | ;; Insert in minibuffer the chars we got. |
| 1420 | (completion--replace beg end completion) |
| 1421 | (setq end (+ beg (length completion)))) |
| 1422 | ;; Move point to its completion-mandated destination. |
| 1423 | (forward-char (- comp-pos (length completion))) |
| 1424 | |
| 1425 | (if (not (or unchanged completed)) |
| 1426 | ;; The case of the string changed, but that's all. We're not sure |
| 1427 | ;; whether this is a unique completion or not, so try again using |
| 1428 | ;; the real case (this shouldn't recurse again, because the next |
| 1429 | ;; time try-completion will return either t or the exact string). |
| 1430 | (completion--do-completion beg end |
| 1431 | try-completion-function expect-exact) |
| 1432 | |
| 1433 | ;; It did find a match. Do we match some possibility exactly now? |
| 1434 | (let* ((exact (test-completion completion |
| 1435 | minibuffer-completion-table |
| 1436 | minibuffer-completion-predicate)) |
| 1437 | (threshold (completion--cycle-threshold md)) |
| 1438 | (comps |
| 1439 | ;; Check to see if we want to do cycling. We do it |
| 1440 | ;; here, after having performed the normal completion, |
| 1441 | ;; so as to take advantage of the difference between |
| 1442 | ;; try-completion and all-completions, for things |
| 1443 | ;; like completion-ignored-extensions. |
| 1444 | (when (and threshold |
| 1445 | ;; Check that the completion didn't make |
| 1446 | ;; us jump to a different boundary. |
| 1447 | (or (not completed) |
| 1448 | (< (car (completion-boundaries |
| 1449 | (substring completion 0 comp-pos) |
| 1450 | minibuffer-completion-table |
| 1451 | minibuffer-completion-predicate |
| 1452 | "")) |
| 1453 | comp-pos))) |
| 1454 | (completion-all-sorted-completions beg end)))) |
| 1455 | (completion--flush-all-sorted-completions) |
| 1456 | (cond |
| 1457 | ((and (consp (cdr comps)) ;; There's something to cycle. |
| 1458 | (not (ignore-errors |
| 1459 | ;; This signal an (intended) error if comps is too |
| 1460 | ;; short or if completion-cycle-threshold is t. |
| 1461 | (consp (nthcdr threshold comps))))) |
| 1462 | ;; Not more than completion-cycle-threshold remaining |
| 1463 | ;; completions: let's cycle. |
| 1464 | (setq completed t exact t) |
| 1465 | (completion--cache-all-sorted-completions beg end comps) |
| 1466 | (minibuffer-force-complete beg end)) |
| 1467 | (completed |
| 1468 | ;; We could also decide to refresh the completions, |
| 1469 | ;; if they're displayed (and assuming there are |
| 1470 | ;; completions left). |
| 1471 | (minibuffer-hide-completions) |
| 1472 | (if exact |
| 1473 | ;; If completion did not put point at end of field, |
| 1474 | ;; it's a sign that completion is not finished. |
| 1475 | (completion--done completion |
| 1476 | (if (< comp-pos (length completion)) |
| 1477 | 'exact 'unknown)))) |
| 1478 | ;; Show the completion table, if requested. |
| 1479 | ((not exact) |
| 1480 | (if (pcase completion-auto-help |
| 1481 | (`lazy (eq this-command last-command)) |
| 1482 | (_ completion-auto-help)) |
| 1483 | (minibuffer-completion-help beg end) |
| 1484 | (completion--message "Next char not unique"))) |
| 1485 | ;; If the last exact completion and this one were the same, it |
| 1486 | ;; means we've already given a "Complete, but not unique" message |
| 1487 | ;; and the user's hit TAB again, so now we give him help. |
| 1488 | (t |
| 1489 | (if (and (eq this-command last-command) completion-auto-help) |
| 1490 | (minibuffer-completion-help beg end)) |
| 1491 | (completion--done completion 'exact |
| 1492 | (unless expect-exact |
| 1493 | "Complete, but not unique")))) |
| 1494 | |
| 1495 | (minibuffer--bitset completed t exact)))))))) |
| 1496 | |
| 1497 | (defun minibuffer-complete () |
| 1498 | "Complete the minibuffer contents as far as possible. |
| 1499 | Return nil if there is no valid completion, else t. |
| 1500 | If no characters can be completed, display a list of possible completions. |
| 1501 | If you repeat this command after it displayed such a list, |
| 1502 | scroll the window of possible completions." |
| 1503 | (interactive) |
| 1504 | (when (<= (minibuffer-prompt-end) (point)) |
| 1505 | (completion-in-region (minibuffer-prompt-end) (point-max) |
| 1506 | minibuffer-completion-table |
| 1507 | minibuffer-completion-predicate))) |
| 1508 | |
| 1509 | (defun completion--in-region-1 (beg end) |
| 1510 | ;; If the previous command was not this, |
| 1511 | ;; mark the completion buffer obsolete. |
| 1512 | (setq this-command 'completion-at-point) |
| 1513 | (unless (eq 'completion-at-point last-command) |
| 1514 | (completion--flush-all-sorted-completions) |
| 1515 | (setq minibuffer-scroll-window nil)) |
| 1516 | |
| 1517 | (cond |
| 1518 | ;; If there's a fresh completion window with a live buffer, |
| 1519 | ;; and this command is repeated, scroll that window. |
| 1520 | ((and (window-live-p minibuffer-scroll-window) |
| 1521 | (eq t (frame-visible-p (window-frame minibuffer-scroll-window)))) |
| 1522 | (let ((window minibuffer-scroll-window)) |
| 1523 | (with-current-buffer (window-buffer window) |
| 1524 | (if (pos-visible-in-window-p (point-max) window) |
| 1525 | ;; If end is in view, scroll up to the beginning. |
| 1526 | (set-window-start window (point-min) nil) |
| 1527 | ;; Else scroll down one screen. |
| 1528 | (with-selected-window window |
| 1529 | (scroll-up))) |
| 1530 | nil))) |
| 1531 | ;; If we're cycling, keep on cycling. |
| 1532 | ((and completion-cycling completion-all-sorted-completions) |
| 1533 | (minibuffer-force-complete beg end) |
| 1534 | t) |
| 1535 | (t (pcase (completion--do-completion beg end) |
| 1536 | (#b000 nil) |
| 1537 | (_ t))))) |
| 1538 | |
| 1539 | (defun completion--cache-all-sorted-completions (beg end comps) |
| 1540 | (add-hook 'after-change-functions |
| 1541 | 'completion--flush-all-sorted-completions nil t) |
| 1542 | (setq completion--all-sorted-completions-location |
| 1543 | (cons (copy-marker beg) (copy-marker end))) |
| 1544 | (setq completion-all-sorted-completions comps)) |
| 1545 | |
| 1546 | (defun completion--flush-all-sorted-completions (&optional start end _len) |
| 1547 | (unless (and start end |
| 1548 | (or (> start (cdr completion--all-sorted-completions-location)) |
| 1549 | (< end (car completion--all-sorted-completions-location)))) |
| 1550 | (remove-hook 'after-change-functions |
| 1551 | 'completion--flush-all-sorted-completions t) |
| 1552 | (setq completion-cycling nil) |
| 1553 | (setq completion-all-sorted-completions nil))) |
| 1554 | |
| 1555 | (defun completion--metadata (string base md-at-point table pred) |
| 1556 | ;; Like completion-metadata, but for the specific case of getting the |
| 1557 | ;; metadata at `base', which tends to trigger pathological behavior for old |
| 1558 | ;; completion tables which don't understand `metadata'. |
| 1559 | (let ((bounds (completion-boundaries string table pred ""))) |
| 1560 | (if (eq (car bounds) base) md-at-point |
| 1561 | (completion-metadata (substring string 0 base) table pred)))) |
| 1562 | |
| 1563 | (defun completion-all-sorted-completions (&optional start end) |
| 1564 | (or completion-all-sorted-completions |
| 1565 | (let* ((start (or start (minibuffer-prompt-end))) |
| 1566 | (end (or end (point-max))) |
| 1567 | (string (buffer-substring start end)) |
| 1568 | (md (completion--field-metadata start)) |
| 1569 | (all (completion-all-completions |
| 1570 | string |
| 1571 | minibuffer-completion-table |
| 1572 | minibuffer-completion-predicate |
| 1573 | (- (point) start) |
| 1574 | md)) |
| 1575 | (last (last all)) |
| 1576 | (base-size (or (cdr last) 0)) |
| 1577 | (all-md (completion--metadata (buffer-substring-no-properties |
| 1578 | start (point)) |
| 1579 | base-size md |
| 1580 | minibuffer-completion-table |
| 1581 | minibuffer-completion-predicate)) |
| 1582 | (sort-fun (completion-metadata-get all-md 'cycle-sort-function))) |
| 1583 | (when last |
| 1584 | (setcdr last nil) |
| 1585 | |
| 1586 | ;; Delete duplicates: do it after setting last's cdr to nil (so |
| 1587 | ;; it's a proper list), and be careful to reset `last' since it |
| 1588 | ;; may be a different cons-cell. |
| 1589 | (setq all (delete-dups all)) |
| 1590 | (setq last (last all)) |
| 1591 | |
| 1592 | (setq all (if sort-fun (funcall sort-fun all) |
| 1593 | ;; Prefer shorter completions, by default. |
| 1594 | (sort all (lambda (c1 c2) (< (length c1) (length c2)))))) |
| 1595 | ;; Prefer recently used completions. |
| 1596 | (when (minibufferp) |
| 1597 | (let ((hist (symbol-value minibuffer-history-variable))) |
| 1598 | (setq all (sort all (lambda (c1 c2) |
| 1599 | (> (length (member c1 hist)) |
| 1600 | (length (member c2 hist)))))))) |
| 1601 | ;; Cache the result. This is not just for speed, but also so that |
| 1602 | ;; repeated calls to minibuffer-force-complete can cycle through |
| 1603 | ;; all possibilities. |
| 1604 | (completion--cache-all-sorted-completions |
| 1605 | start end (nconc all base-size)))))) |
| 1606 | |
| 1607 | (defun minibuffer-force-complete-and-exit () |
| 1608 | "Complete the minibuffer with first of the matches and exit." |
| 1609 | (interactive) |
| 1610 | (if (and (eq (minibuffer-prompt-end) (point-max)) |
| 1611 | minibuffer-default) |
| 1612 | ;; Use the provided default if there's one (bug#17545). |
| 1613 | (minibuffer-complete-and-exit) |
| 1614 | (minibuffer-force-complete) |
| 1615 | (completion--complete-and-exit |
| 1616 | (minibuffer-prompt-end) (point-max) #'exit-minibuffer |
| 1617 | ;; If the previous completion completed to an element which fails |
| 1618 | ;; test-completion, then we shouldn't exit, but that should be rare. |
| 1619 | (lambda () (minibuffer-message "Incomplete"))))) |
| 1620 | |
| 1621 | (defun minibuffer-force-complete (&optional start end) |
| 1622 | "Complete the minibuffer to an exact match. |
| 1623 | Repeated uses step through the possible completions." |
| 1624 | (interactive) |
| 1625 | (setq minibuffer-scroll-window nil) |
| 1626 | ;; FIXME: Need to deal with the extra-size issue here as well. |
| 1627 | ;; FIXME: ~/src/emacs/t<M-TAB>/lisp/minibuffer.el completes to |
| 1628 | ;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el. |
| 1629 | (let* ((start (copy-marker (or start (minibuffer-prompt-end)))) |
| 1630 | (end (or end (point-max))) |
| 1631 | ;; (md (completion--field-metadata start)) |
| 1632 | (all (completion-all-sorted-completions start end)) |
| 1633 | (base (+ start (or (cdr (last all)) 0)))) |
| 1634 | (cond |
| 1635 | ((not (consp all)) |
| 1636 | (completion--message |
| 1637 | (if all "No more completions" "No completions"))) |
| 1638 | ((not (consp (cdr all))) |
| 1639 | (let ((done (equal (car all) (buffer-substring-no-properties base end)))) |
| 1640 | (unless done (completion--replace base end (car all))) |
| 1641 | (completion--done (buffer-substring-no-properties start (point)) |
| 1642 | 'finished (when done "Sole completion")))) |
| 1643 | (t |
| 1644 | (completion--replace base end (car all)) |
| 1645 | (setq end (+ base (length (car all)))) |
| 1646 | (completion--done (buffer-substring-no-properties start (point)) 'sole) |
| 1647 | ;; Set cycling after modifying the buffer since the flush hook resets it. |
| 1648 | (setq completion-cycling t) |
| 1649 | (setq this-command 'completion-at-point) ;For completion-in-region. |
| 1650 | ;; If completing file names, (car all) may be a directory, so we'd now |
| 1651 | ;; have a new set of possible completions and might want to reset |
| 1652 | ;; completion-all-sorted-completions to nil, but we prefer not to, |
| 1653 | ;; so that repeated calls minibuffer-force-complete still cycle |
| 1654 | ;; through the previous possible completions. |
| 1655 | (let ((last (last all))) |
| 1656 | (setcdr last (cons (car all) (cdr last))) |
| 1657 | (completion--cache-all-sorted-completions start end (cdr all))) |
| 1658 | ;; Make sure repeated uses cycle, even though completion--done might |
| 1659 | ;; have added a space or something that moved us outside of the field. |
| 1660 | ;; (bug#12221). |
| 1661 | (let* ((table minibuffer-completion-table) |
| 1662 | (pred minibuffer-completion-predicate) |
| 1663 | (extra-prop completion-extra-properties) |
| 1664 | (cmd |
| 1665 | (lambda () "Cycle through the possible completions." |
| 1666 | (interactive) |
| 1667 | (let ((completion-extra-properties extra-prop)) |
| 1668 | (completion-in-region start (point) table pred))))) |
| 1669 | (set-transient-map |
| 1670 | (let ((map (make-sparse-keymap))) |
| 1671 | (define-key map [remap completion-at-point] cmd) |
| 1672 | (define-key map (vector last-command-event) cmd) |
| 1673 | map))))))) |
| 1674 | |
| 1675 | (defvar minibuffer-confirm-exit-commands |
| 1676 | '(completion-at-point minibuffer-complete |
| 1677 | minibuffer-complete-word PC-complete PC-complete-word) |
| 1678 | "A list of commands which cause an immediately following |
| 1679 | `minibuffer-complete-and-exit' to ask for extra confirmation.") |
| 1680 | |
| 1681 | (defun minibuffer-complete-and-exit () |
| 1682 | "Exit if the minibuffer contains a valid completion. |
| 1683 | Otherwise, try to complete the minibuffer contents. If |
| 1684 | completion leads to a valid completion, a repetition of this |
| 1685 | command will exit. |
| 1686 | |
| 1687 | If `minibuffer-completion-confirm' is `confirm', do not try to |
| 1688 | complete; instead, ask for confirmation and accept any input if |
| 1689 | confirmed. |
| 1690 | If `minibuffer-completion-confirm' is `confirm-after-completion', |
| 1691 | do not try to complete; instead, ask for confirmation if the |
| 1692 | preceding minibuffer command was a member of |
| 1693 | `minibuffer-confirm-exit-commands', and accept the input |
| 1694 | otherwise." |
| 1695 | (interactive) |
| 1696 | (completion-complete-and-exit (minibuffer-prompt-end) (point-max) |
| 1697 | #'exit-minibuffer)) |
| 1698 | |
| 1699 | (defun completion-complete-and-exit (beg end exit-function) |
| 1700 | (completion--complete-and-exit |
| 1701 | beg end exit-function |
| 1702 | (lambda () |
| 1703 | (pcase (condition-case nil |
| 1704 | (completion--do-completion beg end |
| 1705 | nil 'expect-exact) |
| 1706 | (error 1)) |
| 1707 | ((or #b001 #b011) (funcall exit-function)) |
| 1708 | (#b111 (if (not minibuffer-completion-confirm) |
| 1709 | (funcall exit-function) |
| 1710 | (minibuffer-message "Confirm") |
| 1711 | nil)) |
| 1712 | (_ nil))))) |
| 1713 | |
| 1714 | (defun completion--complete-and-exit (beg end |
| 1715 | exit-function completion-function) |
| 1716 | "Exit from `require-match' minibuffer. |
| 1717 | COMPLETION-FUNCTION is called if the current buffer's content does not |
| 1718 | appear to be a match." |
| 1719 | (cond |
| 1720 | ;; Allow user to specify null string |
| 1721 | ((= beg end) (funcall exit-function)) |
| 1722 | ((test-completion (buffer-substring beg end) |
| 1723 | minibuffer-completion-table |
| 1724 | minibuffer-completion-predicate) |
| 1725 | ;; FIXME: completion-ignore-case has various slightly |
| 1726 | ;; incompatible meanings. E.g. it can reflect whether the user |
| 1727 | ;; wants completion to pay attention to case, or whether the |
| 1728 | ;; string will be used in a context where case is significant. |
| 1729 | ;; E.g. usually try-completion should obey the first, whereas |
| 1730 | ;; test-completion should obey the second. |
| 1731 | (when completion-ignore-case |
| 1732 | ;; Fixup case of the field, if necessary. |
| 1733 | (let* ((string (buffer-substring beg end)) |
| 1734 | (compl (try-completion |
| 1735 | string |
| 1736 | minibuffer-completion-table |
| 1737 | minibuffer-completion-predicate))) |
| 1738 | (when (and (stringp compl) (not (equal string compl)) |
| 1739 | ;; If it weren't for this piece of paranoia, I'd replace |
| 1740 | ;; the whole thing with a call to do-completion. |
| 1741 | ;; This is important, e.g. when the current minibuffer's |
| 1742 | ;; content is a directory which only contains a single |
| 1743 | ;; file, so `try-completion' actually completes to |
| 1744 | ;; that file. |
| 1745 | (= (length string) (length compl))) |
| 1746 | (completion--replace beg end compl)))) |
| 1747 | (funcall exit-function)) |
| 1748 | |
| 1749 | ((memq minibuffer-completion-confirm '(confirm confirm-after-completion)) |
| 1750 | ;; The user is permitted to exit with an input that's rejected |
| 1751 | ;; by test-completion, after confirming her choice. |
| 1752 | (if (or (eq last-command this-command) |
| 1753 | ;; For `confirm-after-completion' we only ask for confirmation |
| 1754 | ;; if trying to exit immediately after typing TAB (this |
| 1755 | ;; catches most minibuffer typos). |
| 1756 | (and (eq minibuffer-completion-confirm 'confirm-after-completion) |
| 1757 | (not (memq last-command minibuffer-confirm-exit-commands)))) |
| 1758 | (funcall exit-function) |
| 1759 | (minibuffer-message "Confirm") |
| 1760 | nil)) |
| 1761 | |
| 1762 | (t |
| 1763 | ;; Call do-completion, but ignore errors. |
| 1764 | (funcall completion-function)))) |
| 1765 | |
| 1766 | (defun completion--try-word-completion (string table predicate point md) |
| 1767 | (let ((comp (completion-try-completion string table predicate point md))) |
| 1768 | (if (not (consp comp)) |
| 1769 | comp |
| 1770 | |
| 1771 | ;; If completion finds next char not unique, |
| 1772 | ;; consider adding a space or a hyphen. |
| 1773 | (when (= (length string) (length (car comp))) |
| 1774 | ;; Mark the added char with the `completion-word' property, so it |
| 1775 | ;; can be handled specially by completion styles such as |
| 1776 | ;; partial-completion. |
| 1777 | ;; We used to remove `partial-completion' from completion-styles |
| 1778 | ;; instead, but it was too blunt, leading to situations where SPC |
| 1779 | ;; was the only insertable char at point but minibuffer-complete-word |
| 1780 | ;; refused inserting it. |
| 1781 | (let ((exts (mapcar (lambda (str) (propertize str 'completion-try-word t)) |
| 1782 | '(" " "-"))) |
| 1783 | (before (substring string 0 point)) |
| 1784 | (after (substring string point)) |
| 1785 | tem) |
| 1786 | ;; If both " " and "-" lead to completions, prefer " " so SPC behaves |
| 1787 | ;; a bit more like a self-inserting key (bug#17375). |
| 1788 | (while (and exts (not (consp tem))) |
| 1789 | (setq tem (completion-try-completion |
| 1790 | (concat before (pop exts) after) |
| 1791 | table predicate (1+ point) md))) |
| 1792 | (if (consp tem) (setq comp tem)))) |
| 1793 | |
| 1794 | ;; Completing a single word is actually more difficult than completing |
| 1795 | ;; as much as possible, because we first have to find the "current |
| 1796 | ;; position" in `completion' in order to find the end of the word |
| 1797 | ;; we're completing. Normally, `string' is a prefix of `completion', |
| 1798 | ;; which makes it trivial to find the position, but with fancier |
| 1799 | ;; completion (plus env-var expansion, ...) `completion' might not |
| 1800 | ;; look anything like `string' at all. |
| 1801 | (let* ((comppoint (cdr comp)) |
| 1802 | (completion (car comp)) |
| 1803 | (before (substring string 0 point)) |
| 1804 | (combined (concat before "\n" completion))) |
| 1805 | ;; Find in completion the longest text that was right before point. |
| 1806 | (when (string-match "\\(.+\\)\n.*?\\1" combined) |
| 1807 | (let* ((prefix (match-string 1 before)) |
| 1808 | ;; We used non-greedy match to make `rem' as long as possible. |
| 1809 | (rem (substring combined (match-end 0))) |
| 1810 | ;; Find in the remainder of completion the longest text |
| 1811 | ;; that was right after point. |
| 1812 | (after (substring string point)) |
| 1813 | (suffix (if (string-match "\\`\\(.+\\).*\n.*\\1" |
| 1814 | (concat after "\n" rem)) |
| 1815 | (match-string 1 after)))) |
| 1816 | ;; The general idea is to try and guess what text was inserted |
| 1817 | ;; at point by the completion. Problem is: if we guess wrong, |
| 1818 | ;; we may end up treating as "added by completion" text that was |
| 1819 | ;; actually painfully typed by the user. So if we then cut |
| 1820 | ;; after the first word, we may throw away things the |
| 1821 | ;; user wrote. So let's try to be as conservative as possible: |
| 1822 | ;; only cut after the first word, if we're reasonably sure that |
| 1823 | ;; our guess is correct. |
| 1824 | ;; Note: a quick survey on emacs-devel seemed to indicate that |
| 1825 | ;; nobody actually cares about the "word-at-a-time" feature of |
| 1826 | ;; minibuffer-complete-word, whose real raison-d'être is that it |
| 1827 | ;; tries to add "-" or " ". One more reason to only cut after |
| 1828 | ;; the first word, if we're really sure we're right. |
| 1829 | (when (and (or suffix (zerop (length after))) |
| 1830 | (string-match (concat |
| 1831 | ;; Make submatch 1 as small as possible |
| 1832 | ;; to reduce the risk of cutting |
| 1833 | ;; valuable text. |
| 1834 | ".*" (regexp-quote prefix) "\\(.*?\\)" |
| 1835 | (if suffix (regexp-quote suffix) "\\'")) |
| 1836 | completion) |
| 1837 | ;; The new point in `completion' should also be just |
| 1838 | ;; before the suffix, otherwise something more complex |
| 1839 | ;; is going on, and we're not sure where we are. |
| 1840 | (eq (match-end 1) comppoint) |
| 1841 | ;; (match-beginning 1)..comppoint is now the stretch |
| 1842 | ;; of text in `completion' that was completed at point. |
| 1843 | (string-match "\\W" completion (match-beginning 1)) |
| 1844 | ;; Is there really something to cut? |
| 1845 | (> comppoint (match-end 0))) |
| 1846 | ;; Cut after the first word. |
| 1847 | (let ((cutpos (match-end 0))) |
| 1848 | (setq completion (concat (substring completion 0 cutpos) |
| 1849 | (substring completion comppoint))) |
| 1850 | (setq comppoint cutpos))))) |
| 1851 | |
| 1852 | (cons completion comppoint))))) |
| 1853 | |
| 1854 | |
| 1855 | (defun minibuffer-complete-word () |
| 1856 | "Complete the minibuffer contents at most a single word. |
| 1857 | After one word is completed as much as possible, a space or hyphen |
| 1858 | is added, provided that matches some possible completion. |
| 1859 | Return nil if there is no valid completion, else t." |
| 1860 | (interactive) |
| 1861 | (completion-in-region--single-word |
| 1862 | (minibuffer-prompt-end) (point-max) |
| 1863 | minibuffer-completion-table minibuffer-completion-predicate)) |
| 1864 | |
| 1865 | (defun completion-in-region--single-word (beg end collection |
| 1866 | &optional predicate) |
| 1867 | (let ((minibuffer-completion-table collection) |
| 1868 | (minibuffer-completion-predicate predicate)) |
| 1869 | (pcase (completion--do-completion beg end |
| 1870 | #'completion--try-word-completion) |
| 1871 | (#b000 nil) |
| 1872 | (_ t)))) |
| 1873 | |
| 1874 | (defface completions-annotations '((t :inherit italic)) |
| 1875 | "Face to use for annotations in the *Completions* buffer.") |
| 1876 | |
| 1877 | (defcustom completions-format 'horizontal |
| 1878 | "Define the appearance and sorting of completions. |
| 1879 | If the value is `vertical', display completions sorted vertically |
| 1880 | in columns in the *Completions* buffer. |
| 1881 | If the value is `horizontal', display completions sorted |
| 1882 | horizontally in alphabetical order, rather than down the screen." |
| 1883 | :type '(choice (const horizontal) (const vertical)) |
| 1884 | :version "23.2") |
| 1885 | |
| 1886 | (defun completion--insert-strings (strings) |
| 1887 | "Insert a list of STRINGS into the current buffer. |
| 1888 | Uses columns to keep the listing readable but compact. |
| 1889 | It also eliminates runs of equal strings." |
| 1890 | (when (consp strings) |
| 1891 | (let* ((length (apply 'max |
| 1892 | (mapcar (lambda (s) |
| 1893 | (if (consp s) |
| 1894 | (+ (string-width (car s)) |
| 1895 | (string-width (cadr s))) |
| 1896 | (string-width s))) |
| 1897 | strings))) |
| 1898 | (window (get-buffer-window (current-buffer) 0)) |
| 1899 | (wwidth (if window (1- (window-width window)) 79)) |
| 1900 | (columns (min |
| 1901 | ;; At least 2 columns; at least 2 spaces between columns. |
| 1902 | (max 2 (/ wwidth (+ 2 length))) |
| 1903 | ;; Don't allocate more columns than we can fill. |
| 1904 | ;; Windows can't show less than 3 lines anyway. |
| 1905 | (max 1 (/ (length strings) 2)))) |
| 1906 | (colwidth (/ wwidth columns)) |
| 1907 | (column 0) |
| 1908 | (rows (/ (length strings) columns)) |
| 1909 | (row 0) |
| 1910 | (first t) |
| 1911 | (laststring nil)) |
| 1912 | ;; The insertion should be "sensible" no matter what choices were made |
| 1913 | ;; for the parameters above. |
| 1914 | (dolist (str strings) |
| 1915 | (unless (equal laststring str) ; Remove (consecutive) duplicates. |
| 1916 | (setq laststring str) |
| 1917 | ;; FIXME: `string-width' doesn't pay attention to |
| 1918 | ;; `display' properties. |
| 1919 | (let ((length (if (consp str) |
| 1920 | (+ (string-width (car str)) |
| 1921 | (string-width (cadr str))) |
| 1922 | (string-width str)))) |
| 1923 | (cond |
| 1924 | ((eq completions-format 'vertical) |
| 1925 | ;; Vertical format |
| 1926 | (when (> row rows) |
| 1927 | (forward-line (- -1 rows)) |
| 1928 | (setq row 0 column (+ column colwidth))) |
| 1929 | (when (> column 0) |
| 1930 | (end-of-line) |
| 1931 | (while (> (current-column) column) |
| 1932 | (if (eobp) |
| 1933 | (insert "\n") |
| 1934 | (forward-line 1) |
| 1935 | (end-of-line))) |
| 1936 | (insert " \t") |
| 1937 | (set-text-properties (1- (point)) (point) |
| 1938 | `(display (space :align-to ,column))))) |
| 1939 | (t |
| 1940 | ;; Horizontal format |
| 1941 | (unless first |
| 1942 | (if (< wwidth (+ (max colwidth length) column)) |
| 1943 | ;; No space for `str' at point, move to next line. |
| 1944 | (progn (insert "\n") (setq column 0)) |
| 1945 | (insert " \t") |
| 1946 | ;; Leave the space unpropertized so that in the case we're |
| 1947 | ;; already past the goal column, there is still |
| 1948 | ;; a space displayed. |
| 1949 | (set-text-properties (1- (point)) (point) |
| 1950 | ;; We can't just set tab-width, because |
| 1951 | ;; completion-setup-function will kill |
| 1952 | ;; all local variables :-( |
| 1953 | `(display (space :align-to ,column))) |
| 1954 | nil)))) |
| 1955 | (setq first nil) |
| 1956 | (if (not (consp str)) |
| 1957 | (put-text-property (point) (progn (insert str) (point)) |
| 1958 | 'mouse-face 'highlight) |
| 1959 | (put-text-property (point) (progn (insert (car str)) (point)) |
| 1960 | 'mouse-face 'highlight) |
| 1961 | (let ((beg (point)) |
| 1962 | (end (progn (insert (cadr str)) (point)))) |
| 1963 | (put-text-property beg end 'mouse-face nil) |
| 1964 | (font-lock-prepend-text-property beg end 'face |
| 1965 | 'completions-annotations))) |
| 1966 | (cond |
| 1967 | ((eq completions-format 'vertical) |
| 1968 | ;; Vertical format |
| 1969 | (if (> column 0) |
| 1970 | (forward-line) |
| 1971 | (insert "\n")) |
| 1972 | (setq row (1+ row))) |
| 1973 | (t |
| 1974 | ;; Horizontal format |
| 1975 | ;; Next column to align to. |
| 1976 | (setq column (+ column |
| 1977 | ;; Round up to a whole number of columns. |
| 1978 | (* colwidth (ceiling length colwidth)))))))))))) |
| 1979 | |
| 1980 | (defvar completion-common-substring nil) |
| 1981 | (make-obsolete-variable 'completion-common-substring nil "23.1") |
| 1982 | |
| 1983 | (defvar completion-setup-hook nil |
| 1984 | "Normal hook run at the end of setting up a completion list buffer. |
| 1985 | When this hook is run, the current buffer is the one in which the |
| 1986 | command to display the completion list buffer was run. |
| 1987 | The completion list buffer is available as the value of `standard-output'. |
| 1988 | See also `display-completion-list'.") |
| 1989 | |
| 1990 | (defface completions-first-difference |
| 1991 | '((t (:inherit bold))) |
| 1992 | "Face for the first uncommon character in completions. |
| 1993 | See also the face `completions-common-part'.") |
| 1994 | |
| 1995 | (defface completions-common-part '((t nil)) |
| 1996 | "Face for the common prefix substring in completions. |
| 1997 | The idea of this face is that you can use it to make the common parts |
| 1998 | less visible than normal, so that the differing parts are emphasized |
| 1999 | by contrast. |
| 2000 | See also the face `completions-first-difference'.") |
| 2001 | |
| 2002 | (defun completion-hilit-commonality (completions prefix-len &optional base-size) |
| 2003 | "Apply font-lock highlighting to a list of completions, COMPLETIONS. |
| 2004 | PREFIX-LEN is an integer. BASE-SIZE is an integer or nil (meaning zero). |
| 2005 | |
| 2006 | This adds the face `completions-common-part' to the first |
| 2007 | \(PREFIX-LEN - BASE-SIZE) characters of each completion, and the face |
| 2008 | `completions-first-difference' to the first character after that. |
| 2009 | |
| 2010 | It returns a list with font-lock properties applied to each element, |
| 2011 | and with BASE-SIZE appended as the last element." |
| 2012 | (when completions |
| 2013 | (let ((com-str-len (- prefix-len (or base-size 0)))) |
| 2014 | (nconc |
| 2015 | (mapcar |
| 2016 | (lambda (elem) |
| 2017 | (let ((str |
| 2018 | ;; Don't modify the string itself, but a copy, since the |
| 2019 | ;; the string may be read-only or used for other purposes. |
| 2020 | ;; Furthermore, since `completions' may come from |
| 2021 | ;; display-completion-list, `elem' may be a list. |
| 2022 | (if (consp elem) |
| 2023 | (car (setq elem (cons (copy-sequence (car elem)) |
| 2024 | (cdr elem)))) |
| 2025 | (setq elem (copy-sequence elem))))) |
| 2026 | (font-lock-prepend-text-property |
| 2027 | 0 |
| 2028 | ;; If completion-boundaries returns incorrect |
| 2029 | ;; values, all-completions may return strings |
| 2030 | ;; that don't contain the prefix. |
| 2031 | (min com-str-len (length str)) |
| 2032 | 'face 'completions-common-part str) |
| 2033 | (if (> (length str) com-str-len) |
| 2034 | (font-lock-prepend-text-property com-str-len (1+ com-str-len) |
| 2035 | 'face |
| 2036 | 'completions-first-difference |
| 2037 | str))) |
| 2038 | elem) |
| 2039 | completions) |
| 2040 | base-size)))) |
| 2041 | |
| 2042 | (defun display-completion-list (completions &optional common-substring) |
| 2043 | "Display the list of completions, COMPLETIONS, using `standard-output'. |
| 2044 | Each element may be just a symbol or string |
| 2045 | or may be a list of two strings to be printed as if concatenated. |
| 2046 | If it is a list of two strings, the first is the actual completion |
| 2047 | alternative, the second serves as annotation. |
| 2048 | `standard-output' must be a buffer. |
| 2049 | The actual completion alternatives, as inserted, are given `mouse-face' |
| 2050 | properties of `highlight'. |
| 2051 | At the end, this runs the normal hook `completion-setup-hook'. |
| 2052 | It can find the completion buffer in `standard-output'." |
| 2053 | (declare (advertised-calling-convention (completions) "24.4")) |
| 2054 | (if common-substring |
| 2055 | (setq completions (completion-hilit-commonality |
| 2056 | completions (length common-substring) |
| 2057 | ;; We don't know the base-size. |
| 2058 | nil))) |
| 2059 | (if (not (bufferp standard-output)) |
| 2060 | ;; This *never* (ever) happens, so there's no point trying to be clever. |
| 2061 | (with-temp-buffer |
| 2062 | (let ((standard-output (current-buffer)) |
| 2063 | (completion-setup-hook nil)) |
| 2064 | (display-completion-list completions common-substring)) |
| 2065 | (princ (buffer-string))) |
| 2066 | |
| 2067 | (with-current-buffer standard-output |
| 2068 | (goto-char (point-max)) |
| 2069 | (if (null completions) |
| 2070 | (insert "There are no possible completions of what you have typed.") |
| 2071 | (insert "Possible completions are:\n") |
| 2072 | (completion--insert-strings completions)))) |
| 2073 | |
| 2074 | ;; The hilit used to be applied via completion-setup-hook, so there |
| 2075 | ;; may still be some code that uses completion-common-substring. |
| 2076 | (with-no-warnings |
| 2077 | (let ((completion-common-substring common-substring)) |
| 2078 | (run-hooks 'completion-setup-hook))) |
| 2079 | nil) |
| 2080 | |
| 2081 | (defvar completion-extra-properties nil |
| 2082 | "Property list of extra properties of the current completion job. |
| 2083 | These include: |
| 2084 | |
| 2085 | `:annotation-function': Function to annotate the completions buffer. |
| 2086 | The function must accept one argument, a completion string, |
| 2087 | and return either nil or a string which is to be displayed |
| 2088 | next to the completion (but which is not part of the |
| 2089 | completion). The function can access the completion data via |
| 2090 | `minibuffer-completion-table' and related variables. |
| 2091 | |
| 2092 | `:exit-function': Function to run after completion is performed. |
| 2093 | |
| 2094 | The function must accept two arguments, STRING and STATUS. |
| 2095 | STRING is the text to which the field was completed, and |
| 2096 | STATUS indicates what kind of operation happened: |
| 2097 | `finished' - text is now complete |
| 2098 | `sole' - text cannot be further completed but |
| 2099 | completion is not finished |
| 2100 | `exact' - text is a valid completion but may be further |
| 2101 | completed.") |
| 2102 | |
| 2103 | (defvar completion-annotate-function |
| 2104 | nil |
| 2105 | ;; Note: there's a lot of scope as for when to add annotations and |
| 2106 | ;; what annotations to add. E.g. completing-help.el allowed adding |
| 2107 | ;; the first line of docstrings to M-x completion. But there's |
| 2108 | ;; a tension, since such annotations, while useful at times, can |
| 2109 | ;; actually drown the useful information. |
| 2110 | ;; So completion-annotate-function should be used parsimoniously, or |
| 2111 | ;; else only used upon a user's request (e.g. we could add a command |
| 2112 | ;; to completion-list-mode to add annotations to the current |
| 2113 | ;; completions). |
| 2114 | "Function to add annotations in the *Completions* buffer. |
| 2115 | The function takes a completion and should either return nil, or a string that |
| 2116 | will be displayed next to the completion. The function can access the |
| 2117 | completion table and predicates via `minibuffer-completion-table' and related |
| 2118 | variables.") |
| 2119 | (make-obsolete-variable 'completion-annotate-function |
| 2120 | 'completion-extra-properties "24.1") |
| 2121 | |
| 2122 | (defun completion--done (string &optional finished message) |
| 2123 | (let* ((exit-fun (plist-get completion-extra-properties :exit-function)) |
| 2124 | (pre-msg (and exit-fun (current-message)))) |
| 2125 | (cl-assert (memq finished '(exact sole finished unknown))) |
| 2126 | (when exit-fun |
| 2127 | (when (eq finished 'unknown) |
| 2128 | (setq finished |
| 2129 | (if (eq (try-completion string |
| 2130 | minibuffer-completion-table |
| 2131 | minibuffer-completion-predicate) |
| 2132 | t) |
| 2133 | 'finished 'exact))) |
| 2134 | (funcall exit-fun string finished)) |
| 2135 | (when (and message |
| 2136 | ;; Don't output any message if the exit-fun already did so. |
| 2137 | (equal pre-msg (and exit-fun (current-message)))) |
| 2138 | (completion--message message)))) |
| 2139 | |
| 2140 | (defun minibuffer-completion-help (&optional start end) |
| 2141 | "Display a list of possible completions of the current minibuffer contents." |
| 2142 | (interactive) |
| 2143 | (message "Making completion list...") |
| 2144 | (let* ((start (or start (minibuffer-prompt-end))) |
| 2145 | (end (or end (point-max))) |
| 2146 | (string (buffer-substring start end)) |
| 2147 | (md (completion--field-metadata start)) |
| 2148 | (completions (completion-all-completions |
| 2149 | string |
| 2150 | minibuffer-completion-table |
| 2151 | minibuffer-completion-predicate |
| 2152 | (- (point) start) |
| 2153 | md))) |
| 2154 | (message nil) |
| 2155 | (if (or (null completions) |
| 2156 | (and (not (consp (cdr completions))) |
| 2157 | (equal (car completions) string))) |
| 2158 | (progn |
| 2159 | ;; If there are no completions, or if the current input is already |
| 2160 | ;; the sole completion, then hide (previous&stale) completions. |
| 2161 | (minibuffer-hide-completions) |
| 2162 | (ding) |
| 2163 | (minibuffer-message |
| 2164 | (if completions "Sole completion" "No completions"))) |
| 2165 | |
| 2166 | (let* ((last (last completions)) |
| 2167 | (base-size (cdr last)) |
| 2168 | (prefix (unless (zerop base-size) (substring string 0 base-size))) |
| 2169 | (all-md (completion--metadata (buffer-substring-no-properties |
| 2170 | start (point)) |
| 2171 | base-size md |
| 2172 | minibuffer-completion-table |
| 2173 | minibuffer-completion-predicate)) |
| 2174 | (afun (or (completion-metadata-get all-md 'annotation-function) |
| 2175 | (plist-get completion-extra-properties |
| 2176 | :annotation-function) |
| 2177 | completion-annotate-function)) |
| 2178 | ;; If the *Completions* buffer is shown in a new |
| 2179 | ;; window, mark it as softly-dedicated, so bury-buffer in |
| 2180 | ;; minibuffer-hide-completions will know whether to |
| 2181 | ;; delete the window or not. |
| 2182 | (display-buffer-mark-dedicated 'soft)) |
| 2183 | (with-output-to-temp-buffer "*Completions*" |
| 2184 | ;; Remove the base-size tail because `sort' requires a properly |
| 2185 | ;; nil-terminated list. |
| 2186 | (when last (setcdr last nil)) |
| 2187 | (setq completions |
| 2188 | ;; FIXME: This function is for the output of all-completions, |
| 2189 | ;; not completion-all-completions. Often it's the same, but |
| 2190 | ;; not always. |
| 2191 | (let ((sort-fun (completion-metadata-get |
| 2192 | all-md 'display-sort-function))) |
| 2193 | (if sort-fun |
| 2194 | (funcall sort-fun completions) |
| 2195 | (sort completions 'string-lessp)))) |
| 2196 | (when afun |
| 2197 | (setq completions |
| 2198 | (mapcar (lambda (s) |
| 2199 | (let ((ann (funcall afun s))) |
| 2200 | (if ann (list s ann) s))) |
| 2201 | completions))) |
| 2202 | |
| 2203 | (with-current-buffer standard-output |
| 2204 | (set (make-local-variable 'completion-base-position) |
| 2205 | (list (+ start base-size) |
| 2206 | ;; FIXME: We should pay attention to completion |
| 2207 | ;; boundaries here, but currently |
| 2208 | ;; completion-all-completions does not give us the |
| 2209 | ;; necessary information. |
| 2210 | end)) |
| 2211 | (set (make-local-variable 'completion-list-insert-choice-function) |
| 2212 | (let ((ctable minibuffer-completion-table) |
| 2213 | (cpred minibuffer-completion-predicate) |
| 2214 | (cprops completion-extra-properties)) |
| 2215 | (lambda (start end choice) |
| 2216 | (unless (or (zerop (length prefix)) |
| 2217 | (equal prefix |
| 2218 | (buffer-substring-no-properties |
| 2219 | (max (point-min) |
| 2220 | (- start (length prefix))) |
| 2221 | start))) |
| 2222 | (message "*Completions* out of date")) |
| 2223 | ;; FIXME: Use `md' to do quoting&terminator here. |
| 2224 | (completion--replace start end choice) |
| 2225 | (let* ((minibuffer-completion-table ctable) |
| 2226 | (minibuffer-completion-predicate cpred) |
| 2227 | (completion-extra-properties cprops) |
| 2228 | (result (concat prefix choice)) |
| 2229 | (bounds (completion-boundaries |
| 2230 | result ctable cpred ""))) |
| 2231 | ;; If the completion introduces a new field, then |
| 2232 | ;; completion is not finished. |
| 2233 | (completion--done result |
| 2234 | (if (eq (car bounds) (length result)) |
| 2235 | 'exact 'finished))))))) |
| 2236 | |
| 2237 | (display-completion-list completions)))) |
| 2238 | nil)) |
| 2239 | |
| 2240 | (defun minibuffer-hide-completions () |
| 2241 | "Get rid of an out-of-date *Completions* buffer." |
| 2242 | ;; FIXME: We could/should use minibuffer-scroll-window here, but it |
| 2243 | ;; can also point to the minibuffer-parent-window, so it's a bit tricky. |
| 2244 | (let ((win (get-buffer-window "*Completions*" 0))) |
| 2245 | (if win (with-selected-window win (bury-buffer))))) |
| 2246 | |
| 2247 | (defun exit-minibuffer () |
| 2248 | "Terminate this minibuffer argument." |
| 2249 | (interactive) |
| 2250 | ;; If the command that uses this has made modifications in the minibuffer, |
| 2251 | ;; we don't want them to cause deactivation of the mark in the original |
| 2252 | ;; buffer. |
| 2253 | ;; A better solution would be to make deactivate-mark buffer-local |
| 2254 | ;; (or to turn it into a list of buffers, ...), but in the mean time, |
| 2255 | ;; this should do the trick in most cases. |
| 2256 | (setq deactivate-mark nil) |
| 2257 | (throw 'exit nil)) |
| 2258 | |
| 2259 | (defun self-insert-and-exit () |
| 2260 | "Terminate minibuffer input." |
| 2261 | (interactive) |
| 2262 | (if (characterp last-command-event) |
| 2263 | (call-interactively 'self-insert-command) |
| 2264 | (ding)) |
| 2265 | (exit-minibuffer)) |
| 2266 | |
| 2267 | (defvar completion-in-region-functions nil |
| 2268 | "Wrapper hook around `completion--in-region'.") |
| 2269 | (make-obsolete-variable 'completion-in-region-functions |
| 2270 | 'completion-in-region-function "24.4") |
| 2271 | |
| 2272 | (defvar completion-in-region-function #'completion--in-region |
| 2273 | "Function to perform the job of `completion-in-region'. |
| 2274 | The function is called with 4 arguments: START END COLLECTION PREDICATE. |
| 2275 | The arguments and expected return value are as specified for |
| 2276 | `completion-in-region'.") |
| 2277 | |
| 2278 | (defvar completion-in-region--data nil) |
| 2279 | |
| 2280 | (defvar completion-in-region-mode-predicate nil |
| 2281 | "Predicate to tell `completion-in-region-mode' when to exit. |
| 2282 | It is called with no argument and should return nil when |
| 2283 | `completion-in-region-mode' should exit (and hence pop down |
| 2284 | the *Completions* buffer).") |
| 2285 | |
| 2286 | (defvar completion-in-region-mode--predicate nil |
| 2287 | "Copy of the value of `completion-in-region-mode-predicate'. |
| 2288 | This holds the value `completion-in-region-mode-predicate' had when |
| 2289 | we entered `completion-in-region-mode'.") |
| 2290 | |
| 2291 | (defun completion-in-region (start end collection &optional predicate) |
| 2292 | "Complete the text between START and END using COLLECTION. |
| 2293 | Point needs to be somewhere between START and END. |
| 2294 | PREDICATE (a function called with no arguments) says when to exit. |
| 2295 | This calls the function that `completion-in-region-function' specifies |
| 2296 | \(passing the same four arguments that it received) to do the work, |
| 2297 | and returns whatever it does. The return value should be nil |
| 2298 | if there was no valid completion, else t." |
| 2299 | (cl-assert (<= start (point)) (<= (point) end)) |
| 2300 | (funcall completion-in-region-function start end collection predicate)) |
| 2301 | |
| 2302 | (defcustom read-file-name-completion-ignore-case |
| 2303 | (if (memq system-type '(ms-dos windows-nt darwin cygwin)) |
| 2304 | t nil) |
| 2305 | "Non-nil means when reading a file name completion ignores case." |
| 2306 | :type 'boolean |
| 2307 | :version "22.1") |
| 2308 | |
| 2309 | (defun completion--in-region (start end collection &optional predicate) |
| 2310 | "Default function to use for `completion-in-region-function'. |
| 2311 | Its arguments and return value are as specified for `completion-in-region'. |
| 2312 | This respects the wrapper hook `completion-in-region-functions'." |
| 2313 | (with-wrapper-hook |
| 2314 | ;; FIXME: Maybe we should use this hook to provide a "display |
| 2315 | ;; completions" operation as well. |
| 2316 | completion-in-region-functions (start end collection predicate) |
| 2317 | (let ((minibuffer-completion-table collection) |
| 2318 | (minibuffer-completion-predicate predicate)) |
| 2319 | ;; HACK: if the text we are completing is already in a field, we |
| 2320 | ;; want the completion field to take priority (e.g. Bug#6830). |
| 2321 | (when completion-in-region-mode-predicate |
| 2322 | (setq completion-in-region--data |
| 2323 | `(,(if (markerp start) start (copy-marker start)) |
| 2324 | ,(copy-marker end t) ,collection ,predicate)) |
| 2325 | (completion-in-region-mode 1)) |
| 2326 | (completion--in-region-1 start end)))) |
| 2327 | |
| 2328 | (defvar completion-in-region-mode-map |
| 2329 | (let ((map (make-sparse-keymap))) |
| 2330 | ;; FIXME: Only works if completion-in-region-mode was activated via |
| 2331 | ;; completion-at-point called directly. |
| 2332 | (define-key map "\M-?" 'completion-help-at-point) |
| 2333 | (define-key map "\t" 'completion-at-point) |
| 2334 | map) |
| 2335 | "Keymap activated during `completion-in-region'.") |
| 2336 | |
| 2337 | ;; It is difficult to know when to exit completion-in-region-mode (i.e. hide |
| 2338 | ;; the *Completions*). Here's how previous packages did it: |
| 2339 | ;; - lisp-mode: never. |
| 2340 | ;; - comint: only do it if you hit SPC at the right time. |
| 2341 | ;; - pcomplete: pop it down on SPC or after some time-delay. |
| 2342 | ;; - semantic: use a post-command-hook check similar to this one. |
| 2343 | (defun completion-in-region--postch () |
| 2344 | (or unread-command-events ;Don't pop down the completions in the middle of |
| 2345 | ;mouse-drag-region/mouse-set-point. |
| 2346 | (and completion-in-region--data |
| 2347 | (and (eq (marker-buffer (nth 0 completion-in-region--data)) |
| 2348 | (current-buffer)) |
| 2349 | (>= (point) (nth 0 completion-in-region--data)) |
| 2350 | (<= (point) |
| 2351 | (save-excursion |
| 2352 | (goto-char (nth 1 completion-in-region--data)) |
| 2353 | (line-end-position))) |
| 2354 | (funcall completion-in-region-mode--predicate))) |
| 2355 | (completion-in-region-mode -1))) |
| 2356 | |
| 2357 | ;; (defalias 'completion-in-region--prech 'completion-in-region--postch) |
| 2358 | |
| 2359 | (defvar completion-in-region-mode nil) ;Explicit defvar, i.s.o defcustom. |
| 2360 | |
| 2361 | (define-minor-mode completion-in-region-mode |
| 2362 | "Transient minor mode used during `completion-in-region'." |
| 2363 | :global t |
| 2364 | :group 'minibuffer |
| 2365 | ;; Prevent definition of a custom-variable since it makes no sense to |
| 2366 | ;; customize this variable. |
| 2367 | :variable completion-in-region-mode |
| 2368 | ;; (remove-hook 'pre-command-hook #'completion-in-region--prech) |
| 2369 | (remove-hook 'post-command-hook #'completion-in-region--postch) |
| 2370 | (setq minor-mode-overriding-map-alist |
| 2371 | (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist) |
| 2372 | minor-mode-overriding-map-alist)) |
| 2373 | (if (null completion-in-region-mode) |
| 2374 | (progn |
| 2375 | (setq completion-in-region--data nil) |
| 2376 | (unless (equal "*Completions*" (buffer-name (window-buffer))) |
| 2377 | (minibuffer-hide-completions))) |
| 2378 | ;; (add-hook 'pre-command-hook #'completion-in-region--prech) |
| 2379 | (cl-assert completion-in-region-mode-predicate) |
| 2380 | (setq completion-in-region-mode--predicate |
| 2381 | completion-in-region-mode-predicate) |
| 2382 | (add-hook 'post-command-hook #'completion-in-region--postch) |
| 2383 | (push `(completion-in-region-mode . ,completion-in-region-mode-map) |
| 2384 | minor-mode-overriding-map-alist))) |
| 2385 | |
| 2386 | ;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it |
| 2387 | ;; on minor-mode-overriding-map-alist instead. |
| 2388 | (setq minor-mode-map-alist |
| 2389 | (delq (assq 'completion-in-region-mode minor-mode-map-alist) |
| 2390 | minor-mode-map-alist)) |
| 2391 | |
| 2392 | (defvar completion-at-point-functions '(tags-completion-at-point-function) |
| 2393 | "Special hook to find the completion table for the thing at point. |
| 2394 | Each function on this hook is called in turns without any argument and should |
| 2395 | return either nil to mean that it is not applicable at point, |
| 2396 | or a function of no argument to perform completion (discouraged), |
| 2397 | or a list of the form (START END COLLECTION . PROPS) where |
| 2398 | START and END delimit the entity to complete and should include point, |
| 2399 | COLLECTION is the completion table to use to complete it, and |
| 2400 | PROPS is a property list for additional information. |
| 2401 | Currently supported properties are all the properties that can appear in |
| 2402 | `completion-extra-properties' plus: |
| 2403 | `:predicate' a predicate that completion candidates need to satisfy. |
| 2404 | `:exclusive' If `no', means that if the completion table fails to |
| 2405 | match the text at point, then instead of reporting a completion |
| 2406 | failure, the completion should try the next completion function. |
| 2407 | As is the case with most hooks, the functions are responsible to preserve |
| 2408 | things like point and current buffer.") |
| 2409 | |
| 2410 | (defvar completion--capf-misbehave-funs nil |
| 2411 | "List of functions found on `completion-at-point-functions' that misbehave. |
| 2412 | These are functions that neither return completion data nor a completion |
| 2413 | function but instead perform completion right away.") |
| 2414 | (defvar completion--capf-safe-funs nil |
| 2415 | "List of well-behaved functions found on `completion-at-point-functions'. |
| 2416 | These are functions which return proper completion data rather than |
| 2417 | a completion function or god knows what else.") |
| 2418 | |
| 2419 | (defun completion--capf-wrapper (fun which) |
| 2420 | ;; FIXME: The safe/misbehave handling assumes that a given function will |
| 2421 | ;; always return the same kind of data, but this breaks down with functions |
| 2422 | ;; like comint-completion-at-point or mh-letter-completion-at-point, which |
| 2423 | ;; could be sometimes safe and sometimes misbehaving (and sometimes neither). |
| 2424 | (if (pcase which |
| 2425 | (`all t) |
| 2426 | (`safe (member fun completion--capf-safe-funs)) |
| 2427 | (`optimist (not (member fun completion--capf-misbehave-funs)))) |
| 2428 | (let ((res (funcall fun))) |
| 2429 | (cond |
| 2430 | ((and (consp res) (not (functionp res))) |
| 2431 | (unless (member fun completion--capf-safe-funs) |
| 2432 | (push fun completion--capf-safe-funs)) |
| 2433 | (and (eq 'no (plist-get (nthcdr 3 res) :exclusive)) |
| 2434 | ;; FIXME: Here we'd need to decide whether there are |
| 2435 | ;; valid completions against the current text. But this depends |
| 2436 | ;; on the actual completion UI (e.g. with the default completion |
| 2437 | ;; it depends on completion-style) ;-( |
| 2438 | ;; We approximate this result by checking whether prefix |
| 2439 | ;; completion might work, which means that non-prefix completion |
| 2440 | ;; will not work (or not right) for completion functions that |
| 2441 | ;; are non-exclusive. |
| 2442 | (null (try-completion (buffer-substring-no-properties |
| 2443 | (car res) (point)) |
| 2444 | (nth 2 res) |
| 2445 | (plist-get (nthcdr 3 res) :predicate))) |
| 2446 | (setq res nil))) |
| 2447 | ((not (or (listp res) (functionp res))) |
| 2448 | (unless (member fun completion--capf-misbehave-funs) |
| 2449 | (message |
| 2450 | "Completion function %S uses a deprecated calling convention" fun) |
| 2451 | (push fun completion--capf-misbehave-funs)))) |
| 2452 | (if res (cons fun res))))) |
| 2453 | |
| 2454 | (defun completion-at-point () |
| 2455 | "Perform completion on the text around point. |
| 2456 | The completion method is determined by `completion-at-point-functions'." |
| 2457 | (interactive) |
| 2458 | (let ((res (run-hook-wrapped 'completion-at-point-functions |
| 2459 | #'completion--capf-wrapper 'all))) |
| 2460 | (pcase res |
| 2461 | (`(,_ . ,(and (pred functionp) f)) (funcall f)) |
| 2462 | (`(,hookfun . (,start ,end ,collection . ,plist)) |
| 2463 | (unless (markerp start) (setq start (copy-marker start))) |
| 2464 | (let* ((completion-extra-properties plist) |
| 2465 | (completion-in-region-mode-predicate |
| 2466 | (lambda () |
| 2467 | ;; We're still in the same completion field. |
| 2468 | (let ((newstart (car-safe (funcall hookfun)))) |
| 2469 | (and newstart (= newstart start)))))) |
| 2470 | (completion-in-region start end collection |
| 2471 | (plist-get plist :predicate)))) |
| 2472 | ;; Maybe completion already happened and the function returned t. |
| 2473 | (_ (cdr res))))) |
| 2474 | |
| 2475 | (defun completion-help-at-point () |
| 2476 | "Display the completions on the text around point. |
| 2477 | The completion method is determined by `completion-at-point-functions'." |
| 2478 | (interactive) |
| 2479 | (let ((res (run-hook-wrapped 'completion-at-point-functions |
| 2480 | ;; Ignore misbehaving functions. |
| 2481 | #'completion--capf-wrapper 'optimist))) |
| 2482 | (pcase res |
| 2483 | (`(,_ . ,(and (pred functionp) f)) |
| 2484 | (message "Don't know how to show completions for %S" f)) |
| 2485 | (`(,hookfun . (,start ,end ,collection . ,plist)) |
| 2486 | (unless (markerp start) (setq start (copy-marker start))) |
| 2487 | (let* ((minibuffer-completion-table collection) |
| 2488 | (minibuffer-completion-predicate (plist-get plist :predicate)) |
| 2489 | (completion-extra-properties plist) |
| 2490 | (completion-in-region-mode-predicate |
| 2491 | (lambda () |
| 2492 | ;; We're still in the same completion field. |
| 2493 | (let ((newstart (car-safe (funcall hookfun)))) |
| 2494 | (and newstart (= newstart start)))))) |
| 2495 | ;; FIXME: We should somehow (ab)use completion-in-region-function or |
| 2496 | ;; introduce a corresponding hook (plus another for word-completion, |
| 2497 | ;; and another for force-completion, maybe?). |
| 2498 | (setq completion-in-region--data |
| 2499 | `(,start ,(copy-marker end t) ,collection |
| 2500 | ,(plist-get plist :predicate))) |
| 2501 | (completion-in-region-mode 1) |
| 2502 | (minibuffer-completion-help start end))) |
| 2503 | (`(,hookfun . ,_) |
| 2504 | ;; The hook function already performed completion :-( |
| 2505 | ;; Not much we can do at this point. |
| 2506 | (message "%s already performed completion!" hookfun) |
| 2507 | nil) |
| 2508 | (_ (message "Nothing to complete at point"))))) |
| 2509 | |
| 2510 | ;;; Key bindings. |
| 2511 | |
| 2512 | (let ((map minibuffer-local-map)) |
| 2513 | (define-key map "\C-g" 'abort-recursive-edit) |
| 2514 | (define-key map "\r" 'exit-minibuffer) |
| 2515 | (define-key map "\n" 'exit-minibuffer)) |
| 2516 | |
| 2517 | (defvar minibuffer-local-completion-map |
| 2518 | (let ((map (make-sparse-keymap))) |
| 2519 | (set-keymap-parent map minibuffer-local-map) |
| 2520 | (define-key map "\t" 'minibuffer-complete) |
| 2521 | ;; M-TAB is already abused for many other purposes, so we should find |
| 2522 | ;; another binding for it. |
| 2523 | ;; (define-key map "\e\t" 'minibuffer-force-complete) |
| 2524 | (define-key map " " 'minibuffer-complete-word) |
| 2525 | (define-key map "?" 'minibuffer-completion-help) |
| 2526 | map) |
| 2527 | "Local keymap for minibuffer input with completion.") |
| 2528 | |
| 2529 | (defvar minibuffer-local-must-match-map |
| 2530 | (let ((map (make-sparse-keymap))) |
| 2531 | (set-keymap-parent map minibuffer-local-completion-map) |
| 2532 | (define-key map "\r" 'minibuffer-complete-and-exit) |
| 2533 | (define-key map "\n" 'minibuffer-complete-and-exit) |
| 2534 | map) |
| 2535 | "Local keymap for minibuffer input with completion, for exact match.") |
| 2536 | |
| 2537 | (defvar minibuffer-local-filename-completion-map |
| 2538 | (let ((map (make-sparse-keymap))) |
| 2539 | (define-key map " " nil) |
| 2540 | map) |
| 2541 | "Local keymap for minibuffer input with completion for filenames. |
| 2542 | Gets combined either with `minibuffer-local-completion-map' or |
| 2543 | with `minibuffer-local-must-match-map'.") |
| 2544 | |
| 2545 | (define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map |
| 2546 | 'minibuffer-local-filename-must-match-map "23.1") |
| 2547 | (defvar minibuffer-local-filename-must-match-map (make-sparse-keymap)) |
| 2548 | (make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1") |
| 2549 | |
| 2550 | (let ((map minibuffer-local-ns-map)) |
| 2551 | (define-key map " " 'exit-minibuffer) |
| 2552 | (define-key map "\t" 'exit-minibuffer) |
| 2553 | (define-key map "?" 'self-insert-and-exit)) |
| 2554 | |
| 2555 | (defvar minibuffer-inactive-mode-map |
| 2556 | (let ((map (make-keymap))) |
| 2557 | (suppress-keymap map) |
| 2558 | (define-key map "e" 'find-file-other-frame) |
| 2559 | (define-key map "f" 'find-file-other-frame) |
| 2560 | (define-key map "b" 'switch-to-buffer-other-frame) |
| 2561 | (define-key map "i" 'info) |
| 2562 | (define-key map "m" 'mail) |
| 2563 | (define-key map "n" 'make-frame) |
| 2564 | (define-key map [mouse-1] 'view-echo-area-messages) |
| 2565 | ;; So the global down-mouse-1 binding doesn't clutter the execution of the |
| 2566 | ;; above mouse-1 binding. |
| 2567 | (define-key map [down-mouse-1] #'ignore) |
| 2568 | map) |
| 2569 | "Keymap for use in the minibuffer when it is not active. |
| 2570 | The non-mouse bindings in this keymap can only be used in minibuffer-only |
| 2571 | frames, since the minibuffer can normally not be selected when it is |
| 2572 | not active.") |
| 2573 | |
| 2574 | (define-derived-mode minibuffer-inactive-mode nil "InactiveMinibuffer" |
| 2575 | :abbrev-table nil ;abbrev.el is not loaded yet during dump. |
| 2576 | ;; Note: this major mode is called from minibuf.c. |
| 2577 | "Major mode to use in the minibuffer when it is not active. |
| 2578 | This is only used when the minibuffer area has no active minibuffer.") |
| 2579 | |
| 2580 | ;;; Completion tables. |
| 2581 | |
| 2582 | (defun minibuffer--double-dollars (str) |
| 2583 | ;; Reuse the actual "$" from the string to preserve any text-property it |
| 2584 | ;; might have, such as `face'. |
| 2585 | (replace-regexp-in-string "\\$" (lambda (dollar) (concat dollar dollar)) |
| 2586 | str)) |
| 2587 | |
| 2588 | (defun completion--make-envvar-table () |
| 2589 | (mapcar (lambda (enventry) |
| 2590 | (substring enventry 0 (string-match-p "=" enventry))) |
| 2591 | process-environment)) |
| 2592 | |
| 2593 | (defconst completion--embedded-envvar-re |
| 2594 | ;; We can't reuse env--substitute-vars-regexp because we need to match only |
| 2595 | ;; potentially-unfinished envvars at end of string. |
| 2596 | (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" |
| 2597 | "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) |
| 2598 | |
| 2599 | (defun completion--embedded-envvar-table (string _pred action) |
| 2600 | "Completion table for envvars embedded in a string. |
| 2601 | The envvar syntax (and escaping) rules followed by this table are the |
| 2602 | same as `substitute-in-file-name'." |
| 2603 | ;; We ignore `pred', because the predicates passed to us via |
| 2604 | ;; read-file-name-internal are not 100% correct and fail here: |
| 2605 | ;; e.g. we get predicates like file-directory-p there, whereas the filename |
| 2606 | ;; completed needs to be passed through substitute-in-file-name before it |
| 2607 | ;; can be passed to file-directory-p. |
| 2608 | (when (string-match completion--embedded-envvar-re string) |
| 2609 | (let* ((beg (or (match-beginning 2) (match-beginning 1))) |
| 2610 | (table (completion--make-envvar-table)) |
| 2611 | (prefix (substring string 0 beg))) |
| 2612 | (cond |
| 2613 | ((eq action 'lambda) |
| 2614 | ;; This table is expected to be used in conjunction with some |
| 2615 | ;; other table that provides the "main" completion. Let the |
| 2616 | ;; other table handle the test-completion case. |
| 2617 | nil) |
| 2618 | ((or (eq (car-safe action) 'boundaries) (eq action 'metadata)) |
| 2619 | ;; Only return boundaries/metadata if there's something to complete, |
| 2620 | ;; since otherwise when we're used in |
| 2621 | ;; completion-table-in-turn, we could return boundaries and |
| 2622 | ;; let some subsequent table return a list of completions. |
| 2623 | ;; FIXME: Maybe it should rather be fixed in |
| 2624 | ;; completion-table-in-turn instead, but it's difficult to |
| 2625 | ;; do it efficiently there. |
| 2626 | (when (try-completion (substring string beg) table nil) |
| 2627 | ;; Compute the boundaries of the subfield to which this |
| 2628 | ;; completion applies. |
| 2629 | (if (eq action 'metadata) |
| 2630 | '(metadata (category . environment-variable)) |
| 2631 | (let ((suffix (cdr action))) |
| 2632 | `(boundaries |
| 2633 | ,(or (match-beginning 2) (match-beginning 1)) |
| 2634 | . ,(when (string-match "[^[:alnum:]_]" suffix) |
| 2635 | (match-beginning 0))))))) |
| 2636 | (t |
| 2637 | (if (eq (aref string (1- beg)) ?{) |
| 2638 | (setq table (apply-partially 'completion-table-with-terminator |
| 2639 | "}" table))) |
| 2640 | ;; Even if file-name completion is case-insensitive, we want |
| 2641 | ;; envvar completion to be case-sensitive. |
| 2642 | (let ((completion-ignore-case nil)) |
| 2643 | (completion-table-with-context |
| 2644 | prefix table (substring string beg) nil action))))))) |
| 2645 | |
| 2646 | (defun completion-file-name-table (string pred action) |
| 2647 | "Completion table for file names." |
| 2648 | (condition-case nil |
| 2649 | (cond |
| 2650 | ((eq action 'metadata) '(metadata (category . file))) |
| 2651 | ((string-match-p "\\`~[^/\\]*\\'" string) |
| 2652 | (completion-table-with-context "~" |
| 2653 | (mapcar (lambda (u) (concat u "/")) |
| 2654 | (system-users)) |
| 2655 | (substring string 1) |
| 2656 | pred action)) |
| 2657 | ((eq (car-safe action) 'boundaries) |
| 2658 | (let ((start (length (file-name-directory string))) |
| 2659 | (end (string-match-p "/" (cdr action)))) |
| 2660 | `(boundaries |
| 2661 | ;; if `string' is "C:" in w32, (file-name-directory string) |
| 2662 | ;; returns "C:/", so `start' is 3 rather than 2. |
| 2663 | ;; Not quite sure what is The Right Fix, but clipping it |
| 2664 | ;; back to 2 will work for this particular case. We'll |
| 2665 | ;; see if we can come up with a better fix when we bump |
| 2666 | ;; into more such problematic cases. |
| 2667 | ,(min start (length string)) . ,end))) |
| 2668 | |
| 2669 | ((eq action 'lambda) |
| 2670 | (if (zerop (length string)) |
| 2671 | nil ;Not sure why it's here, but it probably doesn't harm. |
| 2672 | (funcall (or pred 'file-exists-p) string))) |
| 2673 | |
| 2674 | (t |
| 2675 | (let* ((name (file-name-nondirectory string)) |
| 2676 | (specdir (file-name-directory string)) |
| 2677 | (realdir (or specdir default-directory))) |
| 2678 | |
| 2679 | (cond |
| 2680 | ((null action) |
| 2681 | (let ((comp (file-name-completion name realdir pred))) |
| 2682 | (if (stringp comp) |
| 2683 | (concat specdir comp) |
| 2684 | comp))) |
| 2685 | |
| 2686 | ((eq action t) |
| 2687 | (let ((all (file-name-all-completions name realdir))) |
| 2688 | |
| 2689 | ;; Check the predicate, if necessary. |
| 2690 | (unless (memq pred '(nil file-exists-p)) |
| 2691 | (let ((comp ()) |
| 2692 | (pred |
| 2693 | (if (eq pred 'file-directory-p) |
| 2694 | ;; Brute-force speed up for directory checking: |
| 2695 | ;; Discard strings which don't end in a slash. |
| 2696 | (lambda (s) |
| 2697 | (let ((len (length s))) |
| 2698 | (and (> len 0) (eq (aref s (1- len)) ?/)))) |
| 2699 | ;; Must do it the hard (and slow) way. |
| 2700 | pred))) |
| 2701 | (let ((default-directory (expand-file-name realdir))) |
| 2702 | (dolist (tem all) |
| 2703 | (if (funcall pred tem) (push tem comp)))) |
| 2704 | (setq all (nreverse comp)))) |
| 2705 | |
| 2706 | all)))))) |
| 2707 | (file-error nil))) ;PCM often calls with invalid directories. |
| 2708 | |
| 2709 | (defvar read-file-name-predicate nil |
| 2710 | "Current predicate used by `read-file-name-internal'.") |
| 2711 | (make-obsolete-variable 'read-file-name-predicate |
| 2712 | "use the regular PRED argument" "23.2") |
| 2713 | |
| 2714 | (defun completion--sifn-requote (upos qstr) |
| 2715 | ;; We're looking for `qpos' such that: |
| 2716 | ;; (equal (substring (substitute-in-file-name qstr) 0 upos) |
| 2717 | ;; (substitute-in-file-name (substring qstr 0 qpos))) |
| 2718 | ;; Big problem here: we have to reverse engineer substitute-in-file-name to |
| 2719 | ;; find the position corresponding to UPOS in QSTR, but |
| 2720 | ;; substitute-in-file-name can do anything, depending on file-name-handlers. |
| 2721 | ;; substitute-in-file-name does the following kind of things: |
| 2722 | ;; - expand env-var references. |
| 2723 | ;; - turn backslashes into slashes. |
| 2724 | ;; - truncate some prefix of the input. |
| 2725 | ;; - rewrite some prefix. |
| 2726 | ;; Some of these operations are written in external libraries and we'd rather |
| 2727 | ;; not hard code any assumptions here about what they actually do. IOW, we |
| 2728 | ;; want to treat substitute-in-file-name as a black box, as much as possible. |
| 2729 | ;; Kind of like in rfn-eshadow-update-overlay, only worse. |
| 2730 | ;; Example of things we need to handle: |
| 2731 | ;; - Tramp (substitute-in-file-name "/foo:~/bar//baz") => "/scpc:foo:/baz". |
| 2732 | ;; - Cygwin (substitute-in-file-name "C:\bin") => "/usr/bin" |
| 2733 | ;; (substitute-in-file-name "C:\") => "/" |
| 2734 | ;; (substitute-in-file-name "C:\bi") => "/bi" |
| 2735 | (let* ((ustr (substitute-in-file-name qstr)) |
| 2736 | (uprefix (substring ustr 0 upos)) |
| 2737 | qprefix) |
| 2738 | ;; Main assumption: nothing after qpos should affect the text before upos, |
| 2739 | ;; so we can work our way backward from the end of qstr, one character |
| 2740 | ;; at a time. |
| 2741 | ;; Second assumptions: If qpos is far from the end this can be a bit slow, |
| 2742 | ;; so we speed it up by doing a first loop that skips a word at a time. |
| 2743 | ;; This word-sized loop is careful not to cut in the middle of env-vars. |
| 2744 | (while (let ((boundary (string-match "\\(\\$+{?\\)?\\w+\\W*\\'" qstr))) |
| 2745 | (and boundary |
| 2746 | (progn |
| 2747 | (setq qprefix (substring qstr 0 boundary)) |
| 2748 | (string-prefix-p uprefix |
| 2749 | (substitute-in-file-name qprefix))))) |
| 2750 | (setq qstr qprefix)) |
| 2751 | (let ((qpos (length qstr))) |
| 2752 | (while (and (> qpos 0) |
| 2753 | (string-prefix-p uprefix |
| 2754 | (substitute-in-file-name |
| 2755 | (substring qstr 0 (1- qpos))))) |
| 2756 | (setq qpos (1- qpos))) |
| 2757 | (cons qpos #'minibuffer--double-dollars)))) |
| 2758 | |
| 2759 | (defalias 'completion--file-name-table |
| 2760 | (completion-table-with-quoting #'completion-file-name-table |
| 2761 | #'substitute-in-file-name |
| 2762 | #'completion--sifn-requote) |
| 2763 | "Internal subroutine for `read-file-name'. Do not call this. |
| 2764 | This is a completion table for file names, like `completion-file-name-table' |
| 2765 | except that it passes the file name through `substitute-in-file-name'.") |
| 2766 | |
| 2767 | (defalias 'read-file-name-internal |
| 2768 | (completion-table-in-turn #'completion--embedded-envvar-table |
| 2769 | #'completion--file-name-table) |
| 2770 | "Internal subroutine for `read-file-name'. Do not call this.") |
| 2771 | |
| 2772 | (defvar read-file-name-function 'read-file-name-default |
| 2773 | "The function called by `read-file-name' to do its work. |
| 2774 | It should accept the same arguments as `read-file-name'.") |
| 2775 | |
| 2776 | (defcustom insert-default-directory t |
| 2777 | "Non-nil means when reading a filename start with default dir in minibuffer. |
| 2778 | |
| 2779 | When the initial minibuffer contents show a name of a file or a directory, |
| 2780 | typing RETURN without editing the initial contents is equivalent to typing |
| 2781 | the default file name. |
| 2782 | |
| 2783 | If this variable is non-nil, the minibuffer contents are always |
| 2784 | initially non-empty, and typing RETURN without editing will fetch the |
| 2785 | default name, if one is provided. Note however that this default name |
| 2786 | is not necessarily the same as initial contents inserted in the minibuffer, |
| 2787 | if the initial contents is just the default directory. |
| 2788 | |
| 2789 | If this variable is nil, the minibuffer often starts out empty. In |
| 2790 | that case you may have to explicitly fetch the next history element to |
| 2791 | request the default name; typing RETURN without editing will leave |
| 2792 | the minibuffer empty. |
| 2793 | |
| 2794 | For some commands, exiting with an empty minibuffer has a special meaning, |
| 2795 | such as making the current buffer visit no file in the case of |
| 2796 | `set-visited-file-name'." |
| 2797 | :type 'boolean) |
| 2798 | |
| 2799 | ;; Not always defined, but only called if next-read-file-uses-dialog-p says so. |
| 2800 | (declare-function x-file-dialog "xfns.c" |
| 2801 | (prompt dir &optional default-filename mustmatch only-dir-p)) |
| 2802 | |
| 2803 | (defun read-file-name--defaults (&optional dir initial) |
| 2804 | (let ((default |
| 2805 | (cond |
| 2806 | ;; With non-nil `initial', use `dir' as the first default. |
| 2807 | ;; Essentially, this mean reversing the normal order of the |
| 2808 | ;; current directory name and the current file name, i.e. |
| 2809 | ;; 1. with normal file reading: |
| 2810 | ;; 1.1. initial input is the current directory |
| 2811 | ;; 1.2. the first default is the current file name |
| 2812 | ;; 2. with non-nil `initial' (e.g. for `find-alternate-file'): |
| 2813 | ;; 2.2. initial input is the current file name |
| 2814 | ;; 2.1. the first default is the current directory |
| 2815 | (initial (abbreviate-file-name dir)) |
| 2816 | ;; In file buffers, try to get the current file name |
| 2817 | (buffer-file-name |
| 2818 | (abbreviate-file-name buffer-file-name)))) |
| 2819 | (file-name-at-point |
| 2820 | (run-hook-with-args-until-success 'file-name-at-point-functions))) |
| 2821 | (when file-name-at-point |
| 2822 | (setq default (delete-dups |
| 2823 | (delete "" (delq nil (list file-name-at-point default)))))) |
| 2824 | ;; Append new defaults to the end of existing `minibuffer-default'. |
| 2825 | (append |
| 2826 | (if (listp minibuffer-default) minibuffer-default (list minibuffer-default)) |
| 2827 | (if (listp default) default (list default))))) |
| 2828 | |
| 2829 | (defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate) |
| 2830 | "Read file name, prompting with PROMPT and completing in directory DIR. |
| 2831 | The return value is not expanded---you must call `expand-file-name' yourself. |
| 2832 | |
| 2833 | DIR is the directory to use for completing relative file names. |
| 2834 | It should be an absolute directory name, or nil (which means the |
| 2835 | current buffer's value of `default-directory'). |
| 2836 | |
| 2837 | DEFAULT-FILENAME specifies the default file name to return if the |
| 2838 | user exits the minibuffer with the same non-empty string inserted |
| 2839 | by this function. If DEFAULT-FILENAME is a string, that serves |
| 2840 | as the default. If DEFAULT-FILENAME is a list of strings, the |
| 2841 | first string is the default. If DEFAULT-FILENAME is omitted or |
| 2842 | nil, then if INITIAL is non-nil, the default is DIR combined with |
| 2843 | INITIAL; otherwise, if the current buffer is visiting a file, |
| 2844 | that file serves as the default; otherwise, the default is simply |
| 2845 | the string inserted into the minibuffer. |
| 2846 | |
| 2847 | If the user exits with an empty minibuffer, return an empty |
| 2848 | string. (This happens only if the user erases the pre-inserted |
| 2849 | contents, or if `insert-default-directory' is nil.) |
| 2850 | |
| 2851 | Fourth arg MUSTMATCH can take the following values: |
| 2852 | - nil means that the user can exit with any input. |
| 2853 | - t means that the user is not allowed to exit unless |
| 2854 | the input is (or completes to) an existing file. |
| 2855 | - `confirm' means that the user can exit with any input, but she needs |
| 2856 | to confirm her choice if the input is not an existing file. |
| 2857 | - `confirm-after-completion' means that the user can exit with any |
| 2858 | input, but she needs to confirm her choice if she called |
| 2859 | `minibuffer-complete' right before `minibuffer-complete-and-exit' |
| 2860 | and the input is not an existing file. |
| 2861 | - anything else behaves like t except that typing RET does not exit if it |
| 2862 | does non-null completion. |
| 2863 | |
| 2864 | Fifth arg INITIAL specifies text to start with. |
| 2865 | |
| 2866 | Sixth arg PREDICATE, if non-nil, should be a function of one |
| 2867 | argument; then a file name is considered an acceptable completion |
| 2868 | alternative only if PREDICATE returns non-nil with the file name |
| 2869 | as its argument. |
| 2870 | |
| 2871 | If this command was invoked with the mouse, use a graphical file |
| 2872 | dialog if `use-dialog-box' is non-nil, and the window system or X |
| 2873 | toolkit in use provides a file dialog box, and DIR is not a |
| 2874 | remote file. For graphical file dialogs, any of the special values |
| 2875 | of MUSTMATCH `confirm' and `confirm-after-completion' are |
| 2876 | treated as equivalent to nil. Some graphical file dialogs respect |
| 2877 | a MUSTMATCH value of t, and some do not (or it only has a cosmetic |
| 2878 | effect, and does not actually prevent the user from entering a |
| 2879 | non-existent file). |
| 2880 | |
| 2881 | See also `read-file-name-completion-ignore-case' |
| 2882 | and `read-file-name-function'." |
| 2883 | ;; If x-gtk-use-old-file-dialog = t (xg_get_file_with_selection), |
| 2884 | ;; then MUSTMATCH is enforced. But with newer Gtk |
| 2885 | ;; (xg_get_file_with_chooser), it only has a cosmetic effect. |
| 2886 | ;; The user can still type a non-existent file name. |
| 2887 | (funcall (or read-file-name-function #'read-file-name-default) |
| 2888 | prompt dir default-filename mustmatch initial predicate)) |
| 2889 | |
| 2890 | (defvar minibuffer-local-filename-syntax |
| 2891 | (let ((table (make-syntax-table)) |
| 2892 | (punctuation (car (string-to-syntax ".")))) |
| 2893 | ;; Convert all punctuation entries to symbol. |
| 2894 | (map-char-table (lambda (c syntax) |
| 2895 | (when (eq (car syntax) punctuation) |
| 2896 | (modify-syntax-entry c "_" table))) |
| 2897 | table) |
| 2898 | (mapc |
| 2899 | (lambda (c) |
| 2900 | (modify-syntax-entry c "." table)) |
| 2901 | '(?/ ?: ?\\)) |
| 2902 | table) |
| 2903 | "Syntax table used when reading a file name in the minibuffer.") |
| 2904 | |
| 2905 | ;; minibuffer-completing-file-name is a variable used internally in minibuf.c |
| 2906 | ;; to determine whether to use minibuffer-local-filename-completion-map or |
| 2907 | ;; minibuffer-local-completion-map. It shouldn't be exported to Elisp. |
| 2908 | ;; FIXME: Actually, it is also used in rfn-eshadow.el we'd otherwise have to |
| 2909 | ;; use (eq minibuffer-completion-table #'read-file-name-internal), which is |
| 2910 | ;; probably even worse. Maybe We should add some read-file-name-setup-hook |
| 2911 | ;; instead, but for now, let's keep this non-obsolete. |
| 2912 | ;;(make-obsolete-variable 'minibuffer-completing-file-name nil "future" 'get) |
| 2913 | |
| 2914 | (defun read-file-name-default (prompt &optional dir default-filename mustmatch initial predicate) |
| 2915 | "Default method for reading file names. |
| 2916 | See `read-file-name' for the meaning of the arguments." |
| 2917 | (unless dir (setq dir default-directory)) |
| 2918 | (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir))) |
| 2919 | (unless default-filename |
| 2920 | (setq default-filename (if initial (expand-file-name initial dir) |
| 2921 | buffer-file-name))) |
| 2922 | ;; If dir starts with user's homedir, change that to ~. |
| 2923 | (setq dir (abbreviate-file-name dir)) |
| 2924 | ;; Likewise for default-filename. |
| 2925 | (if default-filename |
| 2926 | (setq default-filename |
| 2927 | (if (consp default-filename) |
| 2928 | (mapcar 'abbreviate-file-name default-filename) |
| 2929 | (abbreviate-file-name default-filename)))) |
| 2930 | (let ((insdef (cond |
| 2931 | ((and insert-default-directory (stringp dir)) |
| 2932 | (if initial |
| 2933 | (cons (minibuffer--double-dollars (concat dir initial)) |
| 2934 | (length (minibuffer--double-dollars dir))) |
| 2935 | (minibuffer--double-dollars dir))) |
| 2936 | (initial (cons (minibuffer--double-dollars initial) 0))))) |
| 2937 | |
| 2938 | (let ((completion-ignore-case read-file-name-completion-ignore-case) |
| 2939 | (minibuffer-completing-file-name t) |
| 2940 | (pred (or predicate 'file-exists-p)) |
| 2941 | (add-to-history nil)) |
| 2942 | |
| 2943 | (let* ((val |
| 2944 | (if (or (not (next-read-file-uses-dialog-p)) |
| 2945 | ;; Graphical file dialogs can't handle remote |
| 2946 | ;; files (Bug#99). |
| 2947 | (file-remote-p dir)) |
| 2948 | ;; We used to pass `dir' to `read-file-name-internal' by |
| 2949 | ;; abusing the `predicate' argument. It's better to |
| 2950 | ;; just use `default-directory', but in order to avoid |
| 2951 | ;; changing `default-directory' in the current buffer, |
| 2952 | ;; we don't let-bind it. |
| 2953 | (let ((dir (file-name-as-directory |
| 2954 | (expand-file-name dir)))) |
| 2955 | (minibuffer-with-setup-hook |
| 2956 | (lambda () |
| 2957 | (setq default-directory dir) |
| 2958 | ;; When the first default in `minibuffer-default' |
| 2959 | ;; duplicates initial input `insdef', |
| 2960 | ;; reset `minibuffer-default' to nil. |
| 2961 | (when (equal (or (car-safe insdef) insdef) |
| 2962 | (or (car-safe minibuffer-default) |
| 2963 | minibuffer-default)) |
| 2964 | (setq minibuffer-default |
| 2965 | (cdr-safe minibuffer-default))) |
| 2966 | ;; On the first request on `M-n' fill |
| 2967 | ;; `minibuffer-default' with a list of defaults |
| 2968 | ;; relevant for file-name reading. |
| 2969 | (set (make-local-variable 'minibuffer-default-add-function) |
| 2970 | (lambda () |
| 2971 | (with-current-buffer |
| 2972 | (window-buffer (minibuffer-selected-window)) |
| 2973 | (read-file-name--defaults dir initial)))) |
| 2974 | (set-syntax-table minibuffer-local-filename-syntax)) |
| 2975 | (completing-read prompt 'read-file-name-internal |
| 2976 | pred mustmatch insdef |
| 2977 | 'file-name-history default-filename))) |
| 2978 | ;; If DEFAULT-FILENAME not supplied and DIR contains |
| 2979 | ;; a file name, split it. |
| 2980 | (let ((file (file-name-nondirectory dir)) |
| 2981 | ;; When using a dialog, revert to nil and non-nil |
| 2982 | ;; interpretation of mustmatch. confirm options |
| 2983 | ;; need to be interpreted as nil, otherwise |
| 2984 | ;; it is impossible to create new files using |
| 2985 | ;; dialogs with the default settings. |
| 2986 | (dialog-mustmatch |
| 2987 | (not (memq mustmatch |
| 2988 | '(nil confirm confirm-after-completion))))) |
| 2989 | (when (and (not default-filename) |
| 2990 | (not (zerop (length file)))) |
| 2991 | (setq default-filename file) |
| 2992 | (setq dir (file-name-directory dir))) |
| 2993 | (when default-filename |
| 2994 | (setq default-filename |
| 2995 | (expand-file-name (if (consp default-filename) |
| 2996 | (car default-filename) |
| 2997 | default-filename) |
| 2998 | dir))) |
| 2999 | (setq add-to-history t) |
| 3000 | (x-file-dialog prompt dir default-filename |
| 3001 | dialog-mustmatch |
| 3002 | (eq predicate 'file-directory-p))))) |
| 3003 | |
| 3004 | (replace-in-history (eq (car-safe file-name-history) val))) |
| 3005 | ;; If completing-read returned the inserted default string itself |
| 3006 | ;; (rather than a new string with the same contents), |
| 3007 | ;; it has to mean that the user typed RET with the minibuffer empty. |
| 3008 | ;; In that case, we really want to return "" |
| 3009 | ;; so that commands such as set-visited-file-name can distinguish. |
| 3010 | (when (consp default-filename) |
| 3011 | (setq default-filename (car default-filename))) |
| 3012 | (when (eq val default-filename) |
| 3013 | ;; In this case, completing-read has not added an element |
| 3014 | ;; to the history. Maybe we should. |
| 3015 | (if (not replace-in-history) |
| 3016 | (setq add-to-history t)) |
| 3017 | (setq val "")) |
| 3018 | (unless val (error "No file name specified")) |
| 3019 | |
| 3020 | (if (and default-filename |
| 3021 | (string-equal val (if (consp insdef) (car insdef) insdef))) |
| 3022 | (setq val default-filename)) |
| 3023 | (setq val (substitute-in-file-name val)) |
| 3024 | |
| 3025 | (if replace-in-history |
| 3026 | ;; Replace what Fcompleting_read added to the history |
| 3027 | ;; with what we will actually return. As an exception, |
| 3028 | ;; if that's the same as the second item in |
| 3029 | ;; file-name-history, it's really a repeat (Bug#4657). |
| 3030 | (let ((val1 (minibuffer--double-dollars val))) |
| 3031 | (if history-delete-duplicates |
| 3032 | (setcdr file-name-history |
| 3033 | (delete val1 (cdr file-name-history)))) |
| 3034 | (if (string= val1 (cadr file-name-history)) |
| 3035 | (pop file-name-history) |
| 3036 | (setcar file-name-history val1))) |
| 3037 | (if add-to-history |
| 3038 | ;; Add the value to the history--but not if it matches |
| 3039 | ;; the last value already there. |
| 3040 | (let ((val1 (minibuffer--double-dollars val))) |
| 3041 | (unless (and (consp file-name-history) |
| 3042 | (equal (car file-name-history) val1)) |
| 3043 | (setq file-name-history |
| 3044 | (cons val1 |
| 3045 | (if history-delete-duplicates |
| 3046 | (delete val1 file-name-history) |
| 3047 | file-name-history))))))) |
| 3048 | val)))) |
| 3049 | |
| 3050 | (defun internal-complete-buffer-except (&optional buffer) |
| 3051 | "Perform completion on all buffers excluding BUFFER. |
| 3052 | BUFFER nil or omitted means use the current buffer. |
| 3053 | Like `internal-complete-buffer', but removes BUFFER from the completion list." |
| 3054 | (let ((except (if (stringp buffer) buffer (buffer-name buffer)))) |
| 3055 | (apply-partially 'completion-table-with-predicate |
| 3056 | 'internal-complete-buffer |
| 3057 | (lambda (name) |
| 3058 | (not (equal (if (consp name) (car name) name) except))) |
| 3059 | nil))) |
| 3060 | |
| 3061 | ;;; Old-style completion, used in Emacs-21 and Emacs-22. |
| 3062 | |
| 3063 | (defun completion-emacs21-try-completion (string table pred _point) |
| 3064 | (let ((completion (try-completion string table pred))) |
| 3065 | (if (stringp completion) |
| 3066 | (cons completion (length completion)) |
| 3067 | completion))) |
| 3068 | |
| 3069 | (defun completion-emacs21-all-completions (string table pred _point) |
| 3070 | (completion-hilit-commonality |
| 3071 | (all-completions string table pred) |
| 3072 | (length string) |
| 3073 | (car (completion-boundaries string table pred "")))) |
| 3074 | |
| 3075 | (defun completion-emacs22-try-completion (string table pred point) |
| 3076 | (let ((suffix (substring string point)) |
| 3077 | (completion (try-completion (substring string 0 point) table pred))) |
| 3078 | (if (not (stringp completion)) |
| 3079 | completion |
| 3080 | ;; Merge a trailing / in completion with a / after point. |
| 3081 | ;; We used to only do it for word completion, but it seems to make |
| 3082 | ;; sense for all completions. |
| 3083 | ;; Actually, claiming this feature was part of Emacs-22 completion |
| 3084 | ;; is pushing it a bit: it was only done in minibuffer-completion-word, |
| 3085 | ;; which was (by default) not bound during file completion, where such |
| 3086 | ;; slashes are most likely to occur. |
| 3087 | (if (and (not (zerop (length completion))) |
| 3088 | (eq ?/ (aref completion (1- (length completion)))) |
| 3089 | (not (zerop (length suffix))) |
| 3090 | (eq ?/ (aref suffix 0))) |
| 3091 | ;; This leaves point after the / . |
| 3092 | (setq suffix (substring suffix 1))) |
| 3093 | (cons (concat completion suffix) (length completion))))) |
| 3094 | |
| 3095 | (defun completion-emacs22-all-completions (string table pred point) |
| 3096 | (let ((beforepoint (substring string 0 point))) |
| 3097 | (completion-hilit-commonality |
| 3098 | (all-completions beforepoint table pred) |
| 3099 | point |
| 3100 | (car (completion-boundaries beforepoint table pred ""))))) |
| 3101 | |
| 3102 | ;;; Basic completion. |
| 3103 | |
| 3104 | (defun completion--merge-suffix (completion point suffix) |
| 3105 | "Merge end of COMPLETION with beginning of SUFFIX. |
| 3106 | Simple generalization of the \"merge trailing /\" done in Emacs-22. |
| 3107 | Return the new suffix." |
| 3108 | (if (and (not (zerop (length suffix))) |
| 3109 | (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix) |
| 3110 | ;; Make sure we don't compress things to less |
| 3111 | ;; than we started with. |
| 3112 | point) |
| 3113 | ;; Just make sure we didn't match some other \n. |
| 3114 | (eq (match-end 1) (length completion))) |
| 3115 | (substring suffix (- (match-end 1) (match-beginning 1))) |
| 3116 | ;; Nothing to merge. |
| 3117 | suffix)) |
| 3118 | |
| 3119 | (defun completion-basic--pattern (beforepoint afterpoint bounds) |
| 3120 | (delete |
| 3121 | "" (list (substring beforepoint (car bounds)) |
| 3122 | 'point |
| 3123 | (substring afterpoint 0 (cdr bounds))))) |
| 3124 | |
| 3125 | (defun completion-basic-try-completion (string table pred point) |
| 3126 | (let* ((beforepoint (substring string 0 point)) |
| 3127 | (afterpoint (substring string point)) |
| 3128 | (bounds (completion-boundaries beforepoint table pred afterpoint))) |
| 3129 | (if (zerop (cdr bounds)) |
| 3130 | ;; `try-completion' may return a subtly different result |
| 3131 | ;; than `all+merge', so try to use it whenever possible. |
| 3132 | (let ((completion (try-completion beforepoint table pred))) |
| 3133 | (if (not (stringp completion)) |
| 3134 | completion |
| 3135 | (cons |
| 3136 | (concat completion |
| 3137 | (completion--merge-suffix completion point afterpoint)) |
| 3138 | (length completion)))) |
| 3139 | (let* ((suffix (substring afterpoint (cdr bounds))) |
| 3140 | (prefix (substring beforepoint 0 (car bounds))) |
| 3141 | (pattern (delete |
| 3142 | "" (list (substring beforepoint (car bounds)) |
| 3143 | 'point |
| 3144 | (substring afterpoint 0 (cdr bounds))))) |
| 3145 | (all (completion-pcm--all-completions prefix pattern table pred))) |
| 3146 | (if minibuffer-completing-file-name |
| 3147 | (setq all (completion-pcm--filename-try-filter all))) |
| 3148 | (completion-pcm--merge-try pattern all prefix suffix))))) |
| 3149 | |
| 3150 | (defun completion-basic-all-completions (string table pred point) |
| 3151 | (let* ((beforepoint (substring string 0 point)) |
| 3152 | (afterpoint (substring string point)) |
| 3153 | (bounds (completion-boundaries beforepoint table pred afterpoint)) |
| 3154 | ;; (suffix (substring afterpoint (cdr bounds))) |
| 3155 | (prefix (substring beforepoint 0 (car bounds))) |
| 3156 | (pattern (delete |
| 3157 | "" (list (substring beforepoint (car bounds)) |
| 3158 | 'point |
| 3159 | (substring afterpoint 0 (cdr bounds))))) |
| 3160 | (all (completion-pcm--all-completions prefix pattern table pred))) |
| 3161 | (completion-hilit-commonality all point (car bounds)))) |
| 3162 | |
| 3163 | ;;; Partial-completion-mode style completion. |
| 3164 | |
| 3165 | (defvar completion-pcm--delim-wild-regex nil |
| 3166 | "Regular expression matching delimiters controlling the partial-completion. |
| 3167 | Typically, this regular expression simply matches a delimiter, meaning |
| 3168 | that completion can add something at (match-beginning 0), but if it has |
| 3169 | a submatch 1, then completion can add something at (match-end 1). |
| 3170 | This is used when the delimiter needs to be of size zero (e.g. the transition |
| 3171 | from lowercase to uppercase characters).") |
| 3172 | |
| 3173 | (defun completion-pcm--prepare-delim-re (delims) |
| 3174 | (setq completion-pcm--delim-wild-regex (concat "[" delims "*]"))) |
| 3175 | |
| 3176 | (defcustom completion-pcm-word-delimiters "-_./:| " |
| 3177 | "A string of characters treated as word delimiters for completion. |
| 3178 | Some arcane rules: |
| 3179 | If `]' is in this string, it must come first. |
| 3180 | If `^' is in this string, it must not come first. |
| 3181 | If `-' is in this string, it must come first or right after `]'. |
| 3182 | In other words, if S is this string, then `[S]' must be a valid Emacs regular |
| 3183 | expression (not containing character ranges like `a-z')." |
| 3184 | :set (lambda (symbol value) |
| 3185 | (set-default symbol value) |
| 3186 | ;; Refresh other vars. |
| 3187 | (completion-pcm--prepare-delim-re value)) |
| 3188 | :initialize 'custom-initialize-reset |
| 3189 | :type 'string) |
| 3190 | |
| 3191 | (defcustom completion-pcm-complete-word-inserts-delimiters nil |
| 3192 | "Treat the SPC or - inserted by `minibuffer-complete-word' as delimiters. |
| 3193 | Those chars are treated as delimiters if this variable is non-nil. |
| 3194 | I.e. if non-nil, M-x SPC will just insert a \"-\" in the minibuffer, whereas |
| 3195 | if nil, it will list all possible commands in *Completions* because none of |
| 3196 | the commands start with a \"-\" or a SPC." |
| 3197 | :version "24.1" |
| 3198 | :type 'boolean) |
| 3199 | |
| 3200 | (defun completion-pcm--pattern-trivial-p (pattern) |
| 3201 | (and (stringp (car pattern)) |
| 3202 | ;; It can be followed by `point' and "" and still be trivial. |
| 3203 | (let ((trivial t)) |
| 3204 | (dolist (elem (cdr pattern)) |
| 3205 | (unless (member elem '(point "")) |
| 3206 | (setq trivial nil))) |
| 3207 | trivial))) |
| 3208 | |
| 3209 | (defun completion-pcm--string->pattern (string &optional point) |
| 3210 | "Split STRING into a pattern. |
| 3211 | A pattern is a list where each element is either a string |
| 3212 | or a symbol, see `completion-pcm--merge-completions'." |
| 3213 | (if (and point (< point (length string))) |
| 3214 | (let ((prefix (substring string 0 point)) |
| 3215 | (suffix (substring string point))) |
| 3216 | (append (completion-pcm--string->pattern prefix) |
| 3217 | '(point) |
| 3218 | (completion-pcm--string->pattern suffix))) |
| 3219 | (let* ((pattern nil) |
| 3220 | (p 0) |
| 3221 | (p0 p) |
| 3222 | (pending nil)) |
| 3223 | |
| 3224 | (while (and (setq p (string-match completion-pcm--delim-wild-regex |
| 3225 | string p)) |
| 3226 | (or completion-pcm-complete-word-inserts-delimiters |
| 3227 | ;; If the char was added by minibuffer-complete-word, |
| 3228 | ;; then don't treat it as a delimiter, otherwise |
| 3229 | ;; "M-x SPC" ends up inserting a "-" rather than listing |
| 3230 | ;; all completions. |
| 3231 | (not (get-text-property p 'completion-try-word string)))) |
| 3232 | ;; Usually, completion-pcm--delim-wild-regex matches a delimiter, |
| 3233 | ;; meaning that something can be added *before* it, but it can also |
| 3234 | ;; match a prefix and postfix, in which case something can be added |
| 3235 | ;; in-between (e.g. match [[:lower:]][[:upper:]]). |
| 3236 | ;; This is determined by the presence of a submatch-1 which delimits |
| 3237 | ;; the prefix. |
| 3238 | (if (match-end 1) (setq p (match-end 1))) |
| 3239 | (unless (= p0 p) |
| 3240 | (if pending (push pending pattern)) |
| 3241 | (push (substring string p0 p) pattern)) |
| 3242 | (setq pending nil) |
| 3243 | (if (eq (aref string p) ?*) |
| 3244 | (progn |
| 3245 | (push 'star pattern) |
| 3246 | (setq p0 (1+ p))) |
| 3247 | (push 'any pattern) |
| 3248 | (if (match-end 1) |
| 3249 | (setq p0 p) |
| 3250 | (push (substring string p (match-end 0)) pattern) |
| 3251 | ;; `any-delim' is used so that "a-b" also finds "array->beginning". |
| 3252 | (setq pending 'any-delim) |
| 3253 | (setq p0 (match-end 0)))) |
| 3254 | (setq p p0)) |
| 3255 | |
| 3256 | (when (> (length string) p0) |
| 3257 | (if pending (push pending pattern)) |
| 3258 | (push (substring string p0) pattern)) |
| 3259 | ;; An empty string might be erroneously added at the beginning. |
| 3260 | ;; It should be avoided properly, but it's so easy to remove it here. |
| 3261 | (delete "" (nreverse pattern))))) |
| 3262 | |
| 3263 | (defun completion-pcm--optimize-pattern (p) |
| 3264 | ;; Remove empty strings in a separate phase since otherwise a "" |
| 3265 | ;; might prevent some other optimization, as in '(any "" any). |
| 3266 | (setq p (delete "" p)) |
| 3267 | (let ((n '())) |
| 3268 | (while p |
| 3269 | (pcase p |
| 3270 | (`(,(and s1 (pred stringp)) ,(and s2 (pred stringp)) . ,rest) |
| 3271 | (setq p (cons (concat s1 s2) rest))) |
| 3272 | (`(,(and p1 (pred symbolp)) ,(and p2 (guard (eq p1 p2))) . ,_) |
| 3273 | (setq p (cdr p))) |
| 3274 | (`(star ,(pred symbolp) . ,rest) (setq p `(star . ,rest))) |
| 3275 | (`(,(pred symbolp) star . ,rest) (setq p `(star . ,rest))) |
| 3276 | (`(point ,(or `any `any-delim) . ,rest) (setq p `(point . ,rest))) |
| 3277 | (`(,(or `any `any-delim) point . ,rest) (setq p `(point . ,rest))) |
| 3278 | (`(any ,(or `any `any-delim) . ,rest) (setq p `(any . ,rest))) |
| 3279 | (`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'. |
| 3280 | (_ (push (pop p) n)))) |
| 3281 | (nreverse n))) |
| 3282 | |
| 3283 | (defun completion-pcm--pattern->regex (pattern &optional group) |
| 3284 | (let ((re |
| 3285 | (concat "\\`" |
| 3286 | (mapconcat |
| 3287 | (lambda (x) |
| 3288 | (cond |
| 3289 | ((stringp x) (regexp-quote x)) |
| 3290 | (t |
| 3291 | (let ((re (if (eq x 'any-delim) |
| 3292 | (concat completion-pcm--delim-wild-regex "*?") |
| 3293 | ".*?"))) |
| 3294 | (if (if (consp group) (memq x group) group) |
| 3295 | (concat "\\(" re "\\)") |
| 3296 | re))))) |
| 3297 | pattern |
| 3298 | "")))) |
| 3299 | ;; Avoid pathological backtracking. |
| 3300 | (while (string-match "\\.\\*\\?\\(?:\\\\[()]\\)*\\(\\.\\*\\?\\)" re) |
| 3301 | (setq re (replace-match "" t t re 1))) |
| 3302 | re)) |
| 3303 | |
| 3304 | (defun completion-pcm--all-completions (prefix pattern table pred) |
| 3305 | "Find all completions for PATTERN in TABLE obeying PRED. |
| 3306 | PATTERN is as returned by `completion-pcm--string->pattern'." |
| 3307 | ;; (cl-assert (= (car (completion-boundaries prefix table pred "")) |
| 3308 | ;; (length prefix))) |
| 3309 | ;; Find an initial list of possible completions. |
| 3310 | (if (completion-pcm--pattern-trivial-p pattern) |
| 3311 | |
| 3312 | ;; Minibuffer contains no delimiters -- simple case! |
| 3313 | (all-completions (concat prefix (car pattern)) table pred) |
| 3314 | |
| 3315 | ;; Use all-completions to do an initial cull. This is a big win, |
| 3316 | ;; since all-completions is written in C! |
| 3317 | (let* (;; Convert search pattern to a standard regular expression. |
| 3318 | (regex (completion-pcm--pattern->regex pattern)) |
| 3319 | (case-fold-search completion-ignore-case) |
| 3320 | (completion-regexp-list (cons regex completion-regexp-list)) |
| 3321 | (compl (all-completions |
| 3322 | (concat prefix |
| 3323 | (if (stringp (car pattern)) (car pattern) "")) |
| 3324 | table pred))) |
| 3325 | (if (not (functionp table)) |
| 3326 | ;; The internal functions already obeyed completion-regexp-list. |
| 3327 | compl |
| 3328 | (let ((poss ())) |
| 3329 | (dolist (c compl) |
| 3330 | (when (string-match-p regex c) (push c poss))) |
| 3331 | poss))))) |
| 3332 | |
| 3333 | (defun completion-pcm--hilit-commonality (pattern completions) |
| 3334 | (when completions |
| 3335 | (let* ((re (completion-pcm--pattern->regex pattern '(point))) |
| 3336 | (case-fold-search completion-ignore-case)) |
| 3337 | (mapcar |
| 3338 | (lambda (str) |
| 3339 | ;; Don't modify the string itself. |
| 3340 | (setq str (copy-sequence str)) |
| 3341 | (unless (string-match re str) |
| 3342 | (error "Internal error: %s does not match %s" re str)) |
| 3343 | (let ((pos (or (match-beginning 1) (match-end 0)))) |
| 3344 | (put-text-property 0 pos |
| 3345 | 'font-lock-face 'completions-common-part |
| 3346 | str) |
| 3347 | (if (> (length str) pos) |
| 3348 | (put-text-property pos (1+ pos) |
| 3349 | 'font-lock-face 'completions-first-difference |
| 3350 | str))) |
| 3351 | str) |
| 3352 | completions)))) |
| 3353 | |
| 3354 | (defun completion-pcm--find-all-completions (string table pred point |
| 3355 | &optional filter) |
| 3356 | "Find all completions for STRING at POINT in TABLE, satisfying PRED. |
| 3357 | POINT is a position inside STRING. |
| 3358 | FILTER is a function applied to the return value, that can be used, e.g. to |
| 3359 | filter out additional entries (because TABLE might not obey PRED)." |
| 3360 | (unless filter (setq filter 'identity)) |
| 3361 | (let* ((beforepoint (substring string 0 point)) |
| 3362 | (afterpoint (substring string point)) |
| 3363 | (bounds (completion-boundaries beforepoint table pred afterpoint)) |
| 3364 | (prefix (substring beforepoint 0 (car bounds))) |
| 3365 | (suffix (substring afterpoint (cdr bounds))) |
| 3366 | firsterror) |
| 3367 | (setq string (substring string (car bounds) (+ point (cdr bounds)))) |
| 3368 | (let* ((relpoint (- point (car bounds))) |
| 3369 | (pattern (completion-pcm--string->pattern string relpoint)) |
| 3370 | (all (condition-case-unless-debug err |
| 3371 | (funcall filter |
| 3372 | (completion-pcm--all-completions |
| 3373 | prefix pattern table pred)) |
| 3374 | (error (setq firsterror err) nil)))) |
| 3375 | (when (and (null all) |
| 3376 | (> (car bounds) 0) |
| 3377 | (null (ignore-errors (try-completion prefix table pred)))) |
| 3378 | ;; The prefix has no completions at all, so we should try and fix |
| 3379 | ;; that first. |
| 3380 | (let ((substring (substring prefix 0 -1))) |
| 3381 | (pcase-let ((`(,subpat ,suball ,subprefix ,_subsuffix) |
| 3382 | (completion-pcm--find-all-completions |
| 3383 | substring table pred (length substring) filter))) |
| 3384 | (let ((sep (aref prefix (1- (length prefix)))) |
| 3385 | ;; Text that goes between the new submatches and the |
| 3386 | ;; completion substring. |
| 3387 | (between nil)) |
| 3388 | ;; Eliminate submatches that don't end with the separator. |
| 3389 | (dolist (submatch (prog1 suball (setq suball ()))) |
| 3390 | (when (eq sep (aref submatch (1- (length submatch)))) |
| 3391 | (push submatch suball))) |
| 3392 | (when suball |
| 3393 | ;; Update the boundaries and corresponding pattern. |
| 3394 | ;; We assume that all submatches result in the same boundaries |
| 3395 | ;; since we wouldn't know how to merge them otherwise anyway. |
| 3396 | ;; FIXME: COMPLETE REWRITE!!! |
| 3397 | (let* ((newbeforepoint |
| 3398 | (concat subprefix (car suball) |
| 3399 | (substring string 0 relpoint))) |
| 3400 | (leftbound (+ (length subprefix) (length (car suball)))) |
| 3401 | (newbounds (completion-boundaries |
| 3402 | newbeforepoint table pred afterpoint))) |
| 3403 | (unless (or (and (eq (cdr bounds) (cdr newbounds)) |
| 3404 | (eq (car newbounds) leftbound)) |
| 3405 | ;; Refuse new boundaries if they step over |
| 3406 | ;; the submatch. |
| 3407 | (< (car newbounds) leftbound)) |
| 3408 | ;; The new completed prefix does change the boundaries |
| 3409 | ;; of the completed substring. |
| 3410 | (setq suffix (substring afterpoint (cdr newbounds))) |
| 3411 | (setq string |
| 3412 | (concat (substring newbeforepoint (car newbounds)) |
| 3413 | (substring afterpoint 0 (cdr newbounds)))) |
| 3414 | (setq between (substring newbeforepoint leftbound |
| 3415 | (car newbounds))) |
| 3416 | (setq pattern (completion-pcm--string->pattern |
| 3417 | string |
| 3418 | (- (length newbeforepoint) |
| 3419 | (car newbounds))))) |
| 3420 | (dolist (submatch suball) |
| 3421 | (setq all (nconc |
| 3422 | (mapcar |
| 3423 | (lambda (s) (concat submatch between s)) |
| 3424 | (funcall filter |
| 3425 | (completion-pcm--all-completions |
| 3426 | (concat subprefix submatch between) |
| 3427 | pattern table pred))) |
| 3428 | all))) |
| 3429 | ;; FIXME: This can come in handy for try-completion, |
| 3430 | ;; but isn't right for all-completions, since it lists |
| 3431 | ;; invalid completions. |
| 3432 | ;; (unless all |
| 3433 | ;; ;; Even though we found expansions in the prefix, none |
| 3434 | ;; ;; leads to a valid completion. |
| 3435 | ;; ;; Let's keep the expansions, tho. |
| 3436 | ;; (dolist (submatch suball) |
| 3437 | ;; (push (concat submatch between newsubstring) all))) |
| 3438 | )) |
| 3439 | (setq pattern (append subpat (list 'any (string sep)) |
| 3440 | (if between (list between)) pattern)) |
| 3441 | (setq prefix subprefix))))) |
| 3442 | (if (and (null all) firsterror) |
| 3443 | (signal (car firsterror) (cdr firsterror)) |
| 3444 | (list pattern all prefix suffix))))) |
| 3445 | |
| 3446 | (defun completion-pcm-all-completions (string table pred point) |
| 3447 | (pcase-let ((`(,pattern ,all ,prefix ,_suffix) |
| 3448 | (completion-pcm--find-all-completions string table pred point))) |
| 3449 | (when all |
| 3450 | (nconc (completion-pcm--hilit-commonality pattern all) |
| 3451 | (length prefix))))) |
| 3452 | |
| 3453 | (defun completion--common-suffix (strs) |
| 3454 | "Return the common suffix of the strings STRS." |
| 3455 | (nreverse (try-completion "" (mapcar #'reverse strs)))) |
| 3456 | |
| 3457 | (defun completion-pcm--merge-completions (strs pattern) |
| 3458 | "Extract the commonality in STRS, with the help of PATTERN. |
| 3459 | PATTERN can contain strings and symbols chosen among `star', `any', `point', |
| 3460 | and `prefix'. They all match anything (aka \".*\") but are merged differently: |
| 3461 | `any' only grows from the left (when matching \"a1b\" and \"a2b\" it gets |
| 3462 | completed to just \"a\"). |
| 3463 | `prefix' only grows from the right (when matching \"a1b\" and \"a2b\" it gets |
| 3464 | completed to just \"b\"). |
| 3465 | `star' grows from both ends and is reified into a \"*\" (when matching \"a1b\" |
| 3466 | and \"a2b\" it gets completed to \"a*b\"). |
| 3467 | `point' is like `star' except that it gets reified as the position of point |
| 3468 | instead of being reified as a \"*\" character. |
| 3469 | The underlying idea is that we should return a string which still matches |
| 3470 | the same set of elements." |
| 3471 | ;; When completing while ignoring case, we want to try and avoid |
| 3472 | ;; completing "fo" to "foO" when completing against "FOO" (bug#4219). |
| 3473 | ;; So we try and make sure that the string we return is all made up |
| 3474 | ;; of text from the completions rather than part from the |
| 3475 | ;; completions and part from the input. |
| 3476 | ;; FIXME: This reduces the problems of inconsistent capitalization |
| 3477 | ;; but it doesn't fully fix it: we may still end up completing |
| 3478 | ;; "fo-ba" to "foo-BAR" or "FOO-bar" when completing against |
| 3479 | ;; '("foo-barr" "FOO-BARD"). |
| 3480 | (cond |
| 3481 | ((null (cdr strs)) (list (car strs))) |
| 3482 | (t |
| 3483 | (let ((re (completion-pcm--pattern->regex pattern 'group)) |
| 3484 | (ccs ())) ;Chopped completions. |
| 3485 | |
| 3486 | ;; First chop each string into the parts corresponding to each |
| 3487 | ;; non-constant element of `pattern', using regexp-matching. |
| 3488 | (let ((case-fold-search completion-ignore-case)) |
| 3489 | (dolist (str strs) |
| 3490 | (unless (string-match re str) |
| 3491 | (error "Internal error: %s doesn't match %s" str re)) |
| 3492 | (let ((chopped ()) |
| 3493 | (last 0) |
| 3494 | (i 1) |
| 3495 | next) |
| 3496 | (while (setq next (match-end i)) |
| 3497 | (push (substring str last next) chopped) |
| 3498 | (setq last next) |
| 3499 | (setq i (1+ i))) |
| 3500 | ;; Add the text corresponding to the implicit trailing `any'. |
| 3501 | (push (substring str last) chopped) |
| 3502 | (push (nreverse chopped) ccs)))) |
| 3503 | |
| 3504 | ;; Then for each of those non-constant elements, extract the |
| 3505 | ;; commonality between them. |
| 3506 | (let ((res ()) |
| 3507 | (fixed "")) |
| 3508 | ;; Make the implicit trailing `any' explicit. |
| 3509 | (dolist (elem (append pattern '(any))) |
| 3510 | (if (stringp elem) |
| 3511 | (setq fixed (concat fixed elem)) |
| 3512 | (let ((comps ())) |
| 3513 | (dolist (cc (prog1 ccs (setq ccs nil))) |
| 3514 | (push (car cc) comps) |
| 3515 | (push (cdr cc) ccs)) |
| 3516 | ;; Might improve the likelihood to avoid choosing |
| 3517 | ;; different capitalizations in different parts. |
| 3518 | ;; In practice, it doesn't seem to make any difference. |
| 3519 | (setq ccs (nreverse ccs)) |
| 3520 | (let* ((prefix (try-completion fixed comps)) |
| 3521 | (unique (or (and (eq prefix t) (setq prefix fixed)) |
| 3522 | (eq t (try-completion prefix comps))))) |
| 3523 | (unless (or (eq elem 'prefix) |
| 3524 | (equal prefix "")) |
| 3525 | (push prefix res)) |
| 3526 | ;; If there's only one completion, `elem' is not useful |
| 3527 | ;; any more: it can only match the empty string. |
| 3528 | ;; FIXME: in some cases, it may be necessary to turn an |
| 3529 | ;; `any' into a `star' because the surrounding context has |
| 3530 | ;; changed such that string->pattern wouldn't add an `any' |
| 3531 | ;; here any more. |
| 3532 | (unless unique |
| 3533 | (push elem res) |
| 3534 | ;; Extract common suffix additionally to common prefix. |
| 3535 | ;; Don't do it for `any' since it could lead to a merged |
| 3536 | ;; completion that doesn't itself match the candidates. |
| 3537 | (when (and (memq elem '(star point prefix)) |
| 3538 | ;; If prefix is one of the completions, there's no |
| 3539 | ;; suffix left to find. |
| 3540 | (not (assoc-string prefix comps t))) |
| 3541 | (let ((suffix |
| 3542 | (completion--common-suffix |
| 3543 | (if (zerop (length prefix)) comps |
| 3544 | ;; Ignore the chars in the common prefix, so we |
| 3545 | ;; don't merge '("abc" "abbc") as "ab*bc". |
| 3546 | (let ((skip (length prefix))) |
| 3547 | (mapcar (lambda (str) (substring str skip)) |
| 3548 | comps)))))) |
| 3549 | (cl-assert (stringp suffix)) |
| 3550 | (unless (equal suffix "") |
| 3551 | (push suffix res))))) |
| 3552 | (setq fixed ""))))) |
| 3553 | ;; We return it in reverse order. |
| 3554 | res))))) |
| 3555 | |
| 3556 | (defun completion-pcm--pattern->string (pattern) |
| 3557 | (mapconcat (lambda (x) (cond |
| 3558 | ((stringp x) x) |
| 3559 | ((eq x 'star) "*") |
| 3560 | (t ""))) ;any, point, prefix. |
| 3561 | pattern |
| 3562 | "")) |
| 3563 | |
| 3564 | ;; We want to provide the functionality of `try', but we use `all' |
| 3565 | ;; and then merge it. In most cases, this works perfectly, but |
| 3566 | ;; if the completion table doesn't consider the same completions in |
| 3567 | ;; `try' as in `all', then we have a problem. The most common such |
| 3568 | ;; case is for filename completion where completion-ignored-extensions |
| 3569 | ;; is only obeyed by the `try' code. We paper over the difference |
| 3570 | ;; here. Note that it is not quite right either: if the completion |
| 3571 | ;; table uses completion-table-in-turn, this filtering may take place |
| 3572 | ;; too late to correctly fallback from the first to the |
| 3573 | ;; second alternative. |
| 3574 | (defun completion-pcm--filename-try-filter (all) |
| 3575 | "Filter to adjust `all' file completion to the behavior of `try'." |
| 3576 | (when all |
| 3577 | (let ((try ()) |
| 3578 | (re (concat "\\(?:\\`\\.\\.?/\\|" |
| 3579 | (regexp-opt completion-ignored-extensions) |
| 3580 | "\\)\\'"))) |
| 3581 | (dolist (f all) |
| 3582 | (unless (string-match-p re f) (push f try))) |
| 3583 | (or try all)))) |
| 3584 | |
| 3585 | |
| 3586 | (defun completion-pcm--merge-try (pattern all prefix suffix) |
| 3587 | (cond |
| 3588 | ((not (consp all)) all) |
| 3589 | ((and (not (consp (cdr all))) ;Only one completion. |
| 3590 | ;; Ignore completion-ignore-case here. |
| 3591 | (equal (completion-pcm--pattern->string pattern) (car all))) |
| 3592 | t) |
| 3593 | (t |
| 3594 | (let* ((mergedpat (completion-pcm--merge-completions all pattern)) |
| 3595 | ;; `mergedpat' is in reverse order. Place new point (by |
| 3596 | ;; order of preference) either at the old point, or at |
| 3597 | ;; the last place where there's something to choose, or |
| 3598 | ;; at the very end. |
| 3599 | (pointpat (or (memq 'point mergedpat) |
| 3600 | (memq 'any mergedpat) |
| 3601 | (memq 'star mergedpat) |
| 3602 | ;; Not `prefix'. |
| 3603 | mergedpat)) |
| 3604 | ;; New pos from the start. |
| 3605 | (newpos (length (completion-pcm--pattern->string pointpat))) |
| 3606 | ;; Do it afterwards because it changes `pointpat' by side effect. |
| 3607 | (merged (completion-pcm--pattern->string (nreverse mergedpat)))) |
| 3608 | |
| 3609 | (setq suffix (completion--merge-suffix |
| 3610 | ;; The second arg should ideally be "the position right |
| 3611 | ;; after the last char of `merged' that comes from the text |
| 3612 | ;; to be completed". But completion-pcm--merge-completions |
| 3613 | ;; currently doesn't give us that info. So instead we just |
| 3614 | ;; use the "last but one" position, which tends to work |
| 3615 | ;; well in practice since `suffix' always starts |
| 3616 | ;; with a boundary and we hence mostly/only care about |
| 3617 | ;; merging this boundary (bug#15419). |
| 3618 | merged (max 0 (1- (length merged))) suffix)) |
| 3619 | (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) |
| 3620 | |
| 3621 | (defun completion-pcm-try-completion (string table pred point) |
| 3622 | (pcase-let ((`(,pattern ,all ,prefix ,suffix) |
| 3623 | (completion-pcm--find-all-completions |
| 3624 | string table pred point |
| 3625 | (if minibuffer-completing-file-name |
| 3626 | 'completion-pcm--filename-try-filter)))) |
| 3627 | (completion-pcm--merge-try pattern all prefix suffix))) |
| 3628 | |
| 3629 | ;;; Substring completion |
| 3630 | ;; Mostly derived from the code of `basic' completion. |
| 3631 | |
| 3632 | (defun completion-substring--all-completions (string table pred point) |
| 3633 | (let* ((beforepoint (substring string 0 point)) |
| 3634 | (afterpoint (substring string point)) |
| 3635 | (bounds (completion-boundaries beforepoint table pred afterpoint)) |
| 3636 | (suffix (substring afterpoint (cdr bounds))) |
| 3637 | (prefix (substring beforepoint 0 (car bounds))) |
| 3638 | (basic-pattern (completion-basic--pattern |
| 3639 | beforepoint afterpoint bounds)) |
| 3640 | (pattern (if (not (stringp (car basic-pattern))) |
| 3641 | basic-pattern |
| 3642 | (cons 'prefix basic-pattern))) |
| 3643 | (all (completion-pcm--all-completions prefix pattern table pred))) |
| 3644 | (list all pattern prefix suffix (car bounds)))) |
| 3645 | |
| 3646 | (defun completion-substring-try-completion (string table pred point) |
| 3647 | (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds) |
| 3648 | (completion-substring--all-completions |
| 3649 | string table pred point))) |
| 3650 | (if minibuffer-completing-file-name |
| 3651 | (setq all (completion-pcm--filename-try-filter all))) |
| 3652 | (completion-pcm--merge-try pattern all prefix suffix))) |
| 3653 | |
| 3654 | (defun completion-substring-all-completions (string table pred point) |
| 3655 | (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds) |
| 3656 | (completion-substring--all-completions |
| 3657 | string table pred point))) |
| 3658 | (when all |
| 3659 | (nconc (completion-pcm--hilit-commonality pattern all) |
| 3660 | (length prefix))))) |
| 3661 | |
| 3662 | ;; Initials completion |
| 3663 | ;; Complete /ums to /usr/monnier/src or lch to list-command-history. |
| 3664 | |
| 3665 | (defun completion-initials-expand (str table pred) |
| 3666 | (let ((bounds (completion-boundaries str table pred ""))) |
| 3667 | (unless (or (zerop (length str)) |
| 3668 | ;; Only check within the boundaries, since the |
| 3669 | ;; boundary char (e.g. /) might be in delim-regexp. |
| 3670 | (string-match completion-pcm--delim-wild-regex str |
| 3671 | (car bounds))) |
| 3672 | (if (zerop (car bounds)) |
| 3673 | (mapconcat 'string str "-") |
| 3674 | ;; If there's a boundary, it's trickier. The main use-case |
| 3675 | ;; we consider here is file-name completion. We'd like |
| 3676 | ;; to expand ~/eee to ~/e/e/e and /eee to /e/e/e. |
| 3677 | ;; But at the same time, we don't want /usr/share/ae to expand |
| 3678 | ;; to /usr/share/a/e just because we mistyped "ae" for "ar", |
| 3679 | ;; so we probably don't want initials to touch anything that |
| 3680 | ;; looks like /usr/share/foo. As a heuristic, we just check that |
| 3681 | ;; the text before the boundary char is at most 1 char. |
| 3682 | ;; This allows both ~/eee and /eee and not much more. |
| 3683 | ;; FIXME: It sadly also disallows the use of ~/eee when that's |
| 3684 | ;; embedded within something else (e.g. "(~/eee" in Info node |
| 3685 | ;; completion or "ancestor:/eee" in bzr-revision completion). |
| 3686 | (when (< (car bounds) 3) |
| 3687 | (let ((sep (substring str (1- (car bounds)) (car bounds)))) |
| 3688 | ;; FIXME: the above string-match checks the whole string, whereas |
| 3689 | ;; we end up only caring about the after-boundary part. |
| 3690 | (concat (substring str 0 (car bounds)) |
| 3691 | (mapconcat 'string (substring str (car bounds)) sep)))))))) |
| 3692 | |
| 3693 | (defun completion-initials-all-completions (string table pred _point) |
| 3694 | (let ((newstr (completion-initials-expand string table pred))) |
| 3695 | (when newstr |
| 3696 | (completion-pcm-all-completions newstr table pred (length newstr))))) |
| 3697 | |
| 3698 | (defun completion-initials-try-completion (string table pred _point) |
| 3699 | (let ((newstr (completion-initials-expand string table pred))) |
| 3700 | (when newstr |
| 3701 | (completion-pcm-try-completion newstr table pred (length newstr))))) |
| 3702 | \f |
| 3703 | (defvar completing-read-function 'completing-read-default |
| 3704 | "The function called by `completing-read' to do its work. |
| 3705 | It should accept the same arguments as `completing-read'.") |
| 3706 | |
| 3707 | (defun completing-read-default (prompt collection &optional predicate |
| 3708 | require-match initial-input |
| 3709 | hist def inherit-input-method) |
| 3710 | "Default method for reading from the minibuffer with completion. |
| 3711 | See `completing-read' for the meaning of the arguments." |
| 3712 | |
| 3713 | (when (consp initial-input) |
| 3714 | (setq initial-input |
| 3715 | (cons (car initial-input) |
| 3716 | ;; `completing-read' uses 0-based index while |
| 3717 | ;; `read-from-minibuffer' uses 1-based index. |
| 3718 | (1+ (cdr initial-input))))) |
| 3719 | |
| 3720 | (let* ((minibuffer-completion-table collection) |
| 3721 | (minibuffer-completion-predicate predicate) |
| 3722 | (minibuffer-completion-confirm (unless (eq require-match t) |
| 3723 | require-match)) |
| 3724 | (base-keymap (if require-match |
| 3725 | minibuffer-local-must-match-map |
| 3726 | minibuffer-local-completion-map)) |
| 3727 | (keymap (if (memq minibuffer-completing-file-name '(nil lambda)) |
| 3728 | base-keymap |
| 3729 | ;; Layer minibuffer-local-filename-completion-map |
| 3730 | ;; on top of the base map. |
| 3731 | (make-composed-keymap |
| 3732 | minibuffer-local-filename-completion-map |
| 3733 | ;; Set base-keymap as the parent, so that nil bindings |
| 3734 | ;; in minibuffer-local-filename-completion-map can |
| 3735 | ;; override bindings in base-keymap. |
| 3736 | base-keymap))) |
| 3737 | (result (read-from-minibuffer prompt initial-input keymap |
| 3738 | nil hist def inherit-input-method))) |
| 3739 | (when (and (equal result "") def) |
| 3740 | (setq result (if (consp def) (car def) def))) |
| 3741 | result)) |
| 3742 | \f |
| 3743 | ;; Miscellaneous |
| 3744 | |
| 3745 | (defun minibuffer-insert-file-name-at-point () |
| 3746 | "Get a file name at point in original buffer and insert it to minibuffer." |
| 3747 | (interactive) |
| 3748 | (let ((file-name-at-point |
| 3749 | (with-current-buffer (window-buffer (minibuffer-selected-window)) |
| 3750 | (run-hook-with-args-until-success 'file-name-at-point-functions)))) |
| 3751 | (when file-name-at-point |
| 3752 | (insert file-name-at-point)))) |
| 3753 | |
| 3754 | (provide 'minibuffer) |
| 3755 | |
| 3756 | ;;; minibuffer.el ends here |