From: Eshel Yaron Date: Fri, 1 Mar 2024 16:59:44 +0000 (+0100) Subject: ; Resurrect 'display-completion-list' X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=5b9b4a88b7eab961e8f37a1cc3966c0648340b48;p=emacs.git ; Resurrect 'display-completion-list' --- diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 5c93636ea07..fc039d40d2a 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -290,8 +290,7 @@ that fails this command prompts you for the separator to use." (defun crm-completions-setup () "Enable `completions-multi-mode' in *Completions* buffer." - (with-current-buffer (window-buffer minibuffer-scroll-window) - (completions-multi-mode))) + (with-current-buffer standard-output (completions-multi-mode))) (define-obsolete-variable-alias 'crm-local-completion-map 'completing-read-multiple-mode-map "30.1") diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 44578f2ad2d..d4aa002e35a 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2285,6 +2285,7 @@ completions." :version "28.1") (defvar-local completions-candidates nil) +(defvar-local completions-group-function nil) (defvar-local completions-category nil) (defvar-local completions-sort-function nil) (defvar-local completions-sort-orders nil) @@ -2884,26 +2885,7 @@ completions list." (completion--message "Sole completion") (completion--fail))) - (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))) + (let* ((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))) @@ -2935,13 +2917,7 @@ completions list." (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) - (action (minibuffer-completion-action)) - (mainbuf (current-buffer))) + (action (minibuffer-completion-action))) (minibuffer--cache-completion-input (substring string base-size) full-base) (when last (setcdr last nil)) @@ -3008,83 +2984,141 @@ completions list." (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))))) + (let ((standard-output (get-buffer-create "*Completions*"))) + (completions-display + completions + :group-function group-fun + :style style + :category category + :sort-function explicit-sort-function + :sort-orders sort-orders + :predicate cpred + :action action + :base-position (list (+ start base-size) end) + :base-affixes (list base-prefix base-suffix) + :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)))))))))))) + +(defun completions-setup () + "Set up the current buffer for displaying a list of completions." + (completion-list-mode) + (when completion-tab-width (setq tab-width completion-tab-width)) + (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)) + +(defun completions-display (completions &rest plist) + "Display COMPLETIONS in the buffer specified by `standard-output'. + +PLIST is a property list with optional extra information about COMPLETIONS." + (let* ((mainbuf (current-buffer)) + (buf standard-output) + (group-fun (plist-get plist :group-function)) + (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))))))))) + (with-current-buffer buf + (completions-setup) + (let ((inhibit-read-only t)) + (erase-buffer) + (delete-all-overlays) + (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-local + completion-reference-buffer mainbuf + completions-candidates completions + completions-group-function group-fun + completions-style (plist-get plist :style) + completion-base-position (plist-get plist :base-position) + completion-base-affixes (plist-get plist :base-affixes) + completion-list-insert-choice-function (plist-get plist :insert-choice-function) + completions-category (plist-get plist :category) + completions-sort-function (plist-get plist :sort-function) + completions-sort-orders (plist-get plist :sort-orders) + completions-predicate (plist-get plist :predicate) + completions-action (plist-get plist :action))) + (run-hooks 'completion-setup-hook) + (display-buffer buf + '((display-buffer-reuse-window display-buffer-at-bottom) + (window-height . completions--fit-window-to-buffer) + (preserve-size . (nil . t)) + (dedicated . soft))))) + +(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'." + (completions-display completions :group-function group-fun)) (defun minibuffer-hide-completions () "Get rid of an out-of-date *Completions* buffer."