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" <bug-gnu-emacs@gnu.org>
Newsgroups: gmane.emacs.bugs
Subject: bug#67275: [PATCH] ; Improve and add tests for Completion Preview mode
Date: Sun, 19 Nov 2023 11:25:55 +0100
Message-ID: <m1sf529gzw.fsf@dazzs-mbp.home>
Reply-To: Eshel Yaron <me@eshelyaron.com>
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="27029"; mail-complaints-to="usenet@ciao.gmane.io"
User-Agent: Gnus/5.13 (Gnus v5.13)
To: 67275@debbugs.gnu.org
Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Sun Nov 19 11:27:19 2023
Return-path: <bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org>
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 <bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org>)
	id 1r4f1K-0006nZ-Jf
	for geb-bug-gnu-emacs@m.gmane-mx.org; Sun, 19 Nov 2023 11:27:18 +0100
Original-Received: from localhost ([::1] helo=lists1p.gnu.org)
	by lists.gnu.org with esmtp (Exim 4.90_1)
	(envelope-from <bug-gnu-emacs-bounces@gnu.org>)
	id 1r4f16-0004WS-82; Sun, 19 Nov 2023 05:27:04 -0500
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 <Debian-debbugs@debbugs.gnu.org>)
 id 1r4f14-0004WK-AH
 for bug-gnu-emacs@gnu.org; Sun, 19 Nov 2023 05:27:02 -0500
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 <Debian-debbugs@debbugs.gnu.org>)
 id 1r4f14-0001rv-17
 for bug-gnu-emacs@gnu.org; Sun, 19 Nov 2023 05:27:02 -0500
Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2)
 (envelope-from <Debian-debbugs@debbugs.gnu.org>) id 1r4f14-0006ni-KW
 for bug-gnu-emacs@gnu.org; Sun, 19 Nov 2023 05:27:02 -0500
X-Loop: help-debbugs@gnu.org
Resent-From: Eshel Yaron <me@eshelyaron.com>
Original-Sender: "Debbugs-submit" <debbugs-submit-bounces@debbugs.gnu.org>
Resent-CC: bug-gnu-emacs@gnu.org
Resent-Date: Sun, 19 Nov 2023 10:27:02 +0000
Resent-Message-ID: <handler.67275.B.170038957326078@debbugs.gnu.org>
Resent-Sender: help-debbugs@gnu.org
X-GNU-PR-Message: report 67275
X-GNU-PR-Package: emacs
X-GNU-PR-Keywords: patch
X-Debbugs-Original-To: bug-gnu-emacs@gnu.org
Original-Received: via spool by submit@debbugs.gnu.org id=B.170038957326078
 (code B ref -1); Sun, 19 Nov 2023 10:27:02 +0000
Original-Received: (at submit) by debbugs.gnu.org; 19 Nov 2023 10:26:13 +0000
Original-Received: from localhost ([127.0.0.1]:50084 helo=debbugs.gnu.org)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <debbugs-submit-bounces@debbugs.gnu.org>)
 id 1r4f0G-0006mX-L9
 for submit@debbugs.gnu.org; Sun, 19 Nov 2023 05:26:13 -0500
Original-Received: from lists.gnu.org ([2001:470:142::17]:50720)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <me@eshelyaron.com>) id 1r4f0C-0006mI-Tz
 for submit@debbugs.gnu.org; Sun, 19 Nov 2023 05:26:11 -0500
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 <me@eshelyaron.com>) id 1r4f06-0004Lv-27
 for bug-gnu-emacs@gnu.org; Sun, 19 Nov 2023 05:26:02 -0500
Original-Received: from mail.eshelyaron.com ([107.175.124.16] helo=eshelyaron.com)
 by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <me@eshelyaron.com>) id 1r4f03-0000gB-Mr
 for bug-gnu-emacs@gnu.org; Sun, 19 Nov 2023 05:26:01 -0500
DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=eshelyaron.com;
 s=mail; t=1700389558;
 bh=wgAJx+7QeDJKaJBIaKLPK4jtZ8LXqaZ4F+O0mSz+tJM=;
 h=From:To:Subject:Date:From;
 b=mn46FAHUiEYNOjEMdQq2pBoM6u2KpkjbUtni938OUkhVuvZ7U1lxZaj/tGxo34FIz
 6F3mpdorDG0NWxR5PmxMsEap44zvTM0NQmVdx7YzLF1z3gQU9Z2lcSz7IeBGemsycM
 QTVkdR7qsZwaqSpMURUknjAZwsv2oL02xq80Z1VkYxiCZcSKZpy5WADHl0Aq+QJJy3
 4vm1ht4f1Rq7DbvlzqDWPvBZwdtHqLSqAYQV9tOgGECPfWN5U1ODA9tWu8eoS5anYb
 Nz7/mlEUYNpayCXCa9JNKWQfNDh6k7wv1k5ioED2mVxz+qWiXViTBzDeMe9d2mzW+T
 Z1xw/ilM0EHeA==
X-Hashcash: 1:20:231119:bug-gnu-emacs@gnu.org::RpwUaytY3G9Pyr1n:06SO
Received-SPF: pass client-ip=107.175.124.16; envelope-from=me@eshelyaron.com; 
 helo=eshelyaron.com
X-Spam_score_int: -20
X-Spam_score: -2.1
X-Spam_bar: --
X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1,
 DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, SPF_HELO_PASS=-0.001, 
 SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no
X-Spam_action: no action
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" <bug-gnu-emacs.gnu.org>
List-Unsubscribe: <https://lists.gnu.org/mailman/options/bug-gnu-emacs>,
 <mailto:bug-gnu-emacs-request@gnu.org?subject=unsubscribe>
List-Archive: <https://lists.gnu.org/archive/html/bug-gnu-emacs>
List-Post: <mailto:bug-gnu-emacs@gnu.org>
List-Help: <mailto:bug-gnu-emacs-request@gnu.org?subject=help>
List-Subscribe: <https://lists.gnu.org/mailman/listinfo/bug-gnu-emacs>,
 <mailto:bug-gnu-emacs-request@gnu.org?subject=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:274604
Archived-At: <http://permalink.gmane.org/gmane.emacs.bugs/274604>

--=-=-=
Content-Type: text/plain

Tags: patch

This patch makes Completion Preview mode more robust in face of
misbehaving `completion-at-point-functions`, and adds some tests.


Thanks,

Eshel


--=-=-=
Content-Type: text/patch
Content-Disposition: attachment;
 filename=0001-Improve-and-add-tests-for-Completion-Preview-mode.patch

>From f6a4eac72e8439ad61a2d71e8e376db0d9d55064 Mon Sep 17 00:00:00 2001
From: Eshel Yaron <me@eshelyaron.com>
Date: Sun, 19 Nov 2023 10:55:15 +0100
Subject: [PATCH] ; Improve and add tests for Completion Preview mode

Fix handling of capfs that return a function or signal an error,
respect the ':exclusive' completion property, fix lingering "exact"
face after deletion that makes the matches non-exact, and add tests.

* lisp/completion-preview.el (completion-preview--make-overlay): Only
reuse the previous 'after-string' if it has the right face.
(completion-preview--try-table)
(completion-preview--capf-wrapper): New functions.
(completion-preview--update): Use them.
* test/lisp/completion-preview-tests.el: New file.
---
 lisp/completion-preview.el            | 114 ++++++++++------
 test/lisp/completion-preview-tests.el | 184 ++++++++++++++++++++++++++
 2 files changed, 257 insertions(+), 41 deletions(-)
 create mode 100644 test/lisp/completion-preview-tests.el

diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index 6048d5be272..2b81dc5cd61 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -155,7 +155,9 @@ completion-preview--make-overlay
     (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))
+    (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))
@@ -178,48 +180,78 @@ completion-preview--exit-function
     (completion-preview-active-mode -1)
     (when (functionp func) (apply func args))))
 
+(defun completion-preview--try-table (table beg end props)
+  "Check TABLE for a completion matching the text between BEG and END.
+
+PROPS is a property list with additional information about TABLE.
+See `completion-at-point-functions' for more details.
+
+When TABLE contains a matching completion, return a list
+\(PREVIEW BEG END ALL EXIT-FN) where PREVIEW is the text to show
+in the completion preview, ALL is the list of all matching
+completion candidates, and EXIT-FN is either a function to call
+after inserting PREVIEW or nil.  When TABLE does not contain
+matching completions, or when there are multiple matching
+completions and `completion-preview-exact-match-only' is non-nil,
+return nil instead."
+  (let* ((pred (plist-get props :predicate))
+         (exit-fn (completion-preview--exit-function
+                   (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)
+                      (completion-metadata-get md 'display-sort-function)
+                      completion-preview-sort-function))
+         (all (let ((completion-lazy-hilit t))
+                (completion-all-completions string table pred
+                                            (- (point) beg) md)))
+         (last (last all))
+         (base (or (cdr last) 0))
+         (prefix (substring string base)))
+    (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))
+                (+ beg base) end sorted exit-fn))))))
+
+(defun completion-preview--capf-wrapper (capf)
+  "Translate output of CAPF to properties for completion preview overlay.
+
+If CAPF returns a list (BEG END TABLE . PROPS), call
+`completion-preview--try-table' to check TABLE for matching
+completion candidates.  If `completion-preview--try-table'
+returns a non-nil value, return that value.  Otherwise, return a
+list with nil car which means that completion failed, unless
+PROPS includes the property `:exclusive' with value `no', in
+which case this function returns nil which means to try other
+functions from `completion-at-point-functions'."
+  (unless (eq capf #'completion-preview--insert)
+    (let ((res (ignore-errors (funcall capf))))
+      (and (consp res)
+           (not (functionp res))
+           (seq-let (beg end table &rest plist) res
+             (or (completion-preview--try-table table beg end plist)
+                 (and (not (eq 'no (plist-get plist :exclusive))) '(nil))))))))
+
 (defun completion-preview--update ()
   "Update completion preview."
-  (seq-let (beg end table &rest plist)
-      (let ((completion-preview-insert-on-completion nil))
-        (run-hook-with-args-until-success 'completion-at-point-functions))
-    (when (and beg end table)
-      (let* ((pred (plist-get plist :predicate))
-             (exit-fn (completion-preview--exit-function
-                       (plist-get plist :exit-function)))
-             (string (buffer-substring beg end))
-             (md (completion-metadata string table pred))
-             (sort-fn (or (completion-metadata-get md 'cycle-sort-function)
-                          (completion-metadata-get md 'display-sort-function)
-                          completion-preview-sort-function))
-             (all (let ((completion-lazy-hilit t))
-                    (completion-all-completions string table pred
-                                                (- (point) beg) md)))
-             (last (last all))
-             (base (or (cdr last) 0))
-             (bbeg (+ beg base))
-             (prefix (substring string base)))
-        (when last
-          (setcdr last nil)
-          (let* ((filtered (remove prefix (all-completions prefix all)))
-                 (sorted (funcall sort-fn filtered))
-                 (multi (cadr sorted))  ; multiple candidates
-                 (cand (car sorted)))
-            (when (and cand
-                       (not (and multi
-                                 completion-preview-exact-match-only)))
-              (let* ((face (if multi
-                               'completion-preview
-                             'completion-preview-exact))
-                     (after (propertize (substring cand (length prefix))
-                                        'face face))
-                     (ov (completion-preview--make-overlay end after)))
-                (overlay-put ov 'completion-preview-beg bbeg)
-                (overlay-put ov 'completion-preview-end end)
-                (overlay-put ov 'completion-preview-index 0)
-                (overlay-put ov 'completion-preview-cands sorted)
-                (overlay-put ov 'completion-preview-exit-fn exit-fn)
-                (completion-preview-active-mode)))))))))
+  (seq-let (preview beg end all exit-fn)
+      (run-hook-wrapped
+       'completion-at-point-functions
+       #'completion-preview--capf-wrapper)
+    (when preview
+      (let ((ov (completion-preview--make-overlay end preview)))
+        (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-exit-fn exit-fn)
+        (completion-preview-active-mode)))))
 
 (defun completion-preview--show ()
   "Show a new completion preview.
diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el
new file mode 100644
index 00000000000..b5518e96254
--- /dev/null
+++ b/test/lisp/completion-preview-tests.el
@@ -0,0 +1,184 @@
+;;; completion-preview-tests.el --- tests for completion-preview.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'completion-preview)
+
+(defun completion-preview-tests--capf (completions &rest props)
+  (lambda ()
+    (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)
+  "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.
+
+If STRING is nil, check that there is no completion preview
+instead."
+  (if (not string)
+      (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
+                    'completion-preview))))))
+
+(ert-deftest completion-preview ()
+  "Test Completion Preview mode."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list (completion-preview-tests--capf '("foobarbaz"))))
+
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+
+    ;; Exact match
+    (completion-preview-tests--check-preview "barbaz" 'exact)
+
+    (insert "v")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+
+    ;; No match, no preview
+    (completion-preview-tests--check-preview nil)
+
+    (delete-char -1)
+    (let ((this-command 'delete-backward-char))
+      (completion-preview--post-command))
+
+    ;; Exact match again
+    (completion-preview-tests--check-preview "barbaz" 'exact)))
+
+(ert-deftest completion-preview-multiple-matches ()
+  "Test Completion Preview mode with multiple matching candidates."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list (completion-preview-tests--capf
+                       '("foobar" "foobaz"))))
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+
+    ;; Multiple matches, the preview shows the first one
+    (completion-preview-tests--check-preview "bar")
+
+    (completion-preview-next-candidate 1)
+
+    ;; Next match
+    (completion-preview-tests--check-preview "baz")))
+
+(ert-deftest completion-preview-exact-match-only ()
+  "Test `completion-preview-exact-match-only'."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list (completion-preview-tests--capf
+                       '("spam" "foobar" "foobaz")))
+                completion-preview-exact-match-only t)
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+
+    ;; Multiple matches, so no preview
+    (completion-preview-tests--check-preview nil)
+
+    (delete-region (point-min) (point-max))
+    (insert "spa")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+
+    ;; Exact match
+    (completion-preview-tests--check-preview "m" 'exact)))
+
+(ert-deftest completion-preview-function-capfs ()
+  "Test Completion Preview mode with capfs that return a function."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list
+                 (lambda () #'ignore)
+                 (completion-preview-tests--capf
+                  '("foobar" "foobaz"))))
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "bar")))
+
+(ert-deftest completion-preview-non-exclusive-capfs ()
+  "Test Completion Preview mode with non-exclusive capfs."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list
+                 (completion-preview-tests--capf
+                  '("spam") :exclusive 'no)
+                 (completion-preview-tests--capf
+                  '("foobar" "foobaz") :exclusive 'no)
+                 (completion-preview-tests--capf
+                  '("foobarbaz"))))
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "bar")
+    (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)))
+
+(ert-deftest completion-preview-face-updates ()
+  "Test updating the face in completion preview when match is no longer exact."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list
+                 (completion-preview-tests--capf
+                  '("foobarbaz" "food"))))
+    (insert "foo")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "d")
+    (insert "b")
+    (let ((this-command 'self-insert-command))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "arbaz" 'exact)
+    (delete-char -1)
+    (let ((this-command 'delete-backward-char))
+      (completion-preview--post-command))
+    (completion-preview-tests--check-preview "d")))
+
+(ert-deftest completion-preview-capf-errors ()
+  "Test Completion Preview mode with capfs that signal errors.
+
+`dabbrev-capf' is one example of such a capf."
+  (with-temp-buffer
+    (setq-local completion-at-point-functions
+                (list
+                 (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.el ends here
-- 
2.42.0


--=-=-=--