diff options
Diffstat (limited to 'test/lisp/minibuffer-tests.el')
| -rw-r--r-- | test/lisp/minibuffer-tests.el | 439 |
1 files changed, 432 insertions, 7 deletions
diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el index c27b338f7f3..ec93c8f42a5 100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@ -1,22 +1,24 @@ -;;; completion-tests.el --- Tests for completion functions -*- lexical-binding: t; -*- +;;; minibuffer-tests.el --- Tests for completion functions -*- lexical-binding: t; -*- -;; Copyright (C) 2013-2017 Free Software Foundation, Inc. +;; Copyright (C) 2013-2022 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -24,6 +26,9 @@ ;;; Code: +(require 'ert) +(require 'ert-x) + (eval-when-compile (require 'cl-lib)) (ert-deftest completion-test1 () @@ -42,5 +47,425 @@ (should (equal (buffer-string) "test: ")))))) -(provide 'completion-tests) -;;; completion-tests.el ends here +(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" "lisp/c${CTTQ1}et/semantic-utest") + ("lisp/ced${CTTQ2}se-u" "lisp/ced${CTTQ2}semantic-utest") + ;; Test that env-vars don't prevent partial-completion. + ;; FIXME: Ideally we'd like to keep the ${CTTQ}! + ("lis/c${CTTQ1}/se-u" "lisp/cedet/semantic-utest") + )) + (should (equal (completion-try-completion input + #'completion--file-name-table + nil (length input)) + (cons output (length 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) (lambda (&rest _) t))) + (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-score (comp) + "Get `completion-score' from COMP." + (get-text-property 0 'completion-score comp)) + +(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-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 () + ;; Full match! + (should (eql + (completion--pcm-score + (car (completion-pcm-all-completions + "R" '("R" "hello") nil 1))) + 1.0))) + +(ert-deftest completion-pcm-test-4 () + ;; One fourth of a match and no match due to point being at the end + (should (eql + (completion--pcm-score + (car (completion-pcm-all-completions + "RO" '("RaOb") nil 1))) + (/ 1.0 4.0))) + (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)))))) + +(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-substring-test-1 () + ;; One third of a match! + (should (equal + (car (completion-substring-all-completions + "foo" '("hello" "world" "barfoobar") nil 3)) + "barfoobar")) + (should (eql + (completion--pcm-score + (car (completion-substring-all-completions + "foo" '("hello" "world" "barfoobar") nil 3))) + (/ 1.0 3.0)))) + +(ert-deftest completion-substring-test-2 () + ;; Full match! + (should (eql + (completion--pcm-score + (car (completion-substring-all-completions + "R" '("R" "hello") nil 1))) + 1.0))) + +(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-flex-test-1 () + ;; Fuzzy match + (should (equal + (car (completion-flex-all-completions + "foo" '("hello" "world" "fabrobazo") nil 3)) + "fabrobazo"))) + +(ert-deftest completion-flex-test-2 () + ;; Full match! + (should (eql + (completion--pcm-score + (car (completion-flex-all-completions + "R" '("R" "hello") nil 1))) + 1.0))) + +(ert-deftest completion-flex-test-3 () + ;; Another fuzzy match, but more of a "substring" one + (should (equal + (car (completion-flex-all-completions + "custgroup" '("customize-group-other-window") nil 4)) + "customize-group-other-window")) + ;; `completions-first-difference' should be at the right place + (should (equal + (completion--pcm-first-difference-pos + (car (completion-flex-all-completions + "custgroup" '("customize-group-other-window") nil 4))) + 4)) + (should (equal + (completion--pcm-first-difference-pos + (car (completion-flex-all-completions + "custgroup" '("customize-group-other-window") nil 9))) + 15))) + + +(defmacro completing-read-with-minibuffer-setup (collection &rest body) + (declare (indent 1) (debug (collection body))) + `(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 (get-buffer-window "*Completions*" 0)))) + (let ((completion-auto-help t)) + (completing-read-with-minibuffer-setup + '("a" "ab" "ac") + (execute-kbd-macro (kbd "a TAB TAB")) + (should (get-buffer-window "*Completions*" 0))))))) + +(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 (get-buffer-window "*Completions*" 0) + (eq (current-buffer) (get-buffer "*Completions*")))) + (execute-kbd-macro (kbd "TAB TAB TAB")) + (should (and (get-buffer-window "*Completions*" 0) + (eq (current-buffer) (get-buffer " *Minibuf-1*")))) + (execute-kbd-macro (kbd "S-TAB")) + (should (and (get-buffer-window "*Completions*" 0) + (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 (get-buffer-window "*Completions*" 0) + (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))))) + (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)))))) + +(ert-deftest completions-header-format-test () + (let ((completion-show-help nil) + (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))) + ;; 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))) + (execute-kbd-macro (kbd "C-u RET")) + (should (equal (minibuffer-contents) "ac"))))) + +(provide 'minibuffer-tests) +;;; minibuffer-tests.el ends here |