From: Eshel Yaron Date: Mon, 26 Feb 2024 18:58:03 +0000 (+0100) Subject: Rework *Completions* display X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=88925b645eca13b0d533cf25997a42ef12a0be25;p=emacs.git Rework *Completions* display --- diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 200ca387014..87171336743 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1285,7 +1285,7 @@ prefix argument, completion candidates include all user options instead." (propertize "ON" 'face 'success) (propertize "OFF" 'face 'error))))) -(put 'customize-toggle-option 'minibuffer-action t) +(put 'customize-toggle-option 'minibuffer-action "toggle") ;;;###autoload (defalias 'toggle-option #'customize-toggle-option) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index b1e728c67fa..5c93636ea07 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -267,25 +267,31 @@ that fails this command prompts you for the separator to use." (define-minor-mode completions-multi-mode "Minor mode for reading multiple strings in the minibuffer." - :lighter (:eval - (let ((canonical - (buffer-local-value 'crm-canonical-separator - completion-reference-buffer))) - (propertize - (concat - " Multi" - (when canonical (concat "[" crm-canonical-separator "]"))) - 'help-echo - (concat - "Insert multiple inputs by separating them with \"" - (or canonical - (buffer-local-value 'crm-current-separator - completion-reference-buffer)) - "\""))))) - -(defun crm-completion-setup () + :interactive nil + (if completions-multi-mode + (setq-local completions-header-extra + (cons + '(:eval + (let ((canonical + (buffer-local-value 'crm-canonical-separator + completion-reference-buffer))) + (propertize + (concat + "Multi" + (when canonical (concat "[" crm-canonical-separator "]"))) + 'help-echo + (concat + "Insert multiple inputs by separating them with \"" + (or canonical + (buffer-local-value 'crm-current-separator + completion-reference-buffer)) + "\"")))) + completions-header-extra)))) + +(defun crm-completions-setup () "Enable `completions-multi-mode' in *Completions* buffer." - (with-current-buffer standard-output (completions-multi-mode))) + (with-current-buffer (window-buffer minibuffer-scroll-window) + (completions-multi-mode))) (define-obsolete-variable-alias 'crm-local-completion-map 'completing-read-multiple-mode-map "30.1") @@ -332,10 +338,10 @@ that fails this command prompts you for the separator to use." :interactive nil (if completing-read-multiple-mode (progn - (add-hook 'completion-setup-hook #'crm-completion-setup 10 t) + (add-hook 'completion-setup-hook #'crm-completions-setup 10 t) (add-hook 'after-change-functions #'crm-highlight-separators nil t) (crm-highlight-separators (minibuffer-prompt-end) (point-max))) - (remove-hook 'completion-setup-hook #'crm-completion-setup t) + (remove-hook 'completion-setup-hook #'crm-completions-setup t) (remove-hook 'after-change-functions #'crm-highlight-separators t) (mapc #'delete-overlay (seq-filter (lambda (ov) (overlay-get ov 'crm-separator)) diff --git a/lisp/files.el b/lisp/files.el index fed825580d0..9f9943ebbf8 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -939,6 +939,13 @@ The path separator is colon in GNU and GNU-like systems." (error "No such directory found via CDPATH environment variable: %s" dir) (error "No such directory: %s" dir))))) +(put 'cd 'minibuffer-action + (cons (lambda (dir) + (with-current-buffer minibuffer--original-buffer + (cd dir) + (force-mode-line-update))) + "cd")) + (defun directory-files-recursively (dir regexp &optional include-directories predicate follow-symlinks) @@ -1020,6 +1027,8 @@ See `file-symlink-p' to distinguish symlinks." (read-file-name "Load file: " nil nil 'lambda)))) (load (expand-file-name file) nil nil t)) +(put 'load-file 'minibuffer-action "load") + (defvar comp-eln-to-el-h) (defun locate-file (filename path &optional suffixes predicate) @@ -1246,6 +1255,8 @@ See `load-file' for a different interface to `load'." (interactive (list (read-library-name))) (load library)) +(put 'load-library 'minibuffer-action "load") + (defun require-with-check (feature &optional filename noerror) "If FEATURE is not already loaded, load it from FILENAME. This is like `require' except if FEATURE is already a member of the list @@ -1859,8 +1870,14 @@ suppress wildcard expansion by setting `find-file-wildcards' to nil. \\To visit a file without any kind of conversion and without automatically choosing a major mode, use \\[find-file-literally]." (interactive - (find-file-read-args "Find file: " - (confirm-nonexistent-file-or-buffer))) + (minibuffer-with-setup-hook + (lambda () + (setq-local minibuffer-completion-action + (cons (lambda (file) + (display-buffer (find-file-noselect file))) + "find"))) + (find-file-read-args "Find file: " + (confirm-nonexistent-file-or-buffer)))) (let ((value (find-file-noselect filename nil nil wildcards))) (if (listp value) (mapcar 'pop-to-buffer-same-window (nreverse value)) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 1de425b3640..4b70e2ec6d4 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1271,12 +1271,6 @@ overrides the default specified in `completion-category-defaults'." (or (assq tag (cdr (assq category completion-category-overrides))) (assq tag (cdr (assq category completion-category-defaults))))) -(defvar completion-style nil - "The completion style that produced the current completions list. - -`minibuffer-completion-help' arranges for this variable to be set -buffer-locally in the *Completions* buffer.") - (defvar completion--matching-style nil "Last completion style to match user input.") @@ -1585,7 +1579,7 @@ it with \\[kill-region]." (substitute-command-keys (concat ", \\[minibuffer-widen-completions] to clear restrictions (" - (minibuffer--completion-predicate-description) + (completions-predicate-description minibuffer-completion-predicate) ")"))))))) @@ -2285,28 +2279,78 @@ completions." :type 'boolean :version "28.1") -(defcustom completions-header-format "%s possible%c completions%t%r:\n" - "If non-nil, the format string for completions heading line. -The heading line is inserted before the completions, and is -intended to summarize the completions. The format string may -contain the sequences \"%s\", \"%c\", \"%t\" and \"%r\", which -are substituted as follows: - -- \"%s\": the total count of possible completions. -- \"%c\": the current completion category prefixed with \" \" - (e.g. \" command\"), or the empty string when the completion - table does not specify a category. -- \"%t\": the current completions sort order prefixed with - \", \" (e.g. \", sorted alphabetically\"), or the empty string - when using the default sort order. -- \"%r\": a description of the current completions restriction - prefixed with \", \" (e.g. \", with property disabled\"), or - the empty string when there are no restrictions. - -If this option is nil, no heading line is shown." - :type '(choice (const :tag "No heading line" nil) - (string :tag "Format string for heading line")) - :version "30.1") +(defvar-local completions-candidates nil) +(defvar-local completions-category nil) +(defvar-local completions-sort-function nil) +(defvar-local completions-sort-orders nil) +(defvar-local completions-predicate nil) +(defvar-local completions-action nil) +(defvar-local completions-style nil) + +(defvar completions-header-count + '(completions-candidates + ("count:" (:eval (file-size-human-readable (length completions-candidates) 'si)) " "))) + +(defvar completions-header-category + '(completions-category + ("category:" (:eval (symbol-name completions-category)) " "))) + +(defvar completions-header-order + '(completions-sort-function + ("sort:" + (:eval (concat + (when-let + ((sd (nth 4 (seq-find + (lambda (order) + (eq + (nth 3 order) + (advice--cd*r + completions-sort-function))) + completions-sort-orders)))) + (concat sd " ")) + (when (advice-function-member-p + #'reverse completions-sort-function) + "(reversed)"))) + " "))) + +(defvar completions-header-restriction + '(completions-predicate + ("filter:" + (:eval (or (completions-predicate-description + completions-predicate) + (and (symbolp completions-predicate) + (symbol-name completions-predicate)) + "none")) + " "))) + +(defvar completions-header-action + '(completions-action + ("action:" (:eval (cdr completions-action)) " "))) + +(defvar completions-header-style + '(completions-style + ("style:" + (:eval (symbol-name completions-style)) + " "))) + +(defvar completions-header-extra nil) + +(dolist (sym '(completions-header-count + completions-header-category + completions-header-order + completions-header-restriction + completions-header-action + completions-header-style + completions-header-extra)) + (put sym 'risky-local-variable t)) + +(defvar completions-header-format + '(" " + completions-header-count completions-header-category + completions-header-order completions-header-restriction + completions-header-action completions-header-style + completions-header-extra) + "Header line format of the *Completions* buffer.") (defun completion--insert-strings (strings &optional group-fun) "Insert a list of STRINGS into the current buffer. @@ -2324,7 +2368,7 @@ function as described in the documentation of `completion-metadata'." (string-width s))) strings))) (window (get-buffer-window (current-buffer) 0)) - (wwidth (if window (1- (window-width window)) 79)) + (wwidth (if window (1- (window-width window)) (1- (frame-width)))) (columns (min ;; At least 2 spaces between columns. (max 1 (/ wwidth (+ 2 length))) @@ -2543,14 +2587,14 @@ and with BASE-SIZE appended as the last element." completions) base-size)))) -(defun minibuffer--completion-predicate-description () - (and (functionp minibuffer-completion-predicate) +(defun completions-predicate-description (pred) + (and (functionp pred) (let ((descs nil)) (advice-function-mapc (lambda (_ alist) (when-let ((description (alist-get 'description alist))) (push description descs))) - minibuffer-completion-predicate) + pred) (when descs (mapconcat #'identity descs ", "))))) (defvar minibuffer-completions-sort-function nil @@ -2591,10 +2635,7 @@ when you select this sort order." (choice string (const :tag "No description" nil))))) -(defvar completion-category nil - "The current completion category.") - -(defface completions-heading '((t :inherit shadow)) +(defface completions-heading '((t :background "light cyan" :underline "black")) "Face for the completions headling line.") (defface completions-previous-input '((t :underline "violet")) @@ -2608,58 +2649,6 @@ when you select this sort order." :version "30.1" :type 'boolean) -(defun display-completion-list (completions &optional group-fun) - "Display the list of completions, COMPLETIONS, using `standard-output'. -Each element may be just a symbol or string -or may be a list of two strings to be printed as if concatenated. -If it is a list of two strings, the first is the actual completion -alternative, the second serves as annotation. -`standard-output' must be a buffer. -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'. - -Optional argument GROUP-FUN, if non-nil, is a completions grouping -function as described in the documentation of `completion-metadata'." - (let ((pred-desc - (if-let ((pd (minibuffer--completion-predicate-description))) - (concat ", " pd) - "")) - (sort-desc - (if minibuffer-completions-sort-function - (concat - (when-let - ((sd (nth 4 (seq-find - (lambda (order) - (eq - (nth 3 order) - (advice--cd*r - minibuffer-completions-sort-function))) - minibuffer-completions-sort-orders)))) - (concat ", " sd)) - (when (advice-function-member-p - #'reverse minibuffer-completions-sort-function) - ", reversed")) - "")) - (cat (if completion-category (format " %s" completion-category) ""))) - (with-current-buffer standard-output - (goto-char (point-max)) - (when completions-header-format - (let ((heading - (format-spec completions-header-format - (list (cons ?s (length completions)) - (cons ?t sort-desc) - (cons ?r pred-desc) - (cons ?c cat))))) - (add-face-text-property - 0 (length heading) 'completions-heading t heading) - (insert heading))) - (completion--insert-strings completions group-fun))) - - (run-hooks 'completion-setup-hook) - nil) - (defvar completion-extra-properties nil "Property list of extra properties of the current completion job. These include: @@ -2727,13 +2716,18 @@ in `completion-metadata'. :type '(choice (const nil) natnum) :version "29.1") +(defcustom completions-min-height 2 + "Minimum height for *Completions* buffer window." + :type '(choice (const nil) natnum) + :version "30.1") + (defun completions--fit-window-to-buffer (&optional win &rest _) "Resize *Completions* buffer window." (if temp-buffer-resize-mode (let ((temp-buffer-max-height (or completions-max-height temp-buffer-max-height))) (resize-temp-buffer-window win)) - (fit-window-to-buffer win completions-max-height))) + (fit-window-to-buffer win completions-max-height completions-min-height))) (defcustom minibuffer-read-sort-order-with-completion nil "Whether to use completion for reading minibuffer completions sort order. @@ -2822,7 +2816,7 @@ completions list." (list (let ((styles (completion--styles (completion--field-metadata (minibuffer-prompt-end)))) (current (when-let ((buf (get-buffer "*Completions*"))) - (buffer-local-value 'completion-style buf))) + (buffer-local-value 'completions-style buf))) (enable-recursive-minibuffers t)) (pcase current-prefix-arg (`(,_ . ,_) nil) ; \\[universal-argument] @@ -2863,26 +2857,7 @@ completions list." (defun minibuffer-completion-help (&optional start end) "Display a list of possible completions of the current minibuffer contents." (interactive) - (let* ((current (when-let ((win (get-buffer-window "*Completions*" 0))) - (get-text-property (window-point win) 'completion--string - (get-buffer "*Completions*")))) - (prev-next (when current - (with-current-buffer "*Completions*" - (save-excursion - (goto-char (point-min)) - (text-property-search-forward 'completion--string current t) - (cons - (save-excursion - (when-let ((pm (text-property-search-backward 'completion--string current))) - (goto-char (prop-match-end pm)) - (when-let ((pm (text-property-search-backward 'cursor-face nil))) - (goto-char (prop-match-beginning pm)) - (get-text-property (point) 'completion--string)))) - (save-excursion - (when-let ((pm (text-property-search-forward 'cursor-face nil t))) - (goto-char (prop-match-end pm)) - (get-text-property (point) 'completion--string)))))))) - (start (or start (minibuffer--completion-prompt-end))) + (let* ((start (or start (minibuffer--completion-prompt-end))) (end (or end (point-max))) (string (buffer-substring start end)) (md (completion--field-metadata start)) @@ -2906,7 +2881,26 @@ completions list." (completion--message "Sole completion") (completion--fail))) - (let* ((prefix (unless (zerop base-size) (substring string 0 base-size))) + (let* ((buf (get-buffer-create "*Completions*")) + (current (when-let ((win (get-buffer-window buf 0))) + (get-text-property (window-point win) 'completion--string buf))) + (prev-next (when current + (with-current-buffer buf + (save-excursion + (goto-char (point-min)) + (text-property-search-forward 'completion--string current t) + (cons + (save-excursion + (when-let ((pm (text-property-search-backward 'completion--string current))) + (goto-char (prop-match-end pm)) + (when-let ((pm (text-property-search-backward 'cursor-face nil))) + (goto-char (prop-match-beginning pm)) + (get-text-property (point) 'completion--string)))) + (save-excursion + (when-let ((pm (text-property-search-forward 'cursor-face nil t))) + (goto-char (prop-match-end pm)) + (get-text-property (point) 'completion--string)))))))) + (prefix (unless (zerop base-size) (substring string 0 base-size))) (full-base (substring string 0 base-size)) (base-prefix (buffer-substring (minibuffer--completion-prompt-end) (+ start base-size))) @@ -2930,165 +2924,164 @@ completions list." (aff-fun (completion-metadata-get all-md 'affixation-function)) (sort-fun (completion-metadata-get all-md 'display-sort-function)) (group-fun (completion-metadata-get all-md 'group-function)) - (completion-category (completion-metadata-get all-md 'category)) + (category (completion-metadata-get all-md 'category)) (minibuffer-completion-base (funcall (or (alist-get 'adjust-base-function all-md) #'identity) full-base)) - (mainbuf (current-buffer)) + (explicit-sort-function minibuffer-completions-sort-function) + (sort-orders minibuffer-completions-sort-orders) + (cpred minibuffer-completion-predicate) + (ctable minibuffer-completion-table) ;; If the *Completions* buffer is shown in a new ;; window, mark it as softly-dedicated, so bury-buffer in ;; minibuffer-hide-completions will know whether to ;; delete the window or not. - (display-buffer-mark-dedicated 'soft)) + (display-buffer-mark-dedicated 'soft) + (action (minibuffer-completion-action)) + (mainbuf (current-buffer))) (minibuffer--cache-completion-input (substring string base-size) full-base) - (with-current-buffer-window - "*Completions*" - ;; This is a copy of `display-buffer-fallback-action' - ;; where `display-buffer-use-some-window' is replaced - ;; with `display-buffer-at-bottom'. - `((display-buffer--maybe-same-window - display-buffer-reuse-window - display-buffer--maybe-pop-up-frame - ;; Use `display-buffer-below-selected' for inline completions, - ;; but not in the minibuffer (e.g. in `eval-expression') - ;; for which `display-buffer-at-bottom' is used. - ,(if (eq (selected-window) (minibuffer-window)) - 'display-buffer-at-bottom - 'display-buffer-below-selected)) - (window-height . completions--fit-window-to-buffer) - ,(when temp-buffer-resize-mode - '(preserve-size . (nil . t))) - (body-function - . ,#'(lambda (_window) - (with-current-buffer mainbuf - ;; Remove the base-size tail because `sort' requires a properly - ;; nil-terminated list. - (when last (setcdr last nil)) - - ;; Highilight previously used completions. - (when-let - ((hist (and completions-highlight-previous-inputs - (not (eq minibuffer-history-variable t)) - (symbol-value minibuffer-history-variable)))) - (setq completions - (mapcar - (lambda (comp) - (if (member (concat minibuffer-completion-base comp) hist) - ;; Avoid modifying the original string. - (let ((copy (copy-sequence comp))) - (font-lock-append-text-property - 0 (length copy) - 'face 'completions-previous-input copy) - copy) - comp)) - completions))) - - ;; Sort first using the `display-sort-function'. - ;; FIXME: This function is for the output of - ;; all-completions, not - ;; completion-all-completions. Often it's the - ;; same, but not always. - (setq completions - (cond - (minibuffer-completions-sort-function - (funcall minibuffer-completions-sort-function - completions)) - (sort-fun - (funcall sort-fun completions)) - (t - (pcase completions-sort - ('nil completions) - ('alphabetical (minibuffer-sort-alphabetically completions)) - ('historical (minibuffer-sort-by-history completions)) - (_ (funcall completions-sort completions)))))) - - ;; After sorting, group the candidates using the - ;; `group-function'. - (when group-fun - (setq completions - (minibuffer--group-by - group-fun - (pcase completions-group-sort - ('nil #'identity) - ('alphabetical - (lambda (groups) - (sort groups - (lambda (x y) - (string< (car x) (car y)))))) - (_ completions-group-sort)) - completions))) - - (cond - (aff-fun - (setq completions - (funcall aff-fun completions))) - (ann-fun - (setq completions - (mapcar (lambda (s) - (let ((ann (funcall ann-fun s))) - (if ann (list s ann) s))) - completions)))) - - (with-current-buffer standard-output - (setq-local completion-style style) - (setq-local completion-base-position - (list (+ start base-size) - ;; FIXME: We should pay attention to completion - ;; boundaries here, but currently - ;; completion-all-completions does not give us the - ;; necessary information. - end)) - (setq-local completion-base-affixes - (list base-prefix base-suffix)) - (setq-local completion-list-insert-choice-function - (let ((ctable minibuffer-completion-table) - (cpred minibuffer-completion-predicate) - (cprops completion-extra-properties)) - (lambda (start end choice) - (if (and (stringp start) (stringp end)) - (progn - (delete-minibuffer-contents) - (insert start choice) - ;; Keep point after completion before suffix - (save-excursion (insert end))) - (unless (or (zerop (length prefix)) - (equal prefix - (buffer-substring-no-properties - (max (point-min) - (- start (length prefix))) - start))) - (message "*Completions* out of date")) - ;; FIXME: Use `md' to do quoting&terminator here. - (completion--replace start end choice)) - (let* ((minibuffer-completion-table ctable) - (minibuffer-completion-predicate cpred) - (completion-extra-properties cprops) - (result (concat prefix choice)) - (bounds (completion-boundaries - result ctable cpred ""))) - ;; If the completion introduces a new field, then - ;; completion is not finished. - (completion--done result - (if (eq (car bounds) (length result)) - 'exact 'finished))))))) - - (display-completion-list completions group-fun) - (with-current-buffer standard-output - (goto-char (point-min)) - (when-let - ((pm - (or (and current (text-property-search-forward 'completion--string current t)) - (when-let ((next (cdr prev-next))) - (text-property-search-forward 'completion--string next t)) - (when-let ((prev (car prev-next))) - (text-property-search-forward 'completion--string prev t))))) - (goto-char (prop-match-beginning pm)) - (setq pm (text-property-search-forward 'cursor-face)) - (setq-local cursor-face-highlight-nonselected-window t) - (set-window-point (get-buffer-window) (prop-match-beginning pm)))))))) - nil))) - nil)) + (when last (setcdr last nil)) + ;; Highilight previously used completions. + (when-let + ((hist (and completions-highlight-previous-inputs + (not (eq minibuffer-history-variable t)) + (symbol-value minibuffer-history-variable)))) + (setq completions + (mapcar + (lambda (comp) + (if (member (concat minibuffer-completion-base comp) hist) + ;; Avoid modifying the original string. + (let ((copy (copy-sequence comp))) + (font-lock-append-text-property + 0 (length copy) + 'face 'completions-previous-input copy) + copy) + comp)) + completions))) + + ;; Sort first using the `display-sort-function'. + ;; FIXME: This function is for the output of + ;; all-completions, not + ;; completion-all-completions. Often it's the + ;; same, but not always. + (setq completions + (cond + (explicit-sort-function + (funcall explicit-sort-function + completions)) + (sort-fun + (funcall sort-fun completions)) + (t + (pcase completions-sort + ('nil completions) + ('alphabetical (minibuffer-sort-alphabetically completions)) + ('historical (minibuffer-sort-by-history completions)) + (_ (funcall completions-sort completions)))))) + + ;; After sorting, group the candidates using the + ;; `group-function'. + (when group-fun + (setq completions + (minibuffer--group-by + group-fun + (pcase completions-group-sort + ('nil #'identity) + ('alphabetical + (lambda (groups) + (sort groups + (lambda (x y) + (string< (car x) (car y)))))) + (_ completions-group-sort)) + completions))) + + (cond + (aff-fun + (setq completions + (funcall aff-fun completions))) + (ann-fun + (setq completions + (mapcar (lambda (s) + (let ((ann (funcall ann-fun s))) + (if ann (list s ann) s))) + completions)))) + (with-current-buffer buf + (completion-list-mode) + (setq buffer-read-only nil) + (delete-region (point-min) (point-max)) + (setq-local completions-style style) + (setq-local completion-base-position + (list (+ start base-size) + ;; FIXME: We should pay attention to completion + ;; boundaries here, but currently + ;; completion-all-completions does not give us the + ;; necessary information. + end)) + (setq-local completion-base-affixes + (list base-prefix base-suffix)) + (setq-local completion-list-insert-choice-function + (let ((cprops completion-extra-properties)) + (lambda (start end choice) + (if (and (stringp start) (stringp end)) + (progn + (delete-minibuffer-contents) + (insert start choice) + ;; Keep point after completion before suffix + (save-excursion (insert end))) + (unless (or (zerop (length prefix)) + (equal prefix + (buffer-substring-no-properties + (max (point-min) + (- start (length prefix))) + start))) + (message "*Completions* out of date")) + ;; FIXME: Use `md' to do quoting&terminator here. + (completion--replace start end choice)) + (let* ((minibuffer-completion-table ctable) + (minibuffer-completion-predicate cpred) + (completion-extra-properties cprops) + (result (concat prefix choice)) + (bounds (completion-boundaries + result ctable cpred ""))) + ;; If the completion introduces a new field, then + ;; completion is not finished. + (completion--done result + (if (eq (car bounds) (length result)) + 'exact 'finished)))))) + (setq-local completions-candidates completions) + (setq-local completions-category category) + (setq-local completions-sort-function explicit-sort-function) + (setq-local completions-sort-orders sort-orders) + (setq-local completions-predicate cpred) + (setq-local completions-action action) + (setq-local completion-reference-buffer mainbuf) + (when completion-tab-width + (setq tab-width completion-tab-width)) + ;; Maybe enable cursor completions-highlight. + (when completions-highlight-face (cursor-face-highlight-mode 1)) + (face-remap-add-relative 'header-line 'completions-heading) + (setq-local header-line-format completions-header-format) + (setq-local mode-line-format nil) + (completion--insert-strings completions group-fun) + (goto-char (point-min)) + (when-let + ((pm + (or (and current (text-property-search-forward 'completion--string current t)) + (when-let ((next (cdr prev-next))) + (text-property-search-forward 'completion--string next t)) + (when-let ((prev (car prev-next))) + (text-property-search-forward 'completion--string prev t))))) + (goto-char (prop-match-beginning pm)) + (setq pm (text-property-search-forward 'cursor-face)) + (setq-local cursor-face-highlight-nonselected-window t) + (set-window-point (get-buffer-window) (prop-match-beginning pm))) + (setq buffer-read-only t)) + (setq minibuffer-scroll-window + (display-buffer buf + '((display-buffer-reuse-window display-buffer-at-bottom) + (window-height . completions--fit-window-to-buffer) + (preserve-size . (nil . t))))) + (run-hooks 'completion-setup-hook))))) (defun minibuffer-hide-completions () "Get rid of an out-of-date *Completions* buffer." @@ -3425,13 +3418,15 @@ The completion method is determined by `completion-at-point-functions'." "C-S-a" #'minibuffer-toggle-completion-ignore-case "?" #'minibuffer-completion-help "" #'switch-to-completions - "M-v" #'switch-to-completions "M-g M-c" #'switch-to-completions + "M-v" #'switch-to-completions + "C-v" #'minibuffer-hide-completions "M-" #'minibuffer-previous-line-completion "M-" #'minibuffer-next-line-completion "M-" #'minibuffer-previous-completion "M-" #'minibuffer-next-completion "M-RET" #'minibuffer-choose-completion + "M-j" #'minibuffer-force-complete-and-exit "C-x C-v" #'minibuffer-sort-completions "C-x n" 'minibuffer-narrow-completions-map "C-x /" #'minibuffer-set-completion-styles @@ -4179,8 +4174,7 @@ possible completions." (define-obsolete-function-alias 'internal-complete-buffer 'completion-buffer-name-table "30.1") -(defvar-local minibuffer-completion-action nil - "Function that `minibuffer-apply' applies to the current input, or nil.") +(defvar-local minibuffer-completion-action nil) (defvar-local minibuffer-completion-command nil "The command currently reading input from the minibuffer.") @@ -4198,22 +4192,30 @@ possible completions." (setq prf (funcall adjust-fn prf))) (cons str prf))) +(defun minibuffer--get-action (symbol) + (when-let ((action (get symbol 'minibuffer-action))) + (cond + ((consp action) action) + ((symbolp action) (minibuffer--get-action action)) + (t (cons symbol action))))) + (defun minibuffer-completion-action () "Return the completion action function for the current minibuffer." (or minibuffer-completion-action - (and (symbolp minibuffer-completion-command) - (get minibuffer-completion-command - 'minibuffer-action) - minibuffer-completion-command) - (error "No applicable action"))) + (and minibuffer-completion-command + (symbolp minibuffer-completion-command) + (minibuffer--get-action minibuffer-completion-command)))) -(defun minibuffer-apply (action input &optional prefix) +(defun minibuffer-apply (input &optional prefix) "Apply ACTION to current minibuffer INPUT prefixed by PREFIX." (interactive (let* ((input-prefix (minibuffer-current-input)) (input (car input-prefix)) (prefix (cdr input-prefix))) - (list (minibuffer-completion-action) input prefix))) - (funcall action (concat prefix input)) + (list input prefix))) + (funcall + (or (car (minibuffer-completion-action)) + (user-error "No applicable action")) + (concat prefix input)) (when-let ((buf (get-buffer "*Completions*")) (win (get-buffer-window buf 0))) (with-current-buffer buf @@ -5502,10 +5504,7 @@ DESC is a string describing predicate PRED." (setq-local minibuffer-completion-predicate #'always)) (add-function :after-while (local 'minibuffer-completion-predicate) pred `((description . ,desc))) - (when completion-auto-help (minibuffer-completion-help)) - (when-let ((completions-buffer (get-buffer "*Completions*"))) - (with-current-buffer completions-buffer - (completions-narrow-mode)))) + (when completion-auto-help (minibuffer-completion-help))) (defun minibuffer-narrow-completions () "Restrict completion candidates for current minibuffer interaction." @@ -5627,11 +5626,7 @@ remove all current restrictions without prompting." (format-prompt "Remove completions restrictions" (caar desc-pred-alist)) desc-pred-alist nil t nil nil (caar desc-pred-alist))))))) - (when completion-auto-help (minibuffer-completion-help)) - (when-let ((completions-buffer (and (not (minibuffer-narrow-completions-p)) - (get-buffer "*Completions*")))) - (with-current-buffer completions-buffer - (completions-narrow-mode -1)))) + (when completion-auto-help (minibuffer-completion-help))) (defcustom minibuffer-default-prompt-format " (default %s)" "Format string used to output \"default\" values. diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 657349cbdff..fd2d3b2f494 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -1122,6 +1122,7 @@ these include `opts', `dir', `files', `null-device', `excl' and (buffer-file-name) (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name))))))) +;;;###autoload (defun grep-read-files (regexp) "Read a file-name pattern arg for interactive grep. The pattern can include shell wildcards. As SPC can triggers diff --git a/lisp/simple.el b/lisp/simple.el index c79da7c9eeb..2c31621cfe1 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2273,7 +2273,7 @@ See `extended-command-versions'." (list (list "M-x " (lambda () read-extended-command-predicate)) (list "M-X " #'command-completion--command-for-this-buffer-function)) "Alist of prompts and what the extended command predicate should be. -This is used by the \\\\[execute-extended-command-cycle] command when reading an extended command.") +This is used by the \\\\[execute-extended-command-cycle] command when reading an extended command.") (defvar-keymap read-extended-command-mode-map :doc "Local keymap added to the current map when reading an extended command." @@ -9898,34 +9898,20 @@ makes it easier to edit it." ;; Define the major mode for lists of completions. -(defvar completion-list-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map special-mode-map) - (define-key map "g" nil) ;; There's nothing to revert from. - (define-key map [mouse-2] 'choose-completion) - (define-key map [follow-link] 'mouse-face) - (define-key map [down-mouse-2] nil) - (define-key map "\C-m" 'choose-completion) - (define-key map "\e\e\e" 'delete-completion-window) - (define-key map [remap keyboard-quit] #'delete-completion-window) - (define-key map [up] 'previous-line-completion) - (define-key map [down] 'next-line-completion) - (define-key map [left] 'previous-completion) - (define-key map [right] 'next-completion) - (define-key map [?\t] 'next-completion) - (define-key map [backtab] 'previous-completion) - (define-key map [M-up] 'minibuffer-previous-completion) - (define-key map [M-down] 'minibuffer-next-completion) - (define-key map "\M-\r" 'minibuffer-choose-completion) - (define-key map "z" 'kill-current-buffer) - (define-key map "n" 'next-completion) - (define-key map "p" 'previous-completion) - (define-key map "\M-g\M-c" 'switch-to-minibuffer) - map) - "Local map for completion list buffers.") - -;; Completion mode is suitable only for specially formatted data. -(put 'completion-list-mode 'mode-class 'special) +(defvar-keymap completion-list-mode-map + :doc "Local map for completion list buffers." + "RET" #'choose-completion + "" #'choose-completion + "" #'previous-line-completion + "" #'next-line-completion + "" #'previous-completion + "" #'next-completion + "" #'previous-completion + "TAB" #'next-completion + "p" #'previous-completion + "n" #'next-completion + "M-g M-c" #'switch-to-minibuffer + "" 'mouse-face) (defvar completion-reference-buffer nil "Record the buffer that was current when the completion list was requested. @@ -9959,17 +9945,6 @@ Called with three arguments (BEG END TEXT), it should replace the text between BEG and END with TEXT. Expected to be set buffer-locally in the *Completions* buffer.") -(defun delete-completion-window () - "Delete the completion list window. -Go to the window from which completion was requested." - (interactive) - (let ((buf completion-reference-buffer)) - (if (one-window-p t) - (if (window-dedicated-p) (delete-frame)) - (delete-window (selected-window)) - (if (get-buffer-window buf) - (select-window (get-buffer-window buf)))))) - (defcustom completion-auto-wrap t "Non-nil means to wrap around when selecting completion candidates. This affects the commands `next-completion', `previous-completion', @@ -10348,104 +10323,8 @@ back on `completion-list-insert-choice-function' when nil." (raise-frame (window-frame mini)))) (exit-minibuffer)))))))) -(define-derived-mode completion-list-mode nil - `("Completions" - (completion-style - (:eval (concat "[" - (propertize (symbol-name completion-style) - 'mouse-face 'mode-line-highlight - 'help-echo - (nth 3 (assoc completion-style - completion-styles-alist))) - "]")))) - "Major mode for buffers showing lists of possible completions. -Type \\\\[choose-completion] in the completion list\ - to select the completion near point. -Or click to select one with the mouse. - -See the `completions-format' user option to control how this -buffer is formatted. - -\\{completion-list-mode-map}") - -(defun completion-list-mode-finish () - "Finish setup of the completions buffer. -Called from `temp-buffer-show-hook'." - (when (eq major-mode 'completion-list-mode) - (setq buffer-read-only t))) - -(add-hook 'temp-buffer-show-hook 'completion-list-mode-finish) - - -;; Variables and faces used in `completion-setup-function'. - -(defcustom completion-show-help t - "Non-nil means show help message in *Completions* buffer." - :type 'boolean - :version "22.1" - :group 'completion) - -(define-minor-mode completions-narrow-mode - "Minor mode for *Completions* buffer with completions narrowing." - :interactive nil - :lighter " CompsNarrow") - -;; This function goes in completion-setup-hook, so that it is called -;; after the text of the completion list buffer is written. -(defun completion-setup-function () - (let* ((mainbuf (current-buffer)) - (base-dir - ;; FIXME: This is a bad hack. We try to set the default-directory - ;; in the *Completions* buffer so that the relative file names - ;; displayed there can be treated as valid file names, independently - ;; from the completion context. But this suffers from many problems: - ;; - It's not clear when the completions are file names. With some - ;; completion tables (e.g. bzr revision specs), the listed - ;; completions can mix file names and other things. - ;; - It doesn't pay attention to possible quoting. - ;; - With fancy completion styles, the code below will not always - ;; find the right base directory. - (if minibuffer-completing-file-name - (file-name-directory - (expand-file-name - (buffer-substring (minibuffer-prompt-end) (point)))))) - (narrow (and (functionp minibuffer-completion-predicate) - (let ((result nil)) - (advice-function-mapc - (lambda (_ alist) - (setq result (alist-get 'description alist))) - minibuffer-completion-predicate) - result)))) - (with-current-buffer standard-output - (let ((base-position completion-base-position) - (base-affixes completion-base-affixes) - (insert-fun completion-list-insert-choice-function) - (style completion-style)) - (completion-list-mode) - (setq-local completion-base-position base-position) - (setq-local completion-base-affixes base-affixes) - (setq-local completion-list-insert-choice-function insert-fun) - (setq-local completion-style style) - (when narrow (completions-narrow-mode))) - (setq-local completion-reference-buffer mainbuf) - (if base-dir (setq default-directory base-dir)) - (when completion-tab-width - (setq tab-width completion-tab-width)) - ;; Maybe enable cursor completions-highlight. - (when completions-highlight-face - (cursor-face-highlight-mode 1)) - ;; Maybe insert help string. - (when completion-show-help - (goto-char (point-min)) - (insert (substitute-command-keys - (if (display-mouse-p) - "Click or type \\[minibuffer-choose-completion] on a completion to select it.\n" - "Type \\[minibuffer-choose-completion] on a completion to select it.\n"))) - (insert (substitute-command-keys - "Type \\[minibuffer-next-completion] or \\[minibuffer-previous-completion] \ -to move point between completions.\n\n")))))) - -(add-hook 'completion-setup-hook #'completion-setup-function) +(define-derived-mode completion-list-mode special-mode "Completions" + "Major mode for buffers showing lists of possible completions.") (defun switch-to-completions () "Select the completion list window." diff --git a/lisp/window.el b/lisp/window.el index 62041d56280..6a279431f91 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -5151,6 +5151,8 @@ all window-local buffer lists." ;; Unrecord BUFFER in WINDOW. (unrecord-window-buffer window buffer))))) +(put 'replace-buffer-in-windows 'minibuffer-action 'display-buffer) + (defcustom quit-window-hook nil "Hook run before performing any other actions in the `quit-window' command." :type 'hook @@ -5332,15 +5334,19 @@ BUFFER-OR-NAME. Optional argument FRAME is handled as by This function calls `quit-window' on all candidate windows showing BUFFER-OR-NAME." (interactive "bQuit windows on (buffer):\nP") - (let ((buffer (window-normalize-buffer buffer-or-name)) - ;; Handle the "inverted" meaning of the FRAME argument wrt other - ;; `window-list-1' based function. - (all-frames (cond ((not frame) t) ((eq frame t) nil) (t frame)))) - (dolist (window (window-list-1 nil nil all-frames)) - (if (eq (window-buffer window) buffer) - (quit-window kill window) - ;; If a window doesn't show BUFFER, unrecord BUFFER in it. - (unrecord-window-buffer window buffer))))) + (save-selected-window + (let ((buffer (window-normalize-buffer buffer-or-name)) + ;; Handle the "inverted" meaning of the FRAME argument wrt other + ;; `window-list-1' based function. + (all-frames (cond ((not frame) t) ((eq frame t) nil) (t frame)))) + (dolist (window (window-list-1 nil nil all-frames)) + (if (eq (window-buffer window) buffer) + (quit-window kill window) + ;; If a window doesn't show BUFFER, unrecord BUFFER in it. + (unrecord-window-buffer window buffer)))))) + +(put 'quit-windows-on 'minibuffer-action "quit windows showing buffer") + (defun window--combination-resizable (parent &optional horizontal) "Return number of pixels recoverable from height of window PARENT. @@ -7874,6 +7880,10 @@ specified by the ACTION argument." (add-hook 'post-command-hook postfun))) (and (windowp window) window)))) +(put 'display-buffer 'minibuffer-action "display") +(put 'kill-buffer 'minibuffer-action "kill") ; Defined in buffer.c. + + (defun display-buffer-other-frame (buffer) "Display buffer BUFFER preferably in another frame. This function attempts to look for a window displaying BUFFER, @@ -8850,6 +8860,8 @@ at the front of the list of recently selected ones." ;; Return BUFFER even when we got no window. buffer)) +(put 'pop-to-buffer 'minibuffer-action 'display-buffer) + (defun pop-to-buffer-same-window (buffer &optional norecord) "Select buffer BUFFER in some window, preferably the same one. BUFFER may be a buffer, a string (a buffer name), or nil. If it @@ -8900,9 +8912,12 @@ Return the name of the buffer as a string. This function is intended for the `switch-to-buffer' family of commands since these need to omit the name of the current buffer from the list of completions and default values." - (let ((read-buffer-to-switch-current-buffer (current-buffer))) - (read-buffer prompt (other-buffer (current-buffer)) - (confirm-nonexistent-file-or-buffer)))) + (let ((buffer (current-buffer))) + (minibuffer-with-setup-hook + (lambda () + (setq-local read-buffer-to-switch-current-buffer buffer)) + (read-buffer prompt (other-buffer (current-buffer)) + (confirm-nonexistent-file-or-buffer))))) (defun window-normalize-buffer-to-switch-to (buffer-or-name) "Normalize BUFFER-OR-NAME argument of buffer switching functions. @@ -9091,6 +9106,8 @@ Return the buffer switched to." (select-window (selected-window))) (set-buffer buffer))) +(put 'switch-to-buffer 'minibuffer-action 'display-buffer) + (defun switch-to-buffer-other-window (buffer-or-name &optional norecord) "Select the buffer specified by BUFFER-OR-NAME in another window. BUFFER-OR-NAME may be a buffer, a string (a buffer name), or @@ -9116,6 +9133,8 @@ documentation for additional customization information." (let ((pop-up-windows t)) (pop-to-buffer buffer-or-name t norecord))) +(put 'switch-to-buffer-other-window 'minibuffer-action 'display-buffer) + (defun switch-to-buffer-other-frame (buffer-or-name &optional norecord) "Switch to buffer BUFFER-OR-NAME in another frame. BUFFER-OR-NAME may be a buffer, a string (a buffer name), or @@ -9144,6 +9163,8 @@ buffer at the front of the list of recently selected ones." (list (read-buffer-to-switch "Switch to buffer in other frame: "))) (pop-to-buffer buffer-or-name display-buffer--other-frame-action norecord)) +(put 'switch-to-buffer-other-frame 'minibuffer-action 'display-buffer) + (defun display-buffer-override-next-command (pre-function &optional post-function echo) "Set `display-buffer-overriding-action' for the next command. `pre-function' is called to prepare the window where the buffer should be diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el index e991a8c3bab..8c4f1e3887d 100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@ -503,8 +503,7 @@ (should (equal "a\nb" (get-text-property (point) 'completion--string)))))) (ert-deftest completions-header-format-test () - (let ((completion-show-help nil) - (completions-header-format nil)) + (let ((completions-header-format nil)) (completing-read-with-minibuffer-setup '("aa" "ab" "ac") (insert "a")