mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-03-30 02:33:03 -07:00
aa181cd352
The greedy regexp matching, broken scoring and broken highlight were sources of frequent complaints about the 'flex' matching style. This commit fixes that. Inspired by the 'hotfuzz' style (available at https://github.com/axelf4/hotfuzz) it uses a modified version of Gotoh's 1982 dynamic programming algorithm. It is strictly more correct than the "old" flex. For example, when matching the pattern 'goto' to no longer will 'eglot-format' be sorted before some hypothetical much better 'goobarbaz-goto'. And of course the highlighting is also correctly placed on the 'goto', not scattered across the candidate. Regarding performance, it is faster than the naive 'flex', primarily because of the Elisp rewrite in minibuffer.el. The matching and costing algorithm matters but is not the bottleneck. The Elisp parts of the style were almost completely decoupled from the pcm/substring styles in lisp/minibuffer.el. Only 'completion-flex-try-completion' uses some of pcm's code for pattern augmentation. * src/minibuf.c (completion--flex-cost-gotoh): New function. * lisp/minibuffer.el (completion-flex--pattern-str): New variable. (flex-score-match-tightness): Make obsolete. (completion--flex-all-completions-1): New helper function. (completion-flex-try-completion, completion-flex-all-completions): Rewrite. (completion-substring--all-completions): No longer take transform-pattern-fn. (completion--flex-adjust-metadata): Tweak. (completion--flex-score, completion--flex-score-1) (completion--flex-score-last-md, completion-flex--make-flex-pattern): Delete. * test/lisp/minibuffer-tests.el (completion--sorted-flex-completions): New helper function. (completion-flex-test-non-ascii): New test. (completion--pcm-score): Delete. (completion-pcm-test-3, completion-pcm-test-4) (completion-substring-test-1, completion-substring-test-2) (completion-flex-test-2, completion-flex-test-3): Tweak. * etc/NEWS: Describe change.
1221 lines
52 KiB
EmacsLisp
1221 lines
52 KiB
EmacsLisp
;;; minibuffer-tests.el --- Tests for completion functions -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2013-2026 Free Software Foundation, Inc.
|
||
|
||
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
|
||
;; Keywords:
|
||
|
||
;; 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/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;;
|
||
|
||
;;; Code:
|
||
|
||
(require 'ert)
|
||
(require 'ert-x)
|
||
|
||
(eval-when-compile (require 'cl-lib))
|
||
|
||
(ert-deftest completion-test1 ()
|
||
(with-temp-buffer
|
||
(cl-flet* ((test/completion-table (string pred action)
|
||
(let ((completion-ignore-case t))
|
||
(complete-with-action action '("test: ") string pred)))
|
||
(test/completion-at-point ()
|
||
(list (copy-marker (point-min))
|
||
(copy-marker (point))
|
||
#'test/completion-table)))
|
||
(let ((completion-at-point-functions (list #'test/completion-at-point)))
|
||
(insert "TEST")
|
||
(completion-at-point)
|
||
(should (equal (buffer-string)
|
||
"test: "))))))
|
||
|
||
(ert-deftest completion-table-with-predicate-test ()
|
||
(let ((full-collection
|
||
'("apple" ; Has A.
|
||
"beet" ; Has B.
|
||
"banana" ; Has A & B.
|
||
"cherry" ; Has neither.
|
||
))
|
||
(no-A (lambda (x) (not (string-match-p "a" x))))
|
||
(no-B (lambda (x) (not (string-match-p "b" x)))))
|
||
(should
|
||
(member "cherry"
|
||
(completion-table-with-predicate
|
||
full-collection no-A t "" no-B t)))
|
||
(should-not
|
||
(member "banana"
|
||
(completion-table-with-predicate
|
||
full-collection no-A t "" no-B t)))
|
||
;; "apple" should still match when strict is nil.
|
||
(should (eq t (try-completion
|
||
"apple"
|
||
(apply-partially
|
||
'completion-table-with-predicate
|
||
full-collection no-A nil)
|
||
no-B)))
|
||
;; "apple" should still match when strict is nil and pred2 is nil
|
||
;; (Bug#27841).
|
||
(should (eq t (try-completion
|
||
"apple"
|
||
(apply-partially
|
||
'completion-table-with-predicate
|
||
full-collection no-A nil))))))
|
||
|
||
(ert-deftest completion-table-subvert-test ()
|
||
(let* ((origtable '("A-hello" "A-there"))
|
||
(subvtable (completion-table-subvert origtable "B" "A")))
|
||
(should (equal (try-completion "B-hel" subvtable)
|
||
"B-hello"))
|
||
(should (equal (all-completions "B-hel" subvtable) '("-hello")))
|
||
(should (test-completion "B-hello" subvtable))
|
||
(should (equal (completion-boundaries "B-hel" subvtable
|
||
nil "suffix")
|
||
'(1 . 6)))))
|
||
|
||
(ert-deftest completion-table-test-quoting ()
|
||
(let ((process-environment
|
||
`("CTTQ1=ed" "CTTQ2=et/" ,@process-environment))
|
||
(default-directory (ert-resource-directory)))
|
||
(pcase-dolist (`(,input ,output)
|
||
'(
|
||
;; Test that $ in files is properly $$ quoted.
|
||
("data/m-cttq" "data/minibuffer-test-cttq$$tion")
|
||
;; Test that $$ in input is properly unquoted.
|
||
("data/m-cttq$$t" "data/minibuffer-test-cttq$$tion")
|
||
;; Test that env-vars are preserved.
|
||
("lisp/c${CTTQ1}et/se-u-c" "lisp/c${CTTQ1}et/semantic-utest-c.test")
|
||
("lisp/ced${CTTQ2}se-u-c" "lisp/ced${CTTQ2}semantic-utest-c.test")
|
||
;; Test that env-vars don't prevent partial-completion.
|
||
("lis/c${CTTQ1}/se-u-c" "lisp/c${CTTQ1}et/semantic-utest-c.test")
|
||
))
|
||
(should (equal (completion-try-completion input
|
||
#'completion--file-name-table
|
||
nil (length input))
|
||
(cons output (length output)))))
|
||
;; Everything also works with `completion-ignore-case'.
|
||
(let ((completion-ignore-case t))
|
||
(pcase-dolist (`(,input ,output)
|
||
'(
|
||
("data/M-CTTQ" "data/minibuffer-test-cttq$$tion")
|
||
("data/M-CTTQ$$t" "data/minibuffer-test-cttq$$tion")
|
||
;; When an env var is in the completion bounds, try-completion
|
||
;; won't change letter case.
|
||
("lisp/c${CTTQ1}E" "lisp/c${CTTQ1}Et/")
|
||
("lisp/ced${CTTQ2}SE-U-c" "lisp/ced${CTTQ2}SEmantic-utest-c.test")
|
||
;; If the env var is before the completion bounds, try-completion
|
||
;; *will* change letter case.
|
||
("lisp/c${CTTQ1}et/SE-U-c" "lisp/c${CTTQ1}et/semantic-utest-c.test")
|
||
("lis/c${CTTQ1}/SE-U-c" "lisp/c${CTTQ1}et/semantic-utest-c.test")
|
||
))
|
||
(should (equal (car (completion-try-completion input
|
||
#'completion--file-name-table
|
||
nil (length input)))
|
||
output))))))
|
||
|
||
(ert-deftest completion--insert-strings-faces ()
|
||
(with-temp-buffer
|
||
(completion--insert-strings
|
||
'(("completion1" "suffix1")))
|
||
(should (equal (get-text-property 12 'face) '(completions-annotations))))
|
||
(with-temp-buffer
|
||
(completion--insert-strings
|
||
'(("completion1" #("suffix1" 0 7 (face shadow)))))
|
||
(should (equal (get-text-property 12 'face) 'shadow)))
|
||
(with-temp-buffer
|
||
(completion--insert-strings
|
||
'(("completion1" "prefix1" "suffix1")))
|
||
(should (equal (get-text-property 19 'face) nil)))
|
||
(with-temp-buffer
|
||
(completion--insert-strings
|
||
'(("completion1" "prefix1" #("suffix1" 0 7 (face shadow)))))
|
||
(should (equal (get-text-property 19 'face) 'shadow))))
|
||
|
||
(ert-deftest completion-pcm--optimize-pattern ()
|
||
(should (equal (completion-pcm--optimize-pattern '("buf" point "f"))
|
||
'("buf" point "f")))
|
||
(should (equal (completion-pcm--optimize-pattern '(any "" any))
|
||
'(any))))
|
||
|
||
(defun test-completion-all-sorted-completions (base def history-var history-list)
|
||
(with-temp-buffer
|
||
(insert base)
|
||
(cl-letf (((symbol-function #'minibufferp) #'always))
|
||
(let ((completion-styles '(basic))
|
||
(completion-category-defaults nil)
|
||
(completion-category-overrides nil)
|
||
(minibuffer-history-variable history-var)
|
||
(minibuffer-history history-list)
|
||
(minibuffer-default def)
|
||
(minibuffer-completion-table
|
||
(lambda (str pred action)
|
||
(pcase action
|
||
(`(boundaries . ,_) `(boundaries ,(length base) . 0))
|
||
(_ (complete-with-action
|
||
action
|
||
'("epsilon" "alpha" "gamma" "beta" "delta")
|
||
(substring str (length base)) pred))))))
|
||
(completion-all-sorted-completions)))))
|
||
|
||
(ert-deftest completion-all-sorted-completions ()
|
||
;; No base, disabled history, no default
|
||
(should (equal (test-completion-all-sorted-completions
|
||
"" nil t nil)
|
||
`("beta" "alpha" "delta" "gamma" "epsilon" . 0)))
|
||
;; No base, disabled history, default string
|
||
(should (equal (test-completion-all-sorted-completions
|
||
"" "gamma" t nil)
|
||
`("gamma" "beta" "alpha" "delta" "epsilon" . 0)))
|
||
;; No base, empty history, default string
|
||
(should (equal (test-completion-all-sorted-completions
|
||
"" "gamma" 'minibuffer-history nil)
|
||
`("gamma" "beta" "alpha" "delta" "epsilon" . 0)))
|
||
;; No base, empty history, default list
|
||
(should (equal (test-completion-all-sorted-completions
|
||
"" '("gamma" "zeta") 'minibuffer-history nil)
|
||
`("gamma" "beta" "alpha" "delta" "epsilon" . 0)))
|
||
;; No base, history, default string
|
||
(should (equal (test-completion-all-sorted-completions
|
||
"" "gamma" 'minibuffer-history '("other" "epsilon" "delta"))
|
||
`("gamma" "epsilon" "delta" "beta" "alpha" . 0)))
|
||
;; Base, history, default string
|
||
(should (equal (test-completion-all-sorted-completions
|
||
"base/" "base/gamma" 'minibuffer-history
|
||
'("some/alpha" "base/epsilon" "base/delta"))
|
||
`("gamma" "epsilon" "delta" "beta" "alpha" . 5)))
|
||
;; Base, history, default string
|
||
(should (equal (test-completion-all-sorted-completions
|
||
"base/" "gamma" 'minibuffer-history
|
||
'("some/alpha" "base/epsilon" "base/delta"))
|
||
`("epsilon" "delta" "beta" "alpha" "gamma" . 5))))
|
||
|
||
(defun completion--pcm-first-difference-pos (comp)
|
||
"Get `completions-first-difference' from COMP."
|
||
(cl-loop for pos = (next-single-property-change 0 'face comp)
|
||
then (next-single-property-change pos 'face comp)
|
||
while pos
|
||
when (eq (get-text-property pos 'face comp)
|
||
'completions-first-difference)
|
||
return pos))
|
||
|
||
(ert-deftest completion-test--pcm-bug38458 ()
|
||
(should (equal (let ((completion-ignore-case t))
|
||
(completion-pcm--merge-try '("tes" point "ing")
|
||
'("Testing" "testing")
|
||
"" ""))
|
||
'("testing" . 7)))
|
||
(should (equal
|
||
(let ((completion-ignore-case t))
|
||
(completion-pcm-try-completion "tes" '("Testing" "testing") nil 3))
|
||
'("testing" . 7))))
|
||
|
||
(ert-deftest completion-pcm-test-1 ()
|
||
;; Point is at end, this does not match anything
|
||
(should (null
|
||
(completion-pcm-all-completions
|
||
"foo" '("hello" "world" "barfoobar") nil 3))))
|
||
|
||
(ert-deftest completion-pcm-test-2 ()
|
||
;; Point is at beginning, this matches "barfoobar"
|
||
(should (equal
|
||
(car (completion-pcm-all-completions
|
||
"foo" '("hello" "world" "barfoobar") nil 0))
|
||
"barfoobar")))
|
||
|
||
(ert-deftest completion-pcm-test-3 ()
|
||
(should (car (completion-pcm-all-completions
|
||
"R" '("R" "hello") nil 1))))
|
||
|
||
(ert-deftest completion-pcm-test-4 ()
|
||
;; No match due to point being at the end
|
||
(should (null
|
||
(completion-pcm-all-completions
|
||
"RO" '("RaOb") nil 2))))
|
||
|
||
(ert-deftest completion-pcm-test-5 ()
|
||
;; Since point is at the beginning, there is nothing that can really
|
||
;; be typed anymore
|
||
(should (null
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion-pcm-all-completions
|
||
"f" '("few" "many") nil 0)))))
|
||
(should (equal
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion-pcm-all-completions
|
||
"a*" '("ab" "ac") nil 2)))
|
||
1))
|
||
(should (equal
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion-pcm-all-completions
|
||
"a*" '("ab" "ac") nil 1)))
|
||
1))
|
||
(should (equal
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion-pcm-all-completions
|
||
"a*x" '("abx" "acx") nil 2)))
|
||
1))
|
||
(should (equal
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion-pcm-all-completions
|
||
"a*x" '("abxd" "acxe") nil 3)))
|
||
;; FIXME: the highlighting should start at the 4th character
|
||
;; rather than the third.
|
||
3)))
|
||
|
||
(ert-deftest completion-pcm-test-6 ()
|
||
;; Wildcards and delimiters work
|
||
(should (equal
|
||
(car (completion-pcm-all-completions
|
||
"li-pac*" '("list-packages") nil 7))
|
||
"list-packages"))
|
||
(should (null
|
||
(car (completion-pcm-all-completions
|
||
"li-pac*" '("do-not-list-packages") nil 7)))))
|
||
|
||
(ert-deftest completion-pcm-test-7 ()
|
||
;; Wildcards are preserved even when right before a delimiter.
|
||
(should (equal
|
||
(completion-pcm-try-completion
|
||
"x*/"
|
||
'("x1/y1" "x2/y2")
|
||
nil 3)
|
||
'("x*/y" . 4)))
|
||
;; Or around point.
|
||
(should (equal
|
||
(completion-pcm--merge-try
|
||
'(point star "foo") '("xxfoo" "xyfoo") "" "")
|
||
'("x*foo" . 1)))
|
||
(should (equal
|
||
(completion-pcm--merge-try
|
||
'(star point "foo") '("xxfoo" "xyfoo") "" "")
|
||
'("x*foo" . 2)))
|
||
;; This is important if the wildcard is at the start of a component.
|
||
(should (equal
|
||
(completion-pcm-try-completion
|
||
"*/minibuf"
|
||
'("lisp/minibuffer.el" "src/minibuf.c")
|
||
nil 9)
|
||
'("*/minibuf" . 9)))
|
||
;; A series of wildcards is preserved (for now), along with point's position.
|
||
(should (equal
|
||
(completion-pcm--merge-try
|
||
'(star star point star "foo") '("xxfoo" "xyfoo") "" "")
|
||
'("x***foo" . 3)))
|
||
;; The series of wildcards is considered together; if any of them wants the common suffix, it's generated.
|
||
(should (equal
|
||
(completion-pcm--merge-try
|
||
'(prefix any) '("xfoo" "yfoo") "" "")
|
||
'("foo" . 0)))
|
||
;; We consider each series of wildcards separately: if one series
|
||
;; wants the common suffix, but the next one does not, it doesn't get
|
||
;; the common suffix.
|
||
(should (equal
|
||
(completion-pcm--merge-try
|
||
'(prefix any "bar" any) '("xbarxfoo" "ybaryfoo") "" "")
|
||
'("bar" . 3))))
|
||
|
||
(ert-deftest completion-pcm-test-8 ()
|
||
;; try-completion inserts the common prefix and suffix at point.
|
||
(should (equal (completion-pcm-try-completion
|
||
"r" '("fooxbar" "fooybar") nil 0)
|
||
'("foobar" . 3)))
|
||
;; Even if point is at the end of the minibuffer.
|
||
(should (equal (completion-pcm-try-completion
|
||
"" '("fooxbar" "fooybar") nil 0)
|
||
'("foobar" . 3))))
|
||
|
||
(ert-deftest completion-pcm-test-anydelim ()
|
||
;; After each delimiter is a special wildcard which matches any
|
||
;; sequence of delimiters.
|
||
(should (equal (completion-pcm-try-completion
|
||
"-x" '("-_.x" "-__x") nil 2)
|
||
'("-_x" . 3))))
|
||
|
||
(ert-deftest completion-pcm-test-pattern->regex ()
|
||
(should (equal (completion-pcm--pattern->regex
|
||
'("A" any prefix "B" point "C"))
|
||
"\\`A[^z-a]*?B[^z-a]*?C"))
|
||
(should (equal (completion-pcm--pattern->regex
|
||
'(any any-delim prefix "A" "B" "C"))
|
||
"\\`[^z-a]*?ABC"))
|
||
(should (equal (completion-pcm--pattern->regex
|
||
'(any-delim "A" "B" star "C"))
|
||
"\\`[-_./:| *]*?AB[^z-a]*?C"))
|
||
(should (equal (completion-pcm--pattern->regex
|
||
'(any "A" any-delim "B" any-delim "C" any))
|
||
"\\`[^z-a]*?A[-_./:| *]*?B[-_./:| *]*?C[^z-a]*?")))
|
||
|
||
(ert-deftest completion-pcm--test-zerowidth-delim ()
|
||
(let ((completion-pcm--delim-wild-regex ; Let "u8" complete to "utf-8".
|
||
(concat "\\(?:" completion-pcm--delim-wild-regex
|
||
"\\|\\([[:alpha:]]\\)[[:digit:]]\\)")))
|
||
(should (equal (car (completion-try-completion
|
||
"u8-d" '("utf-8-dos" "utf-8-foo-dos" "utf-8-unix")
|
||
nil 4))
|
||
"utf-8-dos"))))
|
||
|
||
(ert-deftest completion-pcm-bug4219 ()
|
||
;; With `completion-ignore-case', try-completion should change the
|
||
;; case of existing text when the completions have different casing.
|
||
(should (equal
|
||
(let ((completion-ignore-case t))
|
||
(completion-pcm-try-completion "a" '("ABC" "ABD") nil 1))
|
||
'("AB" . 2)))
|
||
;; Even when the text isn't growing.
|
||
(should (equal
|
||
(let ((completion-ignore-case t))
|
||
(completion-pcm-try-completion "ab" '("ABC" "ABD") nil 2))
|
||
'("AB" . 2)))
|
||
;; Or when point is in the middle of the region changing case.
|
||
(should (equal
|
||
(let ((completion-ignore-case t))
|
||
(completion-pcm-try-completion "ab" '("ABC" "ABD") nil 1))
|
||
'("AB" . 2)))
|
||
;; Even when the existing minibuffer contents has mixed case.
|
||
(should (equal
|
||
(let ((completion-ignore-case t))
|
||
(completion-pcm-try-completion "Ab" '("ABC" "ABD") nil 1))
|
||
'("AB" . 2)))
|
||
;; But not if the completions don't actually all have the same case.
|
||
(should (equal
|
||
(let ((completion-ignore-case t))
|
||
(completion-pcm-try-completion "Ab" '("abc" "ABD") nil 1))
|
||
'("Ab" . 2)))
|
||
;; We don't change case if it doesn't match all of the completions, though.
|
||
(should (equal
|
||
(let ((completion-ignore-case t)) (try-completion "a" '("ax" "Ay")))
|
||
"a"))
|
||
(should (equal
|
||
(let ((completion-ignore-case t)) (try-completion "a" '("Ay" "ax")))
|
||
"a")))
|
||
|
||
(ert-deftest completion-substring-test-1 ()
|
||
(should (equal
|
||
(car (completion-substring-all-completions
|
||
"foo" '("hello" "world" "barfoobar") nil 3))
|
||
"barfoobar")))
|
||
|
||
(ert-deftest completion-substring-test-2 ()
|
||
(should (car (completion-substring-all-completions
|
||
"R" '("R" "hello") nil 1))))
|
||
|
||
(ert-deftest completion-substring-test-3 ()
|
||
;; Substring match
|
||
(should (equal
|
||
(car (completion-substring-all-completions
|
||
"custgroup" '("customize-group") nil 4))
|
||
"customize-group"))
|
||
(should (null
|
||
(car (completion-substring-all-completions
|
||
"custgroup" '("customize-group") nil 5)))))
|
||
|
||
(ert-deftest completion-substring-test-4 ()
|
||
;; `completions-first-difference' should be at the right place
|
||
(should (eql
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion-substring-all-completions
|
||
"jab" '("dabjobstabby" "many") nil 1)))
|
||
4))
|
||
(should (null
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion-substring-all-completions
|
||
"jab" '("dabjabstabby" "many") nil 1)))))
|
||
(should (equal
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion-substring-all-completions
|
||
"jab" '("dabjabstabby" "many") nil 3)))
|
||
6)))
|
||
|
||
(ert-deftest completion-substring-test-5 ()
|
||
;; Normally a `prefix' wildcard ignores the common prefix to its
|
||
;; left, since it only grows the common suffix; but if that common
|
||
;; prefix is also a common suffix, it should be included.
|
||
(should (equal
|
||
(completion-pcm--merge-try '(prefix "b") '("ab" "sab") "" "")
|
||
'("ab" . 2)))
|
||
(should (equal
|
||
(completion-pcm--merge-try '(prefix "b") '("ab" "ab") "" "")
|
||
'("ab" . 2)))
|
||
;; When there's a fixed string before `prefix', that fixed string
|
||
;; should always be included.
|
||
(should (equal
|
||
(completion-pcm--merge-try '("a" prefix "b") '("axb" "ayb") "" "")
|
||
'("ab" . 2)))
|
||
;; Letter-casing from the completions on the common prefix is still applied.
|
||
(should (equal
|
||
(let ((completion-ignore-case t))
|
||
(completion-pcm--merge-try '("a" prefix "b") '("Axb" "Ayb") "" ""))
|
||
'("Ab" . 2)))
|
||
(should (equal
|
||
(let ((completion-ignore-case t))
|
||
(completion-pcm--merge-try '("a" prefix "b") '("AAxb" "AAyb") "" ""))
|
||
'("Ab" . 2)))
|
||
;; substring completion should successfully complete the entire string
|
||
(should (equal
|
||
(completion-substring-try-completion "b" '("ab" "ab") nil 0)
|
||
'("ab" . 2))))
|
||
|
||
(defun completion--sorted-flex-completions (pat list &optional point)
|
||
"Flex test helper"
|
||
(let ((all (completion-flex-all-completions pat list nil point)))
|
||
(setcdr (last all) nil)
|
||
(sort all
|
||
(lambda (a b)
|
||
(< (car (completion--flex-cost pat a))
|
||
(car (completion--flex-cost pat b)))))))
|
||
|
||
(ert-deftest completion-flex-test-1 ()
|
||
(should (equal
|
||
(car (completion-flex-all-completions
|
||
"foo" '("hello" "world" "fabrobazo") nil 3))
|
||
"fabrobazo")))
|
||
|
||
(ert-deftest completion-flex-test-2 ()
|
||
(should (car (completion--sorted-flex-completions
|
||
"R" '("R" "hello") 1))))
|
||
|
||
(ert-deftest completion-flex-test-3 ()
|
||
(should (equal
|
||
(car (completion--sorted-flex-completions
|
||
"custgroup" '("customize-group-other-window") 4))
|
||
"customize-group-other-window"))
|
||
;; `completions-first-difference' should be at the right place
|
||
(should (equal
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion--sorted-flex-completions
|
||
"custgroup" '("customize-group-other-window") 4)))
|
||
4))
|
||
(should (equal
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion--sorted-flex-completions
|
||
"custgroup" '("customize-group-other-window") 0)))
|
||
nil))
|
||
(should (equal
|
||
(completion--pcm-first-difference-pos
|
||
(car (completion--sorted-flex-completions
|
||
"custgroup" '("customize-group-other-window") 9)))
|
||
15)))
|
||
|
||
(ert-deftest completion-flex-test-non-ascii ()
|
||
"Test flex completion with variable-width UTF-8 characters."
|
||
;; Uses Japanese Kanji to test multi-byte character handling.
|
||
|
||
;; 日本 = "nihon" (Japan), 東京 = "tōkyō" (Tokyo)
|
||
(should (equal
|
||
(car (completion--sorted-flex-completions
|
||
"日本" '("日本語" "日本" "中国") 2))
|
||
"日本"))
|
||
|
||
;; 図書館 = "toshokan" (library)
|
||
(should (equal
|
||
(car (completion--sorted-flex-completions
|
||
"tsk" '("図書館-toshokan" "task" "desk") 3))
|
||
"task"))
|
||
|
||
;; Mixed pattern (Kanji + ASCII) matching mixed string
|
||
;; 学校 = "gakkō" (school)
|
||
(should (equal
|
||
(car (completion--sorted-flex-completions
|
||
"学s" '("学校-school" "school" "学生") 2))
|
||
"学校-school"))
|
||
|
||
;; Pattern "東" should match "東京" better than "関東"
|
||
(let ((results (completion--sorted-flex-completions
|
||
"東" '("東京" "関東") 1)))
|
||
(should (equal (car results) "東京"))))
|
||
|
||
|
||
(defmacro with-minibuffer-setup (completing-read &rest body)
|
||
(declare (indent 1) (debug t))
|
||
`(catch 'result
|
||
(minibuffer-with-setup-hook
|
||
(lambda ()
|
||
(let ((redisplay-skip-initial-frame nil)
|
||
(executing-kbd-macro nil)) ; Don't skip redisplay
|
||
(throw 'result (progn . ,body))))
|
||
(let ((executing-kbd-macro t)) ; Force the real minibuffer
|
||
,completing-read))))
|
||
|
||
(defmacro completing-read-with-minibuffer-setup (collection &rest body)
|
||
(declare (indent 1) (debug t))
|
||
`(catch 'result
|
||
(minibuffer-with-setup-hook
|
||
(lambda ()
|
||
(let ((redisplay-skip-initial-frame nil)
|
||
(executing-kbd-macro nil)) ; Don't skip redisplay
|
||
(throw 'result (progn . ,body))))
|
||
(let ((executing-kbd-macro t)) ; Force the real minibuffer
|
||
(completing-read "Prompt: " ,collection)))))
|
||
|
||
(ert-deftest completion-auto-help-test ()
|
||
(let (messages)
|
||
(cl-letf* (((symbol-function 'minibuffer-message)
|
||
(lambda (message &rest args)
|
||
(push (apply #'format-message message args) messages))))
|
||
(let ((completion-auto-help nil))
|
||
(completing-read-with-minibuffer-setup
|
||
'("a" "ab" "ac")
|
||
(execute-kbd-macro (kbd "a TAB TAB"))
|
||
(should (equal (car messages) "Complete, but not unique"))
|
||
(should-not (minibuffer--completions-visible))
|
||
(execute-kbd-macro (kbd "b TAB"))
|
||
(should (equal (car messages) "Sole completion"))))
|
||
(let ((completion-auto-help t))
|
||
(completing-read-with-minibuffer-setup
|
||
'("a" "ab" "ac")
|
||
(execute-kbd-macro (kbd "a TAB TAB"))
|
||
(should (minibuffer--completions-visible))
|
||
(execute-kbd-macro (kbd "b TAB"))
|
||
(should (equal (car messages) "Sole completion"))))
|
||
(let ((completion-auto-help 'visible))
|
||
(completing-read-with-minibuffer-setup
|
||
'("a" "ab" "ac" "achoo")
|
||
(execute-kbd-macro (kbd "a TAB TAB"))
|
||
(should (minibuffer--completions-visible))
|
||
(execute-kbd-macro (kbd "ch TAB"))
|
||
(should (equal (car messages) "Sole completion")))))))
|
||
|
||
(ert-deftest completion-auto-select-test ()
|
||
(let ((completion-auto-select t))
|
||
(completing-read-with-minibuffer-setup
|
||
'("aa" "ab" "ac")
|
||
(execute-kbd-macro (kbd "a TAB"))
|
||
(should (and (minibuffer--completions-visible)
|
||
(eq (current-buffer) (get-buffer "*Completions*"))))
|
||
(execute-kbd-macro (kbd "TAB TAB TAB"))
|
||
(should (and (minibuffer--completions-visible)
|
||
(eq (current-buffer) (get-buffer " *Minibuf-1*"))))
|
||
(execute-kbd-macro (kbd "S-TAB"))
|
||
(should (and (minibuffer--completions-visible)
|
||
(eq (current-buffer) (get-buffer "*Completions*"))))))
|
||
(let ((completion-auto-select 'second-tab))
|
||
(completing-read-with-minibuffer-setup
|
||
'("aa" "ab" "ac")
|
||
(execute-kbd-macro (kbd "a TAB"))
|
||
(should (and (minibuffer--completions-visible)
|
||
(not (eq (current-buffer) (get-buffer "*Completions*")))))
|
||
(execute-kbd-macro (kbd "TAB TAB"))
|
||
(should (eq (current-buffer) (get-buffer "*Completions*"))))))
|
||
|
||
(ert-deftest completion-auto-wrap-test ()
|
||
(let ((completion-auto-wrap nil))
|
||
(completing-read-with-minibuffer-setup
|
||
'("aa" "ab" "ac")
|
||
(insert "a")
|
||
(minibuffer-completion-help)
|
||
(switch-to-completions)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(next-completion 2)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
;; Fixed in bug#54374
|
||
(next-completion 5)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(previous-completion 5)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
|
||
(first-completion)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(next-line-completion 2)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(next-line-completion 5)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(previous-line-completion 5)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(goto-char (point-min))
|
||
(next-line-completion 5)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(goto-char (point-min))
|
||
(previous-line-completion 5)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))))
|
||
(let ((completion-auto-wrap t))
|
||
(completing-read-with-minibuffer-setup
|
||
'("aa" "ab" "ac")
|
||
(insert "a")
|
||
(minibuffer-completion-help)
|
||
(switch-to-completions)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(next-completion 2)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(next-completion 1)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(previous-completion 1)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
|
||
(first-completion)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(next-line-completion 2)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(next-line-completion 1)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(previous-line-completion 1)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(goto-char (point-min))
|
||
(next-line-completion 4)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(goto-char (point-min))
|
||
(previous-line-completion 4)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string))))))
|
||
|
||
(ert-deftest completion-next-line-multline-test ()
|
||
(let ((completion-auto-wrap t))
|
||
(completing-read-with-minibuffer-setup
|
||
'("a\na" "a\nb" "ac")
|
||
(insert "a")
|
||
(minibuffer-completion-help)
|
||
(switch-to-completions)
|
||
(goto-char (point-min))
|
||
(next-line-completion 5)
|
||
(should (equal "a\nb" (get-text-property (point) 'completion--string)))
|
||
(goto-char (point-min))
|
||
(previous-line-completion 5)
|
||
(should (equal "a\nb" (get-text-property (point) 'completion--string))))))
|
||
|
||
(ert-deftest completions-header-format-test ()
|
||
(let ((completion-show-help nil)
|
||
(minibuffer-completion-auto-choose t)
|
||
(completions-header-format nil))
|
||
(completing-read-with-minibuffer-setup
|
||
'("aa" "ab" "ac")
|
||
(insert "a")
|
||
(minibuffer-completion-help)
|
||
(switch-to-completions)
|
||
;; Fixed in bug#55430
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(next-completion 2)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(previous-completion 2)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
;; Fixed in bug#54374
|
||
(previous-completion 1)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(next-completion 1)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
|
||
(next-line-completion 2)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(previous-line-completion 2)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(previous-line-completion 1)
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
(next-line-completion 1)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
|
||
;; Fixed in bug#55430
|
||
(execute-kbd-macro (kbd "C-u RET"))
|
||
(should (equal (minibuffer-contents) "aa")))
|
||
(completing-read-with-minibuffer-setup
|
||
'("aa" "ab" "ac")
|
||
;; Fixed in bug#55289
|
||
(execute-kbd-macro (kbd "a M-<up> M-<down>"))
|
||
(should (equal (minibuffer-contents) "aa")))))
|
||
|
||
(ert-deftest completions-affixation-navigation-test ()
|
||
(let ((completion-extra-properties
|
||
`(:affixation-function
|
||
,(lambda (completions)
|
||
(mapcar (lambda (c)
|
||
(list c "prefix " " suffix"))
|
||
completions)))))
|
||
(completing-read-with-minibuffer-setup
|
||
'("aa" "ab" "ac")
|
||
(insert "a")
|
||
(minibuffer-completion-help)
|
||
(switch-to-completions)
|
||
(should (equal 'highlight (get-text-property (point) 'mouse-face)))
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(let ((completion-auto-wrap t))
|
||
(next-completion 3))
|
||
(should (equal 'highlight (get-text-property (point) 'mouse-face)))
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(let ((completion-auto-wrap nil))
|
||
(next-completion 3))
|
||
(should (equal 'highlight (get-text-property (point) 'mouse-face)))
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
;; Fixed in bug#54374
|
||
(goto-char (1- (point-max)))
|
||
(should-not (equal 'highlight (get-text-property (point) 'mouse-face)))
|
||
|
||
(first-completion)
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(let ((completion-auto-wrap t))
|
||
(next-line-completion 3))
|
||
(should (equal "aa" (get-text-property (point) 'completion--string)))
|
||
(let ((completion-auto-wrap nil))
|
||
(next-line-completion 3))
|
||
(should (equal "ac" (get-text-property (point) 'completion--string)))
|
||
|
||
(execute-kbd-macro (kbd "C-u RET"))
|
||
(should (equal (minibuffer-contents) "ac")))))
|
||
|
||
(ert-deftest completions-group-navigation-test ()
|
||
(completing-read-with-minibuffer-setup
|
||
(lambda (string pred action)
|
||
(if (eq action 'metadata)
|
||
`(metadata
|
||
(group-function
|
||
. ,(lambda (name transform)
|
||
(if transform
|
||
name
|
||
(pcase name
|
||
(`"aa1" "Group 1")
|
||
(`"aa2" "Group 1")
|
||
(`"aa3" "Group 1")
|
||
(`"aa4" "Group 1")
|
||
(`"ab1" "Group 2")
|
||
(`"ac1" "Group 3")
|
||
(`"ac2" "Group 3")))))
|
||
(category . unicode-name))
|
||
(complete-with-action action '("aa1" "aa2" "aa3" "aa4" "ab1" "ac1" "ac2")
|
||
string pred)))
|
||
(insert "a")
|
||
(minibuffer-completion-help)
|
||
(switch-to-completions)
|
||
(should (equal "aa1" (get-text-property (point) 'completion--string)))
|
||
(let ((completion-auto-wrap t))
|
||
(next-completion 7))
|
||
(should (equal "aa1" (get-text-property (point) 'completion--string)))
|
||
(let ((completion-auto-wrap nil))
|
||
(next-completion 7))
|
||
(should (equal "ac2" (get-text-property (point) 'completion--string)))
|
||
|
||
(let ((completion-auto-wrap t))
|
||
;; First column
|
||
(first-completion)
|
||
(next-line-completion 1)
|
||
(should (equal "aa4" (get-text-property (point) 'completion--string)))
|
||
(next-line-completion 3)
|
||
(should (equal "aa1" (get-text-property (point) 'completion--string)))
|
||
(previous-line-completion 2)
|
||
(should (equal "ab1" (get-text-property (point) 'completion--string)))
|
||
|
||
;; Second column
|
||
(first-completion)
|
||
(next-completion 1)
|
||
(should (equal "aa2" (get-text-property (point) 'completion--string)))
|
||
(next-line-completion 1)
|
||
(should (equal "ac2" (get-text-property (point) 'completion--string)))
|
||
(next-line-completion 1)
|
||
(should (equal "aa2" (get-text-property (point) 'completion--string)))
|
||
(previous-line-completion 1)
|
||
(should (equal "ac2" (get-text-property (point) 'completion--string)))
|
||
(previous-line-completion 1)
|
||
(should (equal "aa2" (get-text-property (point) 'completion--string)))
|
||
|
||
;; Third column
|
||
(first-completion)
|
||
(next-completion 2)
|
||
(should (equal "aa3" (get-text-property (point) 'completion--string)))
|
||
(next-line-completion 1)
|
||
(should (equal "aa3" (get-text-property (point) 'completion--string))))
|
||
|
||
(let ((completion-auto-wrap nil))
|
||
(first-completion)
|
||
(next-line-completion 7)
|
||
(should (equal "ac1" (get-text-property (point) 'completion--string)))
|
||
(previous-line-completion 7)
|
||
(should (equal "aa1" (get-text-property (point) 'completion--string))))))
|
||
|
||
(defun completions-format-navigation--tests (n)
|
||
"Make tests for navigating buffer of N completion candidate.
|
||
The tests check expected results of navigating with and without wrapping
|
||
for combinations of the values of `completion-auto-wrap' and
|
||
`completions-format' (see bug#78959 for motivation and discussion of the
|
||
expected behavior). The tests are actually run by calling this
|
||
function, with specific values of N (> 1 to have a \"*Completions*\"
|
||
buffer), from functions defined by `ert-deftest.'"
|
||
(let* (
|
||
;; Make list of N unique completions.
|
||
(letters (mapcar 'string (number-sequence 97 122)))
|
||
(gen-compl (lambda (x)
|
||
(let (comps)
|
||
(dotimes (_ x)
|
||
(push (concat (car comps) (pop letters)) comps))
|
||
(nreverse comps))))
|
||
(completions (funcall gen-compl n))
|
||
|
||
;; Navigation tests.
|
||
;; (i) For both horizontal and vertical formats.
|
||
(all-completions
|
||
(lambda (type)
|
||
(let ((next-fn (pcase type
|
||
('any 'next-completion)
|
||
('column 'next-column-completion)
|
||
('line 'next-line-completion)))
|
||
(prev-fn (pcase type
|
||
('any 'previous-completion)
|
||
('column 'previous-column-completion)
|
||
('line 'previous-line-completion))))
|
||
(completing-read-with-minibuffer-setup completions
|
||
(insert (car completions))
|
||
(minibuffer-completion-help)
|
||
(switch-to-completions)
|
||
;; Sanity check that we're on first completion candidate.
|
||
(should
|
||
(equal (car completions)
|
||
(get-text-property (point) 'completion--string)))
|
||
;; Double check.
|
||
(first-completion)
|
||
(should
|
||
(equal (car completions)
|
||
(get-text-property (point) 'completion--string)))
|
||
;; Test moving from first to Ith next completion
|
||
;; candidate (0<I<N-1).
|
||
(dolist (i (number-sequence 1 (1- n)))
|
||
(funcall next-fn i)
|
||
(should
|
||
(equal (nth i completions)
|
||
(get-text-property (point) 'completion--string)))
|
||
(if (< i (1- n))
|
||
(first-completion)
|
||
(last-completion)
|
||
(should
|
||
(equal (nth i completions)
|
||
(get-text-property (point) 'completion--string)))
|
||
(funcall next-fn 1)
|
||
(if completion-auto-wrap
|
||
;; Wrap around to first completion candidate.
|
||
(should
|
||
(equal (car completions)
|
||
(get-text-property (point) 'completion--string)))
|
||
;; No wrapping.
|
||
(should
|
||
(equal (nth i completions)
|
||
(get-text-property (point) 'completion--string))))))
|
||
(last-completion)
|
||
;; Test moving from last to Ith previous completion
|
||
;; candidate (0<I<N-1).
|
||
(dolist (i (number-sequence 1 (1- n)))
|
||
(funcall prev-fn i)
|
||
(should
|
||
(equal (nth (- n i 1) completions)
|
||
(get-text-property (point) 'completion--string)))
|
||
(if (< i (1- n))
|
||
(last-completion)
|
||
(first-completion)
|
||
(should
|
||
(equal (car completions)
|
||
(get-text-property (point) 'completion--string)))
|
||
(funcall prev-fn 1)
|
||
(if completion-auto-wrap
|
||
;; Wrap around to last completion candidate.
|
||
(should
|
||
(equal (nth (1- n) completions)
|
||
(get-text-property (point) 'completion--string)))
|
||
;; No wrapping.
|
||
(should
|
||
(equal (car completions)
|
||
(get-text-property (point)
|
||
'completion--string))))))))))
|
||
|
||
;; (ii) Only for horizontal format.
|
||
(within-column
|
||
(lambda ()
|
||
(completing-read-with-minibuffer-setup completions
|
||
(insert (car completions))
|
||
(minibuffer-completion-help)
|
||
(switch-to-completions)
|
||
(while (not (eolp))
|
||
(completion--move-to-candidate-start)
|
||
(let* ((first (get-text-property (point) 'completion--string))
|
||
(pos (point))
|
||
(i 0)
|
||
last1 last2)
|
||
;; Keep moving to next completion candidate in this
|
||
;; column until we reach the last one, and then wrap
|
||
;; back to the first candidate, if
|
||
;; `completion-auto-wrap' is non-nil, otherwise stay
|
||
;; on the last one.
|
||
(while (or (and completion-auto-wrap
|
||
(not (equal last1 first)))
|
||
(not (equal last1
|
||
(get-text-property
|
||
(point) 'completion--string))))
|
||
(setq last2 last1)
|
||
(next-line-completion 1)
|
||
(incf i)
|
||
;; Set `last1' to either the first or last
|
||
;; candidate, depending on the value of
|
||
;; `completion-auto-wrap'.
|
||
(setq last1 (get-text-property (point) 'completion--string)))
|
||
(setq last1 last2
|
||
last2 nil)
|
||
(decf i)
|
||
(when completion-auto-wrap
|
||
(should (equal (get-text-property (point) 'completion--string)
|
||
first))
|
||
;; Test wrapping from last to first line in this column.
|
||
(next-line-completion i) ; Move to last candidate.
|
||
(should (equal (get-text-property (point) 'completion--string)
|
||
last1)))
|
||
;; Now keeping move from last to first completion
|
||
;; candidate in this column.
|
||
(while (or (not (equal last2 first))
|
||
(not (equal last2
|
||
(get-text-property
|
||
(point) 'completion--string))))
|
||
(previous-line-completion 1)
|
||
(setq last2 (get-text-property (point) 'completion--string)))
|
||
;; Test wrapping from first to last line in this column.
|
||
(when completion-auto-wrap
|
||
(should (equal (get-text-property (point) 'completion--string)
|
||
first))
|
||
(next-line-completion i)
|
||
(should (equal (get-text-property (point) 'completion--string)
|
||
last1)))
|
||
;; Move to first candidate in next column to continue loop
|
||
(completion--move-to-candidate-end)
|
||
(unless (eolp)
|
||
(goto-char pos)
|
||
(next-column-completion 1)))))))
|
||
|
||
;; (iii) Only for vertical format.
|
||
(within-line
|
||
(lambda ()
|
||
(completing-read-with-minibuffer-setup completions
|
||
(insert (car completions))
|
||
(minibuffer-completion-help)
|
||
(switch-to-completions)
|
||
(let ((one-col (save-excursion
|
||
(first-completion)
|
||
(completion--move-to-candidate-end)
|
||
(eolp))))
|
||
(while (not (eobp))
|
||
(let ((first (get-text-property (point) 'completion--string))
|
||
last pos)
|
||
;; Test moving to next column in this line.
|
||
(while (not (eolp))
|
||
(next-column-completion 1)
|
||
(let ((next (get-text-property (point) 'completion--string)))
|
||
(should
|
||
;; FIXME: tautology?
|
||
(equal (nth (seq-position completions next) completions)
|
||
next)))
|
||
;; If this is the last completion in this line,
|
||
;; exit the loop.
|
||
(when (or (> (current-column) 0)
|
||
(save-excursion (and (forward-line) (eobp)))
|
||
(unless one-col
|
||
(save-excursion
|
||
(and (progn
|
||
(completion--move-to-candidate-start)
|
||
(bolp))
|
||
(progn
|
||
(completion--move-to-candidate-end)
|
||
(eolp))))))
|
||
(completion--move-to-candidate-end)))
|
||
(backward-char)
|
||
(completion--move-to-candidate-start)
|
||
(setq last (get-text-property (point) 'completion--string)
|
||
pos (point))
|
||
;; We're on the last column, so next move either
|
||
;; wraps or stays put.
|
||
(next-column-completion 1)
|
||
(if completion-auto-wrap
|
||
;; We wrapped around to first candidate in this line.
|
||
(progn
|
||
(should (bolp))
|
||
(should
|
||
(equal (get-text-property (point) 'completion--string)
|
||
first))
|
||
;; Go back to last completion in this line for next test.
|
||
(goto-char (if one-col pos (pos-eol)))
|
||
(backward-char))
|
||
(should
|
||
(equal (get-text-property (point) 'completion--string)
|
||
last)))
|
||
;; Test moving to previous column in this line.
|
||
(while (if one-col
|
||
(save-excursion
|
||
(forward-line -1)
|
||
(get-text-property (point) 'completion--string))
|
||
(not (bolp)))
|
||
(previous-column-completion 1)
|
||
(let ((prev (get-text-property (point) 'completion--string)))
|
||
(should
|
||
;; FIXME: tautology?
|
||
(equal (nth (seq-position completions prev) completions)
|
||
prev))))
|
||
;; We're on the first column, so next move either
|
||
;; wraps or stay put.
|
||
(previous-column-completion 1)
|
||
(if completion-auto-wrap
|
||
;; We wrapped around to last candidate in this line.
|
||
(progn
|
||
(completion--move-to-candidate-end)
|
||
(should (eolp))
|
||
(backward-char)
|
||
(should
|
||
(equal (get-text-property (point) 'completion--string)
|
||
last)))
|
||
;; We stayed on the first candidate.
|
||
(should
|
||
(equal (get-text-property (point) 'completion--string)
|
||
first)))
|
||
(if one-col
|
||
(goto-char (point-max))
|
||
(forward-line)))))))))
|
||
|
||
;; Run tests.
|
||
;; Test navigation with wrapping...
|
||
(let ((completion-auto-wrap t))
|
||
;; ...in horizontal format,
|
||
(let ((completions-format 'horizontal))
|
||
(funcall all-completions 'any)
|
||
(funcall all-completions 'column)
|
||
(funcall within-column))
|
||
;; ...in vertical format.
|
||
(let ((completions-format 'vertical))
|
||
(funcall all-completions 'any)
|
||
(funcall all-completions 'line)
|
||
(funcall within-line)))
|
||
;; Test navigation without wrapping...
|
||
(let ((completion-auto-wrap nil))
|
||
;; ...in horizontal format,
|
||
(let ((completions-format 'horizontal))
|
||
(funcall all-completions 'any)
|
||
(funcall all-completions 'column)
|
||
(funcall within-column))
|
||
;; ...in vertical format.
|
||
(let ((completions-format 'vertical))
|
||
(funcall all-completions 'any)
|
||
(funcall all-completions 'line)
|
||
(funcall within-line)))))
|
||
|
||
;; (ert-deftest completions-format-navigation-test-1 ()
|
||
;; (completions-format-navigation--tests 1))
|
||
|
||
(ert-deftest completions-format-navigation-test-2 ()
|
||
(completions-format-navigation--tests 2))
|
||
|
||
(ert-deftest completions-format-navigation-test-3 ()
|
||
(completions-format-navigation--tests 3))
|
||
|
||
(ert-deftest completions-format-navigation-test-4 ()
|
||
(completions-format-navigation--tests 4))
|
||
|
||
(ert-deftest completions-format-navigation-test-5 ()
|
||
(completions-format-navigation--tests 5))
|
||
|
||
(ert-deftest completions-format-navigation-test-9 ()
|
||
(completions-format-navigation--tests 9))
|
||
|
||
(ert-deftest completions-format-navigation-test-10 ()
|
||
(completions-format-navigation--tests 10))
|
||
|
||
(ert-deftest completions-format-navigation-test-15 ()
|
||
(completions-format-navigation--tests 15))
|
||
|
||
(ert-deftest completions-format-navigation-test-16 ()
|
||
(completions-format-navigation--tests 16))
|
||
|
||
(ert-deftest completion-cycle ()
|
||
(completing-read-with-minibuffer-setup '("aaa" "bbb" "ccc")
|
||
(let ((completion-cycle-threshold t))
|
||
(execute-kbd-macro (kbd "TAB TAB TAB"))
|
||
(should (equal (minibuffer-contents) "ccc")))))
|
||
|
||
(ert-deftest minibuffer-next-completion ()
|
||
(let ((default-directory (ert-resource-directory))
|
||
(minibuffer-completion-auto-choose t))
|
||
(completing-read-with-minibuffer-setup #'read-file-name-internal
|
||
(insert "d/")
|
||
(execute-kbd-macro (kbd "M-<down> M-<down> M-<down>"))
|
||
(should (equal "data/minibuffer-test-cttq$$tion" (minibuffer-contents))))))
|
||
|
||
(ert-deftest minibuffer-completion-RET-prefix ()
|
||
;; REQUIRE-MATCH=nil
|
||
(with-minibuffer-setup
|
||
(completing-read ":" '("aaa" "bbb" "ccc") nil nil)
|
||
(execute-kbd-macro (kbd "M-<down> M-<down> C-u RET"))
|
||
(should (equal "bbb" (minibuffer-contents))))
|
||
;; REQUIRE-MATCH=t
|
||
(with-minibuffer-setup
|
||
(completing-read ":" '("aaa" "bbb" "ccc") nil t)
|
||
(execute-kbd-macro (kbd "M-<down> M-<down> C-u RET"))
|
||
(should (equal "bbb" (minibuffer-contents)))))
|
||
|
||
(defun test/completion-at-point ()
|
||
(list (point-min) (point) '("test:a" "test:b")))
|
||
|
||
(ert-deftest completion-in-region-next-completion ()
|
||
(with-current-buffer (get-buffer-create "*test*")
|
||
;; Put this buffer in the selected window so
|
||
;; `minibuffer--completions-visible' works.
|
||
(pop-to-buffer (current-buffer))
|
||
(setq-local completion-at-point-functions (list #'test/completion-at-point))
|
||
(insert "test:")
|
||
(completion-help-at-point)
|
||
(should (minibuffer--completions-visible))
|
||
;; C-u RET and RET have basically the same behavior for
|
||
;; completion-in-region-mode, since they both dismiss *Completions*
|
||
;; while leaving completion-in-region-mode still active.
|
||
(execute-kbd-macro (kbd "M-<down>"))
|
||
(should (equal (completion--selected-candidate) "test:a"))
|
||
(execute-kbd-macro (kbd "C-u RET"))
|
||
(should (equal (buffer-string) "test:a"))
|
||
(delete-char -1)
|
||
(completion-help-at-point)
|
||
(execute-kbd-macro (kbd "M-<down> M-<down>"))
|
||
(should (equal (completion--selected-candidate) "test:b"))
|
||
(execute-kbd-macro (kbd "RET"))
|
||
(should (equal (buffer-string) "test:b"))))
|
||
|
||
(ert-deftest completion-category-inheritance ()
|
||
(let ((completion-category-defaults
|
||
'((cat (display-sort-function . foo))
|
||
(dog (display-sort-function . bar)
|
||
(group-function . baz)
|
||
(annotation-function . qux)
|
||
(styles basic))
|
||
(fel (annotation-function . spam))
|
||
(testtesttest (styles substring))))
|
||
(origt (get 'testtesttest 'completion-category-parents))
|
||
(origc (get 'cat 'completion-category-parents)))
|
||
(unwind-protect
|
||
(progn
|
||
(put 'testtesttest 'completion-category-parents '(cat dog))
|
||
(put 'cat 'completion-category-parents '(fel))
|
||
;; Value from first parent.
|
||
(should (eq
|
||
(completion-metadata-get '((category . testtesttest))
|
||
'display-sort-function)
|
||
'foo))
|
||
;; Value from parent of first parent, not from second parent.
|
||
(should (eq
|
||
(completion-metadata-get '((category . testtesttest))
|
||
'annotation-function)
|
||
'spam))
|
||
;; Value from second parent.
|
||
(should (eq
|
||
(completion-metadata-get '((category . testtesttest))
|
||
'group-function)
|
||
'baz))
|
||
;; Property specified directly, takes precedence.
|
||
(should (equal
|
||
(completion-metadata-get '((category . testtesttest))
|
||
'styles)
|
||
'(substring)))
|
||
;; Not specified and not inherited.
|
||
(should-not (completion-metadata-get '((category . testtesttest))
|
||
'affixation-function)))
|
||
(put 'cat 'completion-category-parents origc)
|
||
(put 'testtesttest 'completion-category-parents origt))))
|
||
|
||
(provide 'minibuffer-tests)
|
||
;;; minibuffer-tests.el ends here
|