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#67275: [PATCH] ; Improve and add tests for Completion Preview mode Date: Sun, 19 Nov 2023 11:25:55 +0100 Message-ID: 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="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: 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 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 ) 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 ) 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 ) 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 ) 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 Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sun, 19 Nov 2023 10:27:02 +0000 Resent-Message-ID: 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 ) 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 ) 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 ) 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 ) 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" 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:274604 Archived-At: --=-=-= 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 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 . + +;;; 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 --=-=-=--