From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Eshel Yaron via "Bug reports for GNU Emacs, the Swiss army knife of text editors" Newsgroups: gmane.emacs.bugs Subject: bug#70381: [PATCH] New command 'completion-preview-complete' Date: Sun, 14 Apr 2024 16:05:20 +0200 Message-ID: References: <86plusm9uo.fsf@gnu.org> Reply-To: Eshel Yaron Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="19905"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: 70381@debbugs.gnu.org, spacibba@aol.com To: Eli Zaretskii Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Sun Apr 14 16:06:11 2024 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1rw0Uk-0004yf-KY for geb-bug-gnu-emacs@m.gmane-mx.org; Sun, 14 Apr 2024 16:06:10 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1rw0UU-0007Xr-CG; Sun, 14 Apr 2024 10:05:54 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1rw0US-0007XN-V0 for bug-gnu-emacs@gnu.org; Sun, 14 Apr 2024 10:05:52 -0400 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1rw0US-0008EF-MU for bug-gnu-emacs@gnu.org; Sun, 14 Apr 2024 10:05:52 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1rw0Ud-0001an-J7 for bug-gnu-emacs@gnu.org; Sun, 14 Apr 2024 10:06:03 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Eshel Yaron Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sun, 14 Apr 2024 14:06:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 70381 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 70381-submit@debbugs.gnu.org id=B70381.17131035506036 (code B ref 70381); Sun, 14 Apr 2024 14:06:03 +0000 Original-Received: (at 70381) by debbugs.gnu.org; 14 Apr 2024 14:05:50 +0000 Original-Received: from localhost ([127.0.0.1]:35922 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rw0UK-0001YV-Sm for submit@debbugs.gnu.org; Sun, 14 Apr 2024 10:05:50 -0400 Original-Received: from mail.eshelyaron.com ([107.175.124.16]:43216 helo=eshelyaron.com) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1rw0UA-0001Wg-Pg for 70381@debbugs.gnu.org; Sun, 14 Apr 2024 10:05:42 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=eshelyaron.com; s=mail; t=1713103523; bh=3n6Ci4V0FRFEZ7AcnNzZ71LmEYmicDVwn8VRzps8QJA=; h=From:To:Cc:Subject:In-Reply-To:References:Date:From; b=RXEOn8CVg/iDzyCY7i1OBFklsAIG7fkNPo1baWXKQwTuzfMnBQ/AKSrFyDAAUQe55 M3ISAqw7nyfWn3/Qcb7uUCdLcTShQo8jgnZxEtDgQn+fv+6rxaKdkBDuponkk8FUkJ neLTvlyvTEUvZfeMGLHx6Afwvo94PI67yP7oB7PQ8OIZX/PJD4cg2J/fC/K4ub9OT8 bTGZvUe7mgezxEOG49ur4khbn+hYlejGzSBCT/ZQbVAL+Xi5K83Yuxpflnbek5ov3U pLf+slqICUhuLUkOgGBBDmbjUyGaOIYj12Qtwg+J7AZP27nMCMoM6ZiwnNoOTLCk+m 5dhq7C/hzs7Mw== In-Reply-To: <86plusm9uo.fsf@gnu.org> (Eli Zaretskii's message of "Sun, 14 Apr 2024 15:01:35 +0300") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.bugs:283279 Archived-At: --=-=-= Content-Type: text/plain Eli Zaretskii writes: >> Cc: Ergus >> Date: Sun, 14 Apr 2024 13:21:54 +0200 >> From: Eshel Yaron via "Bug reports for GNU Emacs, >> the Swiss army knife of text editors" >> >> Following a recent discussion on emacs-devel[0], this patch adds a new >> command for Completion Preview mode that completes the symbol at point up >> to the longest common prefix of all completion candidates. This patch >> also adds a visual indication for the longest common prefix when showing >> it as part of the completion preview, so the user can tell how far the new >> 'completion-preview-complete' will complete before invoking this command. >> For example, if the symbol at point is "foo", and the completion >> candidates are "foobar" and "foobaz", then the preview shows "bar" with >> the common prefix "ba" highlighted in face 'completion-preview-common'. > > Thanks. > >> * lisp/completion-preview.el (completion-preview--try-table): >> Return longest common prefix and list of suffixes instead of >> list of full candidates. Add illustrative comment. >> (completion-preview--capf-wrapper, completion-preview--update) >> (completion-preview--show, completion-preview-insert) >> (completion-preview-next-candidate): Adjust. >> (completion-preview-common): New face. >> (completion-preview-exact): Distinguish from 'c-p-common'. >> (completion-preview-complete): New command. ^^^^^^^^^^ >> (completion-preview-active-mode-map): Bind it. >> (completion-preview-mode): Mention it in docstring. >> (completion-preview-commands): Add 'c-p-complete'. > ^^^^^^^^^^^^ > Please don't abbreviate symbols in the log entries. Those are > frequently used to search for changes of functions/variables, and such > abbreviations defeat those searches. All right, fixed in the updated patch below. > If you are annoyed by the need to type long strings, I usually find > M-/ instrumental in reducing that annoyance considerably. > >> +(defface completion-preview-common >> '((((supports :underline t)) >> :underline t :inherit completion-preview) >> (((supports :weight bold)) >> :weight bold :inherit completion-preview) >> (t :background "gray")) >> - "Face for exact completion preview overlay." >> + "Face for completions longest common prefix in the completion preview." > ^^^^^^^^^^^ > This word is redundant here. I'd replace it with "the". Done. >> +(defvar-local completion-preview--inhibit-update-p nil >> + "Whether to inhibit updateing the completion preview following this command.") > ^^^^^^^^^ > "updating" Fixed. >> + (set-text-properties 0 (length suffix) >> + `(face ,(if (cdr suffixes) >> + 'completion-preview >> + 'completion-preview-exact)) >> + suffix) >> + (set-text-properties 0 (length common) >> + `(face ,(if (cdr suffixes) >> + 'completion-preview-common >> + 'completion-preview-exact)) >> + common) > > Is the use of back-ticks really necessary here? > >> + (set-text-properties 0 (length suffix) >> + `(face ,(if (cdr sufs) >> + 'completion-preview >> + 'completion-preview-exact)) >> + suffix) > > Likewise here (and in few other places). Not necessary, no. So I've changed these to regular (list ...) forms. I kept a couple of other backticks that do make the code clearer IMO. Thanks for taking a look, here's the updated patch: --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=v2-0001-New-command-completion-preview-complete.patch >From a3e34613e16e56bf4cc1aaebb68835c6ec60febe Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Fri, 12 Apr 2024 22:41:10 +0200 Subject: [PATCH v2] New command 'completion-preview-complete' This command completes the symbol at point up to the longest common prefix of all completions candidates. We also add an indication of the longest common prefix in the completion preview by highlighting that part of the preview with the 'completion-preview-exact' face. To facilitate these features we change the way we store the completion candidates while the preview is visible, to explicitly keep the common prefix along with a list of its suffixes. * lisp/completion-preview.el (completion-preview--try-table): Return longest common prefix and list of suffixes instead of list of full candidates. Add illustrative comment. (completion-preview--capf-wrapper, completion-preview--update) (completion-preview--show, completion-preview-insert) (completion-preview-next-candidate): Adjust. (completion-preview-common): New face. (completion-preview-exact): Tweak to distinguish it from 'completion-preview-common'. (completion-preview-complete): New command. (completion-preview-active-mode-map): Bind it. (completion-preview-mode): Mention it in docstring. (completion-preview-commands): Add 'completion-preview-complete'. (completion-preview--make-overlay): Simplify. (completion-preview--internal-command-p): Remove. (completion-preview-require-certain-commands): Update. (completion-preview--inhibit-update): New inline function. (completion-preview--inhibit-update-p): New local variable. (completion-preview--post-command, completion-preview-hide): Reset it to nil. * test/lisp/completion-preview-tests.el (completion-preview-tests--check-preview): Check the 'face' property of both the first and last character. Update callers. (completion-preview-insert-calls-exit-function) (completion-preview-complete): New tests. --- lisp/completion-preview.el | 282 +++++++++++++++++++------- test/lisp/completion-preview-tests.el | 147 ++++++++++++-- 2 files changed, 335 insertions(+), 94 deletions(-) diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el index 4e52aa9b151..8bc8cadc46b 100644 --- a/lisp/completion-preview.el +++ b/lisp/completion-preview.el @@ -39,6 +39,16 @@ ;; example, to M-n and M-p in `completion-preview-active-mode-map' to ;; have them handy whenever the preview is visible. ;; +;; When the completion candidate that the preview is showing shares a +;; common prefix with all other candidates, Completion Preview mode +;; underlines that common prefix. If you want to insert the common +;; prefix but with a different suffix than the one the preview is +;; showing, use the command `completion-preview-complete'. This command +;; inserts just the common prefix and lets you go on typing as usual. +;; If you invoke `completion-preview-complete' when there is no common +;; prefix (so nothing is underlined in the preview), it displays a list +;; of all matching completion candidates. +;; ;; If you set the user option `completion-preview-exact-match-only' to ;; non-nil, Completion Preview mode only suggests a completion ;; candidate when its the only possible completion for the (partial) @@ -73,7 +83,8 @@ completion-preview-commands insert-char delete-backward-char backward-delete-char-untabify - analyze-text-conversion) + analyze-text-conversion + completion-preview-complete) "List of commands that should trigger completion preview." :type '(repeat (function :tag "Command" :value self-insert-command)) :version "30.1") @@ -104,16 +115,22 @@ completion-preview-sort-function (defface completion-preview '((t :inherit shadow)) - "Face for completion preview overlay." + "Face for completion candidates in the completion preview overlay." :version "30.1") -(defface completion-preview-exact +(defface completion-preview-common '((((supports :underline t)) :underline t :inherit completion-preview) (((supports :weight bold)) :weight bold :inherit completion-preview) (t :background "gray")) - "Face for exact completion preview overlay." + "Face for the longest common prefix in the completion preview." + :version "30.1") + +(defface completion-preview-exact + ;; An exact match is also the longest common prefix of all matches. + '((t :underline "gray25" :inherit completion-preview-common)) + "Face for matches in the completion preview overlay." :version "30.1") (defface completion-preview-highlight @@ -124,6 +141,8 @@ completion-preview-highlight (defvar-keymap completion-preview-active-mode-map :doc "Keymap for Completion Preview Active mode." "C-i" #'completion-preview-insert + ;; FIXME: Should this have another/better binding by default? + "M-i" #'completion-preview-complete ;; "M-n" #'completion-preview-next-candidate ;; "M-p" #'completion-preview-prev-candidate ) @@ -131,8 +150,8 @@ completion-preview-active-mode-map (defvar-keymap completion-preview--mouse-map :doc "Keymap for mouse clicks on the completion preview." "" #'completion-preview-insert - "C-" #'completion-at-point - "" #'completion-at-point + "C-" #'completion-preview-complete + "" #'completion-preview-complete "" #'completion-preview-prev-candidate "" #'completion-preview-next-candidate) @@ -147,14 +166,16 @@ completion-preview--internal-commands Completion Preview mode avoids updating the preview after these commands.") -(defsubst completion-preview--internal-command-p () - "Return non-nil if `this-command' manipulates the completion preview." - (memq this-command completion-preview--internal-commands)) +(defvar-local completion-preview--inhibit-update-p nil + "Whether to inhibit updating the completion preview following this command.") + +(defsubst completion-preview--inhibit-update () + "Inhibit updating the completion preview following this command." + (setq completion-preview--inhibit-update-p t)) (defsubst completion-preview-require-certain-commands () "Check if `this-command' is one of `completion-preview-commands'." - (or (completion-preview--internal-command-p) - (memq this-command completion-preview-commands))) + (memq this-command completion-preview-commands)) (defun completion-preview-require-minimum-symbol-length () "Check if the length of symbol at point is at least above a certain threshold. @@ -167,7 +188,8 @@ completion-preview-hide "Hide the completion preview." (when completion-preview--overlay (delete-overlay completion-preview--overlay) - (setq completion-preview--overlay nil))) + (setq completion-preview--overlay nil + completion-preview--inhibit-update-p nil))) (defun completion-preview--make-overlay (pos string) "Make preview overlay showing STRING at POS, or move existing preview there." @@ -175,13 +197,9 @@ completion-preview--make-overlay (move-overlay completion-preview--overlay pos pos) (setq completion-preview--overlay (make-overlay pos pos)) (overlay-put completion-preview--overlay 'window (selected-window))) - (let ((previous (overlay-get completion-preview--overlay 'after-string))) - (unless (and previous (string= previous string) - (eq (get-text-property 0 'face previous) - (get-text-property 0 'face string))) - (add-text-properties 0 1 '(cursor 1) string) - (overlay-put completion-preview--overlay 'after-string string)) - completion-preview--overlay)) + (add-text-properties 0 1 '(cursor 1) string) + (overlay-put completion-preview--overlay 'after-string string) + completion-preview--overlay) (defsubst completion-preview--get (prop) "Return property PROP of the completion preview overlay." @@ -221,17 +239,25 @@ completion-preview--try-table PROPS is a property list with additional information about TABLE. See `completion-at-point-functions' for more details. -If TABLE contains a matching completion, return a list -\(PREVIEW BEG END ALL BASE EXIT-FN) where PREVIEW is the text to -show in the completion preview, ALL is the list of all matching -completion candidates, BASE is a common prefix that TABLE elided -from the start of each candidate, and EXIT-FN is either a -function to call after inserting PREVIEW or nil. If TABLE does -not contain matching completions, or if there are multiple -matching completions and `completion-preview-exact-match-only' is -non-nil, return nil instead." +If TABLE contains a matching candidate, return a list +\(BASE COMMON SUFFIXES) where BASE is a prefix of the text +between BEG and END that TABLE elided from the start of each candidate, +COMMON is the longest common prefix of all matching candidates, +SUFFIXES is a list of different suffixes that together with COMMON yield +the matching candidates. If TABLE does not contain matching +candidates or if there are multiple matching completions and +`completion-preview-exact-match-only' is non-nil, return nil instead." + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ;; + ;; | buffer text | preview | ;; + ;; | | | ;; + ;; beg end | ;; + ;; |------+------|--+--------| Each of base, common and suffix ;; + ;; | base | common | suffix | <- may be empty, except common and ;; + ;; suffix cannot both be empty. ;; + ;; ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((pred (plist-get props :predicate)) - (exit-fn (plist-get props :exit-function)) (string (buffer-substring beg end)) (md (completion-metadata string table pred)) (sort-fn (or (completion-metadata-get md 'cycle-sort-function) @@ -250,16 +276,16 @@ completion-preview--try-table (when last (setcdr last nil) (when-let ((sorted (funcall sort-fn - (delete prefix (all-completions prefix all))))) - (unless (and (cdr sorted) completion-preview-exact-match-only) - (list (propertize (substring (car sorted) (length prefix)) - 'face (if (cdr sorted) - 'completion-preview - 'completion-preview-exact) - 'mouse-face 'completion-preview-highlight - 'keymap completion-preview--mouse-map) - (+ beg base) end sorted - (substring string 0 base) exit-fn)))))) + (delete prefix (all-completions prefix all)))) + (common (try-completion prefix sorted)) + (lencom (length common)) + (suffixes sorted)) + (unless (and (cdr suffixes) completion-preview-exact-match-only) + ;; Remove the common prefix from each candidate. + (while sorted + (setcar sorted (substring (car sorted) lencom)) + (setq sorted (cdr sorted))) + (list (substring string 0 base) common suffixes)))))) (defun completion-preview--capf-wrapper (capf) "Translate return value of CAPF to properties for completion preview overlay." @@ -267,25 +293,41 @@ completion-preview--capf-wrapper (and (consp res) (not (functionp res)) (seq-let (beg end table &rest plist) res - (or (completion-preview--try-table table beg end plist) + (or (when-let ((data (completion-preview--try-table + table beg end plist))) + `(,(+ beg (length (car data))) ,end ,plist ,@data)) (unless (eq 'no (plist-get plist :exclusive)) ;; Return non-nil to exclude other capfs. '(nil))))))) (defun completion-preview--update () "Update completion preview." - (seq-let (preview beg end all base exit-fn) + (seq-let (beg end props base common suffixes) (run-hook-wrapped 'completion-at-point-functions #'completion-preview--capf-wrapper) - (when preview - (let ((ov (completion-preview--make-overlay end preview))) + (when-let ((suffix (car suffixes))) + (set-text-properties 0 (length suffix) + (list 'face (if (cdr suffixes) + 'completion-preview + 'completion-preview-exact)) + suffix) + (set-text-properties 0 (length common) + (list 'face (if (cdr suffixes) + 'completion-preview-common + 'completion-preview-exact)) + common) + (let ((ov (completion-preview--make-overlay + end (propertize (concat (substring common (- end beg)) suffix) + 'mouse-face 'completion-preview-highlight + 'keymap completion-preview--mouse-map)))) (overlay-put ov 'completion-preview-beg beg) (overlay-put ov 'completion-preview-end end) (overlay-put ov 'completion-preview-index 0) - (overlay-put ov 'completion-preview-cands all) + (overlay-put ov 'completion-preview-suffixes suffixes) + (overlay-put ov 'completion-preview-common common) (overlay-put ov 'completion-preview-base base) - (overlay-put ov 'completion-preview-exit-fn exit-fn) + (overlay-put ov 'completion-preview-props props) (completion-preview-active-mode))))) (defun completion-preview--show () @@ -308,17 +350,22 @@ completion-preview--show ;; flicker, even with slow completion backends. (let* ((beg (completion-preview--get 'completion-preview-beg)) (end (max (point) (overlay-start completion-preview--overlay))) - (cands (completion-preview--get 'completion-preview-cands)) + (sufs (completion-preview--get 'completion-preview-suffixes)) (index (completion-preview--get 'completion-preview-index)) - (cand (nth index cands)) - (after (completion-preview--get 'after-string)) - (face (get-text-property 0 'face after))) + (common (completion-preview--get 'completion-preview-common)) + (suffix (nth index sufs)) + (cand nil)) + (set-text-properties 0 (length suffix) + (list 'face (if (cdr sufs) + 'completion-preview + 'completion-preview-exact)) + suffix) + (setq cand (concat common (nth index sufs))) (if (and (<= beg (point) end (1- (+ beg (length cand)))) (string-prefix-p (buffer-substring beg end) cand)) ;; The previous preview is still applicable, update it. (overlay-put (completion-preview--make-overlay end (propertize (substring cand (- end beg)) - 'face face 'mouse-face 'completion-preview-highlight 'keymap completion-preview--mouse-map)) 'completion-preview-end end) @@ -329,16 +376,18 @@ completion-preview--show (defun completion-preview--post-command () "Create, update or delete completion preview post last command." - (if (and (completion-preview-require-certain-commands) - (completion-preview-require-minimum-symbol-length)) - ;; We should show the preview. - (or - ;; If we're called after a command that itself updates the - ;; preview, don't do anything. - (completion-preview--internal-command-p) - ;; Otherwise, show the preview. - (completion-preview--show)) - (completion-preview-active-mode -1))) + (let ((internal-p (or completion-preview--inhibit-update-p + (memq this-command + completion-preview--internal-commands)))) + (setq completion-preview--inhibit-update-p nil) + + ;; If we're called after a command that itself updates the + ;; preview, don't do anything. + (unless internal-p + (if (and (completion-preview-require-certain-commands) + (completion-preview-require-minimum-symbol-length)) + (completion-preview--show) + (completion-preview-active-mode -1))))) (defun completion-preview-insert () "Insert the completion candidate that the preview is showing." @@ -347,16 +396,84 @@ completion-preview-insert (let* ((pre (completion-preview--get 'completion-preview-base)) (end (completion-preview--get 'completion-preview-end)) (ind (completion-preview--get 'completion-preview-index)) - (all (completion-preview--get 'completion-preview-cands)) - (efn (completion-preview--get 'completion-preview-exit-fn)) + (all (completion-preview--get 'completion-preview-suffixes)) + (com (completion-preview--get 'completion-preview-common)) + (efn (plist-get (completion-preview--get 'completion-preview-props) + :exit-function)) (aft (completion-preview--get 'after-string)) - (str (concat pre (nth ind all)))) + (str (concat pre com (nth ind all)))) (completion-preview-active-mode -1) (goto-char end) (insert (substring-no-properties aft)) (when (functionp efn) (funcall efn str 'finished))) (user-error "No current completion preview"))) +(defun completion-preview-complete () + "Complete up to the longest common prefix of all completion candidates. + +If you call this command twice in a row, or otherwise if there is no +common prefix to insert, it displays the list of matching completion +candidates unless `completion-auto-help' is nil. If you repeat this +command again when the completions list is visible, it scrolls the +completions list." + (interactive) + (unless completion-preview-active-mode + (user-error "No current completion preview")) + (let* ((beg (completion-preview--get 'completion-preview-beg)) + (end (completion-preview--get 'completion-preview-end)) + (com (completion-preview--get 'completion-preview-common)) + (cur (completion-preview--get 'completion-preview-index)) + (all (completion-preview--get 'completion-preview-suffixes)) + (base (completion-preview--get 'completion-preview-base)) + (props (completion-preview--get 'completion-preview-props)) + (efn (plist-get props :exit-function)) + (ins (substring-no-properties com (- end beg)))) + (goto-char end) + (if (string-empty-p ins) + ;; If there's nothing to insert, call `completion-at-point' to + ;; show the completions list (or just display a message when + ;; `completion-auto-help' is nil). + (let* ((completion-styles completion-preview-completion-styles) + (sub (substring-no-properties com)) + (col (mapcar (lambda (suf) + (concat sub (substring-no-properties suf))) + (append (nthcdr cur all) (take cur all)))) + ;; The candidates are already in order. + (props (plist-put props :display-sort-function #'identity)) + ;; The :exit-function might be slow, e.g. when the + ;; backend is Eglot, so we ensure that the preview is + ;; hidden before any original :exit-function is called. + (props (plist-put props :exit-function + (when (functionp efn) + (lambda (string status) + (completion-preview-active-mode -1) + (funcall efn string status))))) + ;; The predicate is meant for the original completion + ;; candidates, which may be symbols or cons cells, but + ;; now we only have strings, so it might be unapplicable. + (props (plist-put props :predicate nil)) + (completion-at-point-functions + (list (lambda () `(,beg ,end ,col ,@props))))) + (completion-preview--inhibit-update) + (completion-at-point)) + ;; Otherwise, insert the common prefix and update the preview. + (insert ins) + (let ((suf (nth cur all)) + (pos (point))) + (if (or (string-empty-p suf) (null suf)) + ;; If we've inserted a full candidate, let the post-command + ;; hook update the completion preview in case the candidate + ;; can be completed further. + (when (functionp efn) + (funcall efn (concat base com) (if (cdr all) 'exact 'finished))) + ;; Otherwise, remove the common prefix from the preview. + (completion-preview--inhibit-update) + (overlay-put (completion-preview--make-overlay + pos (propertize + suf 'mouse-face 'completion-preview-highlight + 'keymap completion-preview--mouse-map)) + 'completion-preview-end pos)))))) + (defun completion-preview-prev-candidate () "Cycle the candidate that the preview is showing to the previous suggestion." (interactive) @@ -372,18 +489,29 @@ completion-preview-next-candidate (when completion-preview-active-mode (let* ((beg (completion-preview--get 'completion-preview-beg)) (end (completion-preview--get 'completion-preview-end)) - (all (completion-preview--get 'completion-preview-cands)) + (all (completion-preview--get 'completion-preview-suffixes)) + (com (completion-preview--get 'completion-preview-common)) (cur (completion-preview--get 'completion-preview-index)) (len (length all)) (new (mod (+ cur direction) len)) - (str (nth new all))) - (while (or (<= (+ beg (length str)) end) - (not (string-prefix-p (buffer-substring beg end) str))) - (setq new (mod (+ new direction) len) str (nth new all))) - (let ((aft (propertize (substring str (- end beg)) - 'face (if (< 1 len) - 'completion-preview - 'completion-preview-exact) + (suf (nth new all)) + (lencom (length com))) + ;; Skip suffixes that are no longer applicable. This may happen + ;; when the user continues typing and immediately runs this + ;; command, before the completion backend returns an updated set + ;; of completions for the new (longer) prefix, so we still have + ;; the previous (larger) set of candidates at hand. + (while (or (<= (+ beg lencom (length suf)) end) + (not (string-prefix-p (buffer-substring beg end) + (concat com suf)))) + (setq new (mod (+ new direction) len) + suf (nth new all))) + (set-text-properties 0 (length suf) + (list 'face (if (cdr all) + 'completion-preview + 'completion-preview-exact)) + suf) + (let ((aft (propertize (substring (concat com suf) (- end beg)) 'mouse-face 'completion-preview-highlight 'keymap completion-preview--mouse-map))) (add-text-properties 0 1 '(cursor 1) aft) @@ -398,6 +526,7 @@ completion-preview--active-p (buffer-local-value 'completion-preview-active-mode buffer)) (dolist (cmd '(completion-preview-insert + completion-preview-complete completion-preview-prev-candidate completion-preview-next-candidate)) (put cmd 'completion-predicate #'completion-preview--active-p)) @@ -409,11 +538,12 @@ completion-preview-mode This mode automatically shows and updates the completion preview according to the text around point. \\\ -When the preview is visible, \\[completion-preview-insert] -accepts the completion suggestion, +When the preview is visible, \\[completion-preview-insert] accepts the +completion suggestion, \\[completion-preview-complete] completes up to +the longest common prefix of all completion candidates, \\[completion-preview-next-candidate] cycles forward to the next -completion suggestion, and \\[completion-preview-prev-candidate] -cycles backward." +completion suggestion, and \\[completion-preview-prev-candidate] cycles +backward." :lighter " CP" (if completion-preview-mode (add-hook 'post-command-hook #'completion-preview--post-command nil t) diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el index 5b2c28bd3dd..7d358d07519 100644 --- a/test/lisp/completion-preview-tests.el +++ b/test/lisp/completion-preview-tests.el @@ -27,23 +27,25 @@ completion-preview-tests--capf (when-let ((bounds (bounds-of-thing-at-point 'symbol))) (append (list (car bounds) (cdr bounds) completions) props)))) -(defun completion-preview-tests--check-preview (string &optional exact) +(defun completion-preview-tests--check-preview + (string &optional beg-face end-face) "Check that the completion preview is showing STRING. -If EXACT is non-nil, check that STRING has the -`completion-preview-exact' face. Otherwise check that STRING has -the `completion-preview' face. +BEG-FACE and END-FACE say which faces the beginning and end of STRING +should have, respectively. Both BEG-FACE and END-FACE default to +`completion-preview'. If STRING is nil, check that there is no completion preview instead." (if (not string) - (should (not completion-preview--overlay)) + (should-not completion-preview--overlay) (should completion-preview--overlay) (let ((after-string (completion-preview--get 'after-string))) (should (string= after-string string)) (should (eq (get-text-property 0 'face after-string) - (if exact - 'completion-preview-exact + (or beg-face 'completion-preview))) + (should (eq (get-text-property (1- (length after-string)) 'face after-string) + (or end-face 'completion-preview)))))) (ert-deftest completion-preview () @@ -57,7 +59,9 @@ completion-preview (completion-preview--post-command)) ;; Exact match - (completion-preview-tests--check-preview "barbaz" 'exact) + (completion-preview-tests--check-preview "barbaz" + 'completion-preview-exact + 'completion-preview-exact) (insert "v") (let ((this-command 'self-insert-command)) @@ -71,7 +75,9 @@ completion-preview (completion-preview--post-command)) ;; Exact match again - (completion-preview-tests--check-preview "barbaz" 'exact))) + (completion-preview-tests--check-preview "barbaz" + 'completion-preview-exact + 'completion-preview-exact))) (ert-deftest completion-preview-multiple-matches () "Test Completion Preview mode with multiple matching candidates." @@ -84,12 +90,12 @@ completion-preview-multiple-matches (completion-preview--post-command)) ;; Multiple matches, the preview shows the first one - (completion-preview-tests--check-preview "bar") + (completion-preview-tests--check-preview "bar" 'completion-preview-common) (completion-preview-next-candidate 1) ;; Next match - (completion-preview-tests--check-preview "baz"))) + (completion-preview-tests--check-preview "baz" 'completion-preview-common))) (ert-deftest completion-preview-exact-match-only () "Test `completion-preview-exact-match-only'." @@ -111,7 +117,9 @@ completion-preview-exact-match-only (completion-preview--post-command)) ;; Exact match - (completion-preview-tests--check-preview "m" 'exact))) + (completion-preview-tests--check-preview "m" + 'completion-preview-exact + 'completion-preview-exact))) (ert-deftest completion-preview-function-capfs () "Test Completion Preview mode with capfs that return a function." @@ -124,7 +132,7 @@ completion-preview-function-capfs (insert "foo") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "bar"))) + (completion-preview-tests--check-preview "bar" 'completion-preview-common))) (ert-deftest completion-preview-non-exclusive-capfs () "Test Completion Preview mode with non-exclusive capfs." @@ -140,11 +148,13 @@ completion-preview-non-exclusive-capfs (insert "foo") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "bar") + (completion-preview-tests--check-preview "bar" 'completion-preview-common) (setq-local completion-preview-exact-match-only t) (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "barbaz" 'exact))) + (completion-preview-tests--check-preview "barbaz" + 'completion-preview-exact + 'completion-preview-exact))) (ert-deftest completion-preview-face-updates () "Test updating the face in completion preview when match is no longer exact." @@ -160,7 +170,9 @@ completion-preview-face-updates (insert "b") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "arbaz" 'exact) + (completion-preview-tests--check-preview "arbaz" + 'completion-preview-exact + 'completion-preview-exact) (delete-char -1) (let ((this-command 'delete-backward-char)) (completion-preview--post-command)) @@ -173,13 +185,15 @@ completion-preview-capf-errors (with-temp-buffer (setq-local completion-at-point-functions (list - (lambda () (user-error "bad")) + (lambda () (user-error "Bad")) (completion-preview-tests--capf '("foobarbaz")))) (insert "foo") (let ((this-command 'self-insert-command)) (completion-preview--post-command)) - (completion-preview-tests--check-preview "barbaz" 'exact))) + (completion-preview-tests--check-preview "barbaz" + 'completion-preview-exact + 'completion-preview-exact))) (ert-deftest completion-preview-mid-symbol-cycle () "Test cycling the completion preview with point at the middle of a symbol." @@ -196,4 +210,101 @@ completion-preview-mid-symbol-cycle (completion-preview-next-candidate 1) (completion-preview-tests--check-preview "z"))) +(ert-deftest completion-preview-complete () + "Test `completion-preview-complete'." + (with-temp-buffer + (let ((exit-fn-called nil) + (exit-fn-args nil) + (message-args nil) + (completion-auto-help nil)) + (setq-local completion-at-point-functions + (list + (completion-preview-tests--capf + '("foobar" "foobaz" "foobash" "foobash-mode") + :exit-function + (lambda (&rest args) + (setq exit-fn-called t + exit-fn-args args))))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (message "here") + + (completion-preview-tests--check-preview "bar" 'completion-preview-common) + + ;; Insert the common prefix, "ba". + (completion-preview-complete) + + ;; Only "r" should remain. + (completion-preview-tests--check-preview "r") + + (cl-letf (((symbol-function #'minibuffer-message) + (lambda (&rest args) (setq message-args args)))) + + ;; With `completion-auto-help' set to nil, a second call to + ;; `completion-preview-complete' just displays a message. + (completion-preview-complete) + (setq completion-preview--inhibit-update-p nil) + + (should (equal message-args '("Next char not unique")))) + + ;; The preview should stay put. + (completion-preview-tests--check-preview "r") + ;; (completion-preview-active-mode -1) + + ;; Narrow further. + (insert "s") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; The preview should indicate an exact match. + (completion-preview-tests--check-preview "h" + 'completion-preview-common + 'completion-preview-common) + + ;; Insert the entire preview content. + (completion-preview-complete) + (setq completion-preview--inhibit-update-p nil) + (let ((this-command 'completion-preview-complete)) + (completion-preview--post-command)) + + ;; The preview should update to indicate that there's a further + ;; possible completion. + (completion-preview-tests--check-preview "-mode" + 'completion-preview-exact + 'completion-preview-exact) + (should exit-fn-called) + (should (equal exit-fn-args '("foobash" exact))) + (setq exit-fn-called nil exit-fn-args nil) + + ;; Insert the extra suffix. + (completion-preview-complete) + + ;; Nothing more to show, so the preview should now be gone. + (should-not completion-preview--overlay) + (should exit-fn-called) + (should (equal exit-fn-args '("foobash-mode" finished)))))) + +(ert-deftest completion-preview-insert-calls-exit-function () + "Test that `completion-preview-insert' calls the completion exit function." + (let ((exit-fn-called nil) (exit-fn-args nil)) + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (completion-preview-tests--capf + '("foobar" "foobaz") + :exit-function + (lambda (&rest args) + (setq exit-fn-called t + exit-fn-args args))))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "bar" 'completion-preview-common) + (completion-preview-insert) + (should (string= (buffer-string) "foobar")) + (should-not completion-preview--overlay) + (should exit-fn-called) + (should (equal exit-fn-args '("foobar" finished)))))) + ;;; completion-preview-tests.el ends here -- 2.44.0 --=-=-=--