X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/fb9f7146677ca0d6f03ca88dd8cd39bc3733682d..3958758036f64a1c93728ab0a2cb9ea872c59e35:/lisp/minibuffer.el diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 0d2815e535..e588964a65 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -38,7 +38,7 @@ ;;; Bugs: -;; - completion-all-sorted-completions list all the completions, whereas +;; - completion-all-sorted-completions lists all the completions, whereas ;; it should only lists the ones that `try-completion' would consider. ;; E.g. it should honor completion-ignored-extensions. ;; - choose-completion can't automatically figure out the boundaries @@ -145,7 +145,7 @@ Like CL's `some'." (let ((firsterror nil) res) (while (and (not res) xs) - (condition-case err + (condition-case-unless-debug err (setq res (funcall fun (pop xs))) (error (unless firsterror (setq firsterror err)) nil))) (or res @@ -525,7 +525,7 @@ for use at QPOS." (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case))) (defun completion--twq-all (string ustring completions boundary - unquote requote) + _unquote requote) (when completions (pcase-let* ((prefix @@ -568,6 +568,17 @@ for use at QPOS." (cl-assert (string-prefix-p prefix completion 'ignore-case) t) (let* ((new (substring completion (length prefix))) (qnew (funcall qfun new)) + (qprefix + (if (not completion-ignore-case) + qprefix + ;; Make qprefix inherit the case from `completion'. + (let* ((rest (substring completion + 0 (length prefix))) + (qrest (funcall qfun rest))) + (if (completion--string-equal-p qprefix qrest) + (propertize qrest 'face + 'completions-common-part) + qprefix)))) (qcompletion (concat qprefix qnew))) ;; FIXME: Similarly here, Cygwin's mapping trips this ;; assertion. @@ -612,7 +623,8 @@ If ARGS are provided, then pass MESSAGE through `format'." (message nil))) ;; Clear out any old echo-area message to make way for our new thing. (message nil) - (setq message (if (and (null args) (string-match-p "\\` *\\[.+\\]\\'" message)) + (setq message (if (and (null args) + (string-match-p "\\` *\\[.+\\]\\'" message)) ;; Make sure we can put-text-property. (copy-sequence message) (concat " [" message "]"))) @@ -638,8 +650,9 @@ If ARGS are provided, then pass MESSAGE through `format'." (defun minibuffer-completion-contents () "Return the user input in a minibuffer before point as a string. -That is what completion commands operate on." - (buffer-substring (field-beginning) (point))) +In Emacs-22, that was what completion commands operated on." + (declare (obsolete nil "24.4")) + (buffer-substring (minibuffer-prompt-end) (point))) (defun delete-minibuffer-contents () "Delete all user input in a minibuffer. @@ -658,8 +671,7 @@ If the value is t the *Completion* buffer is displayed whenever completion is requested but cannot be done. If the value is `lazy', the *Completions* buffer is only displayed after the second failed attempt to complete." - :type '(choice (const nil) (const t) (const lazy)) - :group 'minibuffer) + :type '(choice (const nil) (const t) (const lazy))) (defconst completion-styles-alist '((emacs21 @@ -738,7 +750,6 @@ The available styles are listed in `completion-styles-alist'. Note that `completion-category-overrides' may override these styles for specific categories, such as files, buffers, etc." :type completion--styles-type - :group 'minibuffer :version "23.1") (defcustom completion-category-overrides @@ -868,7 +879,7 @@ Moves point to the end of the new text." (defcustom completion-cycle-threshold nil "Number of completion candidates below which cycling is used. -Depending on this setting `minibuffer-complete' may use cycling, +Depending on this setting `completion-in-region' may use cycling, like `minibuffer-force-complete'. If nil, cycling is never used. If t, cycling is always used. @@ -882,8 +893,7 @@ completion candidates than this number." (over (assq 'cycle (cdr (assq cat completion-category-overrides))))) (if over (cdr over) completion-cycle-threshold))) -(defvar completion-all-sorted-completions nil) -(make-variable-buffer-local 'completion-all-sorted-completions) +(defvar-local completion-all-sorted-completions nil) (defvar-local completion--all-sorted-completions-location nil) (defvar completion-cycling nil) @@ -894,8 +904,8 @@ completion candidates than this number." (if completion-show-inline-help (minibuffer-message msg))) -(defun completion--do-completion (&optional try-completion-function - expect-exact) +(defun completion--do-completion (beg end &optional + try-completion-function expect-exact) "Do the completion and return a summary of what happened. M = completion was performed, the text was Modified. C = there were available Completions. @@ -914,9 +924,7 @@ E = after completion we now have an Exact match. TRY-COMPLETION-FUNCTION is a function to use in place of `try-completion'. EXPECT-EXACT, if non-nil, means that there is no need to tell the user when the buffer's text is already an exact match." - (let* ((beg (field-beginning)) - (end (field-end)) - (string (buffer-substring beg end)) + (let* ((string (buffer-substring beg end)) (md (completion--field-metadata beg)) (comp (funcall (or try-completion-function 'completion-try-completion) @@ -951,7 +959,8 @@ when the buffer's text is already an exact match." (if unchanged (goto-char end) ;; Insert in minibuffer the chars we got. - (completion--replace beg end completion)) + (completion--replace beg end completion) + (setq end (+ beg (length completion)))) ;; Move point to its completion-mandated destination. (forward-char (- comp-pos (length completion))) @@ -960,7 +969,8 @@ when the buffer's text is already an exact match." ;; whether this is a unique completion or not, so try again using ;; the real case (this shouldn't recurse again, because the next ;; time try-completion will return either t or the exact string). - (completion--do-completion try-completion-function expect-exact) + (completion--do-completion beg end + try-completion-function expect-exact) ;; It did find a match. Do we match some possibility exactly now? (let* ((exact (test-completion completion @@ -983,7 +993,7 @@ when the buffer's text is already an exact match." minibuffer-completion-predicate "")) comp-pos))) - (completion-all-sorted-completions)))) + (completion-all-sorted-completions beg end)))) (completion--flush-all-sorted-completions) (cond ((and (consp (cdr comps)) ;; There's something to cycle. @@ -994,8 +1004,8 @@ when the buffer's text is already an exact match." ;; Not more than completion-cycle-threshold remaining ;; completions: let's cycle. (setq completed t exact t) - (completion--cache-all-sorted-completions comps) - (minibuffer-force-complete)) + (completion--cache-all-sorted-completions beg end comps) + (minibuffer-force-complete beg end)) (completed ;; We could also decide to refresh the completions, ;; if they're displayed (and assuming there are @@ -1012,14 +1022,14 @@ when the buffer's text is already an exact match." (if (pcase completion-auto-help (`lazy (eq this-command last-command)) (_ completion-auto-help)) - (minibuffer-completion-help) + (minibuffer-completion-help beg end) (completion--message "Next char not unique"))) ;; If the last exact completion and this one were the same, it ;; means we've already given a "Complete, but not unique" message ;; and the user's hit TAB again, so now we give him help. (t (if (and (eq this-command last-command) completion-auto-help) - (minibuffer-completion-help)) + (minibuffer-completion-help beg end)) (completion--done completion 'exact (unless expect-exact "Complete, but not unique")))) @@ -1033,6 +1043,11 @@ If no characters can be completed, display a list of possible completions. If you repeat this command after it displayed such a list, scroll the window of possible completions." (interactive) + (completion-in-region (minibuffer-prompt-end) (point-max) + minibuffer-completion-table + minibuffer-completion-predicate)) + +(defun completion--in-region-1 (beg end) ;; If the previous command was not this, ;; mark the completion buffer obsolete. (setq this-command 'completion-at-point) @@ -1043,7 +1058,8 @@ scroll the window of possible completions." (cond ;; If there's a fresh completion window with a live buffer, ;; and this command is repeated, scroll that window. - ((window-live-p minibuffer-scroll-window) + ((and (window-live-p minibuffer-scroll-window) + (eq t (frame-visible-p (window-frame minibuffer-scroll-window)))) (let ((window minibuffer-scroll-window)) (with-current-buffer (window-buffer window) (if (pos-visible-in-window-p (point-max) window) @@ -1054,17 +1070,17 @@ scroll the window of possible completions." nil))) ;; If we're cycling, keep on cycling. ((and completion-cycling completion-all-sorted-completions) - (minibuffer-force-complete) + (minibuffer-force-complete beg end) t) - (t (pcase (completion--do-completion) + (t (pcase (completion--do-completion beg end) (#b000 nil) (_ t))))) -(defun completion--cache-all-sorted-completions (comps) +(defun completion--cache-all-sorted-completions (beg end comps) (add-hook 'after-change-functions 'completion--flush-all-sorted-completions nil t) (setq completion--all-sorted-completions-location - (cons (copy-marker (field-beginning)) (copy-marker (field-end)))) + (cons (copy-marker beg) (copy-marker end))) (setq completion-all-sorted-completions comps)) (defun completion--flush-all-sorted-completions (&optional start end _len) @@ -1084,10 +1100,10 @@ scroll the window of possible completions." (if (eq (car bounds) base) md-at-point (completion-metadata (substring string 0 base) table pred)))) -(defun completion-all-sorted-completions () +(defun completion-all-sorted-completions (&optional start end) (or completion-all-sorted-completions - (let* ((start (field-beginning)) - (end (field-end)) + (let* ((start (or start (minibuffer-prompt-end))) + (end (or end (point-max))) (string (buffer-substring start end)) (md (completion--field-metadata start)) (all (completion-all-completions @@ -1125,28 +1141,31 @@ scroll the window of possible completions." ;; Cache the result. This is not just for speed, but also so that ;; repeated calls to minibuffer-force-complete can cycle through ;; all possibilities. - (completion--cache-all-sorted-completions (nconc all base-size)))))) + (completion--cache-all-sorted-completions + start end (nconc all base-size)))))) (defun minibuffer-force-complete-and-exit () "Complete the minibuffer with first of the matches and exit." (interactive) (minibuffer-force-complete) - (minibuffer--complete-and-exit + (completion--complete-and-exit + (minibuffer-prompt-end) (point-max) #'exit-minibuffer ;; If the previous completion completed to an element which fails ;; test-completion, then we shouldn't exit, but that should be rare. (lambda () (minibuffer-message "Incomplete")))) -(defun minibuffer-force-complete () +(defun minibuffer-force-complete (&optional start end) "Complete the minibuffer to an exact match. Repeated uses step through the possible completions." (interactive) + (setq minibuffer-scroll-window nil) ;; FIXME: Need to deal with the extra-size issue here as well. ;; FIXME: ~/src/emacs/t/lisp/minibuffer.el completes to ;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el. - (let* ((start (copy-marker (field-beginning))) - (end (field-end)) + (let* ((start (copy-marker (or start (minibuffer-prompt-end)))) + (end (or end (point-max))) ;; (md (completion--field-metadata start)) - (all (completion-all-sorted-completions)) + (all (completion-all-sorted-completions start end)) (base (+ start (or (cdr (last all)) 0)))) (cond ((not (consp all)) @@ -1159,9 +1178,11 @@ Repeated uses step through the possible completions." 'finished (when done "Sole completion")))) (t (completion--replace base end (car all)) + (setq end (+ base (length (car all)))) (completion--done (buffer-substring-no-properties start (point)) 'sole) ;; Set cycling after modifying the buffer since the flush hook resets it. (setq completion-cycling t) + (setq this-command 'completion-at-point) ;For completion-in-region. ;; If completing file names, (car all) may be a directory, so we'd now ;; have a new set of possible completions and might want to reset ;; completion-all-sorted-completions to nil, but we prefer not to, @@ -1169,7 +1190,7 @@ Repeated uses step through the possible completions." ;; through the previous possible completions. (let ((last (last all))) (setcdr last (cons (car all) (cdr last))) - (completion--cache-all-sorted-completions (cdr all))) + (completion--cache-all-sorted-completions start end (cdr all))) ;; Make sure repeated uses cycle, even though completion--done might ;; have added a space or something that moved us outside of the field. ;; (bug#12221). @@ -1208,27 +1229,32 @@ If `minibuffer-completion-confirm' is `confirm-after-completion', `minibuffer-confirm-exit-commands', and accept the input otherwise." (interactive) - (minibuffer--complete-and-exit + (completion-complete-and-exit (minibuffer-prompt-end) (point-max) + #'exit-minibuffer)) + +(defun completion-complete-and-exit (beg end exit-function) + (completion--complete-and-exit + beg end exit-function (lambda () (pcase (condition-case nil - (completion--do-completion nil 'expect-exact) + (completion--do-completion beg end + nil 'expect-exact) (error 1)) - ((or #b001 #b011) (exit-minibuffer)) + ((or #b001 #b011) (funcall exit-function)) (#b111 (if (not minibuffer-completion-confirm) - (exit-minibuffer) + (funcall exit-function) (minibuffer-message "Confirm") nil)) (_ nil))))) -(defun minibuffer--complete-and-exit (completion-function) +(defun completion--complete-and-exit (beg end + exit-function completion-function) "Exit from `require-match' minibuffer. COMPLETION-FUNCTION is called if the current buffer's content does not appear to be a match." - (let ((beg (field-beginning)) - (end (field-end))) (cond ;; Allow user to specify null string - ((= beg end) (exit-minibuffer)) + ((= beg end) (funcall exit-function)) ((test-completion (buffer-substring beg end) minibuffer-completion-table minibuffer-completion-predicate) @@ -1254,7 +1280,7 @@ appear to be a match." ;; that file. (= (length string) (length compl))) (completion--replace beg end compl)))) - (exit-minibuffer)) + (funcall exit-function)) ((memq minibuffer-completion-confirm '(confirm confirm-after-completion)) ;; The user is permitted to exit with an input that's rejected @@ -1265,13 +1291,13 @@ appear to be a match." ;; catches most minibuffer typos). (and (eq minibuffer-completion-confirm 'confirm-after-completion) (not (memq last-command minibuffer-confirm-exit-commands)))) - (exit-minibuffer) + (funcall exit-function) (minibuffer-message "Confirm") nil)) (t ;; Call do-completion, but ignore errors. - (funcall completion-function))))) + (funcall completion-function)))) (defun completion--try-word-completion (string table predicate point md) (let ((comp (completion-try-completion string table predicate point md))) @@ -1366,9 +1392,18 @@ After one word is completed as much as possible, a space or hyphen is added, provided that matches some possible completion. Return nil if there is no valid completion, else t." (interactive) - (pcase (completion--do-completion 'completion--try-word-completion) + (completion-in-region--single-word + (minibuffer-prompt-end) (point-max) + minibuffer-completion-table minibuffer-completion-predicate)) + +(defun completion-in-region--single-word (beg end collection + &optional predicate) + (let ((minibuffer-completion-table collection) + (minibuffer-completion-predicate predicate)) + (pcase (completion--do-completion beg end + #'completion--try-word-completion) (#b000 nil) - (_ t))) + (_ t)))) (defface completions-annotations '((t :inherit italic)) "Face to use for annotations in the *Completions* buffer.") @@ -1380,7 +1415,6 @@ in columns in the *Completions* buffer. If the value is `horizontal', display completions sorted horizontally in alphabetical order, rather than down the screen." :type '(choice (const horizontal) (const vertical)) - :group 'minibuffer :version "23.2") (defun completion--insert-strings (strings) @@ -1458,9 +1492,11 @@ It also eliminates runs of equal strings." 'mouse-face 'highlight) (put-text-property (point) (progn (insert (car str)) (point)) 'mouse-face 'highlight) - (add-text-properties (point) (progn (insert (cadr str)) (point)) - '(mouse-face nil - face completions-annotations))) + (let ((beg (point)) + (end (progn (insert (cadr str)) (point)))) + (put-text-property beg end 'mouse-face nil) + (font-lock-prepend-text-property beg end 'face + 'completions-annotations))) (cond ((eq completions-format 'vertical) ;; Vertical format @@ -1487,16 +1523,13 @@ See also `display-completion-list'.") (defface completions-first-difference '((t (:inherit bold))) - "Face put on the first uncommon character in completions in *Completions* buffer." - :group 'completion) + "Face added on the first uncommon character in completions in *Completions* buffer.") -(defface completions-common-part - '((t (:inherit default))) - "Face put on the common prefix substring in completions in *Completions* buffer. +(defface completions-common-part '((t nil)) + "Face added on the common prefix substring in completions in *Completions* buffer. The idea of `completions-common-part' is that you can use it to make the common parts less visible than normal, so that the rest -of the differing parts is, by contrast, slightly highlighted." - :group 'completion) +of the differing parts is, by contrast, slightly highlighted.") (defun completion-hilit-commonality (completions prefix-len base-size) (when completions @@ -1513,17 +1546,18 @@ of the differing parts is, by contrast, slightly highlighted." (car (setq elem (cons (copy-sequence (car elem)) (cdr elem)))) (setq elem (copy-sequence elem))))) - (put-text-property 0 - ;; If completion-boundaries returns incorrect - ;; values, all-completions may return strings - ;; that don't contain the prefix. - (min com-str-len (length str)) - 'font-lock-face 'completions-common-part - str) + (font-lock-prepend-text-property + 0 + ;; If completion-boundaries returns incorrect + ;; values, all-completions may return strings + ;; that don't contain the prefix. + (min com-str-len (length str)) + 'face 'completions-common-part str) (if (> (length str) com-str-len) - (put-text-property com-str-len (1+ com-str-len) - 'font-lock-face 'completions-first-difference - str))) + (font-lock-prepend-text-property com-str-len (1+ com-str-len) + 'face + 'completions-first-difference + str))) elem) completions) base-size)))) @@ -1538,12 +1572,8 @@ alternative, the second serves as annotation. The actual completion alternatives, as inserted, are given `mouse-face' properties of `highlight'. At the end, this runs the normal hook `completion-setup-hook'. -It can find the completion buffer in `standard-output'. - -The obsolete optional arg COMMON-SUBSTRING, if non-nil, should be a string -specifying a common substring for adding the faces -`completions-first-difference' and `completions-common-part' to -the completions buffer." +It can find the completion buffer in `standard-output'." + (declare (advertised-calling-convention (completions) "24.4")) (if common-substring (setq completions (completion-hilit-commonality completions (length common-substring) @@ -1630,19 +1660,19 @@ variables.") (equal pre-msg (and exit-fun (current-message)))) (completion--message message)))) -(defun minibuffer-completion-help () +(defun minibuffer-completion-help (&optional start end) "Display a list of possible completions of the current minibuffer contents." (interactive) (message "Making completion list...") - (let* ((start (field-beginning)) - (end (field-end)) - (string (field-string)) + (let* ((start (or start (minibuffer-prompt-end))) + (end (or end (point-max))) + (string (buffer-substring start end)) (md (completion--field-metadata start)) (completions (completion-all-completions string minibuffer-completion-table minibuffer-completion-predicate - (- (point) (field-beginning)) + (- (point) start) md))) (message nil) (if (or (null completions) @@ -1758,14 +1788,15 @@ variables.") (exit-minibuffer)) (defvar completion-in-region-functions nil - "Wrapper hook around `completion-in-region'. -The functions on this special hook are called with 5 arguments: - NEXT-FUN START END COLLECTION PREDICATE. -NEXT-FUN is a function of four arguments (START END COLLECTION PREDICATE) -that performs the default operation. The other four arguments are like -the ones passed to `completion-in-region'. The functions on this hook -are expected to perform completion on START..END using COLLECTION -and PREDICATE, either by calling NEXT-FUN or by doing it themselves.") + "Wrapper hook around `completion-in-region'.") +(make-obsolete-variable 'completion-in-region-functions + 'completion-in-region-function "24.4") + +(defvar completion-in-region-function #'completion--in-region + "Function to perform the job of `completion-in-region'. +The function is called with 4 arguments: START END COLLECTION PREDICATE. +The arguments and expected return value are like the ones of +`completion-in-region'.") (defvar completion-in-region--data nil) @@ -1787,27 +1818,30 @@ Point needs to be somewhere between START and END. PREDICATE (a function called with no arguments) says when to exit." (cl-assert (<= start (point)) (<= (point) end)) + (funcall completion-in-region-function start end collection predicate)) + +(defcustom read-file-name-completion-ignore-case + (if (memq system-type '(ms-dos windows-nt darwin cygwin)) + t nil) + "Non-nil means when reading a file name completion ignores case." + :type 'boolean + :version "22.1") + +(defun completion--in-region (start end collection &optional predicate) (with-wrapper-hook ;; FIXME: Maybe we should use this hook to provide a "display ;; completions" operation as well. completion-in-region-functions (start end collection predicate) (let ((minibuffer-completion-table collection) - (minibuffer-completion-predicate predicate) - (ol (make-overlay start end nil nil t))) - (overlay-put ol 'field 'completion) + (minibuffer-completion-predicate predicate)) ;; HACK: if the text we are completing is already in a field, we ;; want the completion field to take priority (e.g. Bug#6830). - (overlay-put ol 'priority 100) (when completion-in-region-mode-predicate - (completion-in-region-mode 1) (setq completion-in-region--data - (list (if (markerp start) start (copy-marker start)) - (copy-marker end) collection))) - ;; FIXME: `minibuffer-complete' should call `completion-in-region' rather - ;; than the other way around! - (unwind-protect - (call-interactively 'minibuffer-complete) - (delete-overlay ol))))) + `(,(if (markerp start) start (copy-marker start)) + ,(copy-marker end t) ,collection ,predicate)) + (completion-in-region-mode 1)) + (completion--in-region-1 start end)))) (defvar completion-in-region-mode-map (let ((map (make-sparse-keymap))) @@ -1840,21 +1874,25 @@ exit." ;; (defalias 'completion-in-region--prech 'completion-in-region--postch) +(defvar completion-in-region-mode nil) ;Explicit defvar, i.s.o defcustom. + (define-minor-mode completion-in-region-mode - "Transient minor mode used during `completion-in-region'. -With a prefix argument ARG, enable the modemode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil." + "Transient minor mode used during `completion-in-region'." :global t - (setq completion-in-region--data nil) + :group 'minibuffer + ;; Prevent definition of a custom-variable since it makes no sense to + ;; customize this variable. + :variable completion-in-region-mode ;; (remove-hook 'pre-command-hook #'completion-in-region--prech) (remove-hook 'post-command-hook #'completion-in-region--postch) (setq minor-mode-overriding-map-alist (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist) minor-mode-overriding-map-alist)) (if (null completion-in-region-mode) - (unless (equal "*Completions*" (buffer-name (window-buffer))) - (minibuffer-hide-completions)) + (progn + (setq completion-in-region--data nil) + (unless (equal "*Completions*" (buffer-name (window-buffer))) + (minibuffer-hide-completions))) ;; (add-hook 'pre-command-hook #'completion-in-region--prech) (cl-assert completion-in-region-mode-predicate) (setq completion-in-region-mode--predicate @@ -1971,19 +2009,15 @@ The completion method is determined by `completion-at-point-functions'." (lambda () ;; We're still in the same completion field. (let ((newstart (car-safe (funcall hookfun)))) - (and newstart (= newstart start))))) - (ol (make-overlay start end nil nil t))) + (and newstart (= newstart start)))))) ;; FIXME: We should somehow (ab)use completion-in-region-function or ;; introduce a corresponding hook (plus another for word-completion, ;; and another for force-completion, maybe?). - (overlay-put ol 'field 'completion) - (overlay-put ol 'priority 100) - (completion-in-region-mode 1) (setq completion-in-region--data - (list start (copy-marker end) collection)) - (unwind-protect - (call-interactively 'minibuffer-completion-help) - (delete-overlay ol)))) + `(,start ,(copy-marker end t) ,collection + ,(plist-get plist :predicate))) + (completion-in-region-mode 1) + (minibuffer-completion-help start end))) (`(,hookfun . ,_) ;; The hook function already performed completion :-( ;; Not much we can do at this point. @@ -2045,10 +2079,7 @@ with `minibuffer-local-must-match-map'.") (define-key map "i" 'info) (define-key map "m" 'mail) (define-key map "n" 'make-frame) - (define-key map [mouse-1] (lambda () (interactive) - (with-current-buffer "*Messages*" - (goto-char (point-max)) - (display-buffer (current-buffer))))) + (define-key map [mouse-1] 'view-echo-area-messages) ;; So the global down-mouse-1 binding doesn't clutter the execution of the ;; above mouse-1 binding. (define-key map [down-mouse-1] #'ignore) @@ -2260,14 +2291,6 @@ except that it passes the file name through `substitute-in-file-name'.") "The function called by `read-file-name' to do its work. It should accept the same arguments as `read-file-name'.") -(defcustom read-file-name-completion-ignore-case - (if (memq system-type '(ms-dos windows-nt darwin cygwin)) - t nil) - "Non-nil means when reading a file name completion ignores case." - :group 'minibuffer - :type 'boolean - :version "22.1") - (defcustom insert-default-directory t "Non-nil means when reading a filename start with default dir in minibuffer. @@ -2289,7 +2312,6 @@ the minibuffer empty. For some commands, exiting with an empty minibuffer has a special meaning, such as making the current buffer visit no file in the case of `set-visited-file-name'." - :group 'minibuffer :type 'boolean) ;; Not always defined, but only called if next-read-file-uses-dialog-p says so. @@ -2682,7 +2704,6 @@ expression (not containing character ranges like `a-z')." ;; Refresh other vars. (completion-pcm--prepare-delim-re value)) :initialize 'custom-initialize-reset - :group 'minibuffer :type 'string) (defcustom completion-pcm-complete-word-inserts-delimiters nil @@ -2715,7 +2736,8 @@ or a symbol, see `completion-pcm--merge-completions'." (completion-pcm--string->pattern suffix))) (let* ((pattern nil) (p 0) - (p0 p)) + (p0 p) + (pending nil)) (while (and (setq p (string-match completion-pcm--delim-wild-regex string p)) @@ -2732,18 +2754,49 @@ or a symbol, see `completion-pcm--merge-completions'." ;; This is determined by the presence of a submatch-1 which delimits ;; the prefix. (if (match-end 1) (setq p (match-end 1))) - (push (substring string p0 p) pattern) + (unless (= p0 p) + (if pending (push pending pattern)) + (push (substring string p0 p) pattern)) + (setq pending nil) (if (eq (aref string p) ?*) (progn (push 'star pattern) (setq p0 (1+ p))) (push 'any pattern) - (setq p0 p)) - (cl-incf p)) - + (if (match-end 1) + (setq p0 p) + (push (substring string p (match-end 0)) pattern) + ;; `any-delim' is used so that "a-b" also finds "array->beginning". + (setq pending 'any-delim) + (setq p0 (match-end 0)))) + (setq p p0)) + + (when (> (length string) p0) + (if pending (push pending pattern)) + (push (substring string p0) pattern)) ;; An empty string might be erroneously added at the beginning. ;; It should be avoided properly, but it's so easy to remove it here. - (delete "" (nreverse (cons (substring string p0) pattern)))))) + (delete "" (nreverse pattern))))) + +(defun completion-pcm--optimize-pattern (p) + ;; Remove empty strings in a separate phase since otherwise a "" + ;; might prevent some other optimization, as in '(any "" any). + (setq p (delete "" p)) + (let ((n '())) + (while p + (pcase p + (`(,(and s1 (pred stringp)) ,(and s2 (pred stringp)) . ,rest) + (setq p (cons (concat s1 s2) rest))) + (`(,(and p1 (pred symbolp)) ,(and p2 (guard (eq p1 p2))) . ,_) + (setq p (cdr p))) + (`(star ,(pred symbolp) . ,rest) (setq p `(star . ,rest))) + (`(,(pred symbolp) star . ,rest) (setq p `(star . ,rest))) + (`(point ,(or `any `any-delim) . ,rest) (setq p `(point . ,rest))) + (`(,(or `any `any-delim) point . ,rest) (setq p `(point . ,rest))) + (`(any ,(or `any `any-delim) . ,rest) (setq p `(any . ,rest))) + (`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'. + (_ (push (pop p) n)))) + (nreverse n))) (defun completion-pcm--pattern->regex (pattern &optional group) (let ((re @@ -2752,8 +2805,13 @@ or a symbol, see `completion-pcm--merge-completions'." (lambda (x) (cond ((stringp x) (regexp-quote x)) - ((if (consp group) (memq x group) group) "\\(.*?\\)") - (t ".*?"))) + (t + (let ((re (if (eq x 'any-delim) + (concat completion-pcm--delim-wild-regex "*?") + ".*?"))) + (if (if (consp group) (memq x group) group) + (concat "\\(" re "\\)") + re))))) pattern "")))) ;; Avoid pathological backtracking. @@ -2827,11 +2885,11 @@ filter out additional entries (because TABLE might not obey PRED)." (setq string (substring string (car bounds) (+ point (cdr bounds)))) (let* ((relpoint (- point (car bounds))) (pattern (completion-pcm--string->pattern string relpoint)) - (all (condition-case err + (all (condition-case-unless-debug err (funcall filter (completion-pcm--all-completions prefix pattern table pred)) - (error (unless firsterror (setq firsterror err)) nil)))) + (error (setq firsterror err) nil)))) (when (and (null all) (> (car bounds) 0) (null (ignore-errors (try-completion prefix table pred)))) @@ -2998,12 +3056,21 @@ the same set of elements." ;; here any more. (unless unique (push elem res) - (when (memq elem '(star point prefix)) - ;; Extract common suffix additionally to common prefix. - ;; Only do it for `point', `star', and `prefix' since for - ;; `any' it could lead to a merged completion that - ;; doesn't itself match the candidates. - (let ((suffix (completion--common-suffix comps))) + ;; Extract common suffix additionally to common prefix. + ;; Don't do it for `any' since it could lead to a merged + ;; completion that doesn't itself match the candidates. + (when (and (memq elem '(star point prefix)) + ;; If prefix is one of the completions, there's no + ;; suffix left to find. + (not (assoc-string prefix comps t))) + (let ((suffix + (completion--common-suffix + (if (zerop (length prefix)) comps + ;; Ignore the chars in the common prefix, so we + ;; don't merge '("abc" "abbc") as "ab*bc". + (let ((skip (length prefix))) + (mapcar (lambda (str) (substring str skip)) + comps)))))) (cl-assert (stringp suffix)) (unless (equal suffix "") (push suffix res)))))