;;; minibuffer-tests.el --- Tests for completion functions -*- lexical-binding: t; -*- ;; Copyright (C) 2013-2023 Free Software Foundation, Inc. ;; Author: Stefan Monnier ;; 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 . ;;; Commentary: ;; ;;; Code: (require 'ert) (require 'ert-x) (require 'cl-lib) (ert-deftest completion-test1 () (with-temp-buffer (cl-flet* ((test/completion-table (_string _pred action) (if (eq action 'lambda) nil "test: ")) (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" "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) #'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-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-substring-test-5 () ;; merge-completions needs to work correctly when (should (equal (completion-pcm--merge-completions '("ab" "sab") '(prefix "b")) '("b" "a" prefix))) (should (equal (completion-pcm--merge-completions '("ab" "ab") '(prefix "b")) '("b" "a"))) ;; substring completion should successfully complete the entire string (should (equal (completion-substring-try-completion "b" '("ab" "ab") nil 0) '("ab" . 2)))) (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))) (ert-deftest completion-flex-score-test-1 () ;; Full match! (should (equal (completion--flex-score '(prefix "R") '("R")) (list (cons -1.0 "R"))))) (ert-deftest completion-flex-score-test-2 () ;; One third and half of a match! (should (equal (completion--flex-score '(prefix "foo") '("barfoobar" "fooboo")) (list (cons (/ -1.0 3.0) "barfoobar") (cons (/ -1.0 2.0) "fooboo"))))) (ert-deftest completion-flex-score-test-3 () ;; One fourth of a match (should (eql (caar (completion--flex-score '(prefix "R" point "O") '("RaOb"))) (/ -1.0 4.0)))) (ert-deftest completion-flex-score-test-4 () ;; For quoted completion tables, score the unquoted completion string. (should (equal (completion--flex-score '(prefix "R") (list (propertize "X" 'completion--unquoted "R"))) (list (cons -1.0 "X"))))) (defun completion--test-style (style string point table filtered) (let* ((completion-styles (list style)) (pred (lambda (x) (not (string-search "!" x)))) (result (completion-filter-completions string table pred point nil))) (should (equal (alist-get 'base result) 0)) (should (equal (alist-get 'end result) (length string))) (should (equal (alist-get 'completions result) filtered)) ;; The highlighting function should be present. (should (not (memq (alist-get 'highlight result) '(nil identity)))) ;; Equal results as `completion-all-completions'. (should (equal (completion-all-completions string table pred point) (append filtered 0))) ;; The returned strings should be identical to the original strings. ;; The `completion-filter-completions' function avoids allocations! (should (cl-intersection (alist-get 'completions result) table :test #'eq)))) (ert-deftest completion-basic-style-test-1 () ;; point at the beginning |foo (completion--test-style 'basic "foo" 0 '("foobar" "foo!" "barfoo" "xfooy" "boobar") '("foobar" "barfoo" "xfooy"))) (ert-deftest completion-basic-style-test-2 () ;; point foo (completion--test-style 'basic "foo" 2 '("foobar" "foo!" "fobar" "barfoo" "xfooy" "boobar") '("foobar"))) (ert-deftest completion-substring-style-test () (completion--test-style 'substring "foo" 1 '("foobar" "foo!" "barfoo" "xfooy" "boobar") '("foobar" "barfoo" "xfooy"))) (ert-deftest completion-emacs21-style-test () (completion--test-style 'emacs21 "foo" 1 '("foobar" "foo!" "fobar" "barfoo" "xfooy" "boobar") '("foobar"))) (ert-deftest completion-emacs22-style-test () (completion--test-style 'emacs22 "fo0" 1 '("foobar" "foo!" "fobar" "barfoo" "xfooy" "boobar") '("foobar" "fobar"))) ;; suffix ignored completely (ert-deftest completion-flex-style-test () (completion--test-style 'flex "abc" 1 '("abc" "abc!" "xaybzc" "xaybz") '("abc" "xaybzc"))) (ert-deftest completion-initials-style-test () (completion--test-style 'initials "abc" 1 '("a-b-c" "a-b-c!" "ax-by-cz" "xax-by-cz") '("a-b-c" "ax-by-cz"))) (ert-deftest completion-pcm-style-test () (completion--test-style 'partial-completion "ax-b-c" 1 '("ax-b-c" "ax-b-c!" "ax-by-cz" "xax-by-cz") '("ax-b-c" "ax-by-cz"))) (ert-deftest completion-filter-completions-highlight-test () ;; point at the beginning |foo (let* ((completion-styles '(basic)) (result (completion-filter-completions "foo" '("foobar" "fbarfoo" "fxfooy" "bar") nil 1 nil))) (should (equal (format "%S" (alist-get 'completions result)) (format "%S" '("foobar" "fbarfoo" "fxfooy")))) (should (equal (format "%S" (funcall (alist-get 'highlight result) (alist-get 'completions result))) (format "%S" '(#("foobar" 0 1 (face (completions-common-part)) 1 2 (face (completions-first-difference))) #("fbarfoo" 0 1 (face (completions-common-part)) 1 2 (face (completions-first-difference))) #("fxfooy" 0 1 (face (completions-common-part)) 1 2 (face (completions-first-difference))))))))) (defun completion--test-boundaries (style string table result) (let ((table (lambda (str pred action) (pcase action (`(boundaries . ,suffix) `(boundaries ,(1+ (string-match-p "<\\|/" str)) . ,(or (string-search ">" suffix) (length suffix)))) (_ (complete-with-action action table (replace-regexp-in-string ".*[after" '("other") nil) (completion--test-boundaries 'emacs21 "beforeafter" '("ainput>after" "input>after" "inpux>after" "inxputy>after" "input>after2") '((base . 7) (end . 18) (completions "input>after" "input>after2")))) (ert-deftest completion-emacs22-boundaries-test () (completion--test-boundaries 'emacs22 "beforeafter" '("other") nil) (completion--test-boundaries 'emacs22 "beforeafter" '("ainxxx" "inyy" "inzzz") '((base . 7) (end . 12) (completions "inyy" "inzzz")))) (ert-deftest completion-basic-boundaries-test () (completion--test-boundaries 'basic "beforeafter" '("other") nil) (completion--test-boundaries 'basic "beforeafter" '("ainput" "input" "inpux" "inxputy") '((base . 7) (end . 12) (completions "input" "inxputy")))) (ert-deftest completion-substring-boundaries-test () (completion--test-boundaries 'substring "beforeafter" '("other") nil) (completion--test-boundaries 'substring "beforeafter" '("ainputs" "inputs" "inpux" "inxputsy") '((base . 7) (end . 13) (completions "ainputs" "inputs" "inxputsy")))) (ert-deftest completion-pcm-boundaries-test () (completion--test-boundaries 'partial-completion "beforeafter" '("other") nil) (completion--test-boundaries 'partial-completion "beforeafter" '("ain-pu-ts" "in-pts" "in-pu-ts" "in-px" "inx-ptsy") '((base . 7) (end . 12) (completions "in-pts" "in-pu-ts" "inx-ptsy")))) (ert-deftest completion-initials-boundaries-test () (completion--test-boundaries 'initials "/ip|t" '("other") nil) (completion--test-boundaries 'initials "/ip|t" '("ain/pu/ts" "in/pts" "in/pu/ts" "a/in/pu/ts" "in/pu/ts/foo" "in/px" "inx/ptsy") '((base . 1) (end . 4) (completions "in/pu/ts" "in/pu/ts/foo")))) (defun completion-emacs22orig-all-completions (string table pred point) (let ((beforepoint (substring string 0 point))) (completion-hilit-commonality (all-completions beforepoint table pred) point (car (completion-boundaries beforepoint table pred ""))))) (ert-deftest completion-upgrade-return-type-test () ;; Test transparent upgrade of list completion style return value ;; to the alist return value format of `completion-format-completions'. (let ((completion-styles-alist '((emacs22orig completion-emacs22-try-completion completion-emacs22orig-all-completions nil)))) (completion--test-boundaries 'emacs22orig "beforeafter" '("ainxxx" "inyy" "inzzz") '((base . 7) ;; 18 is incorrect, should be 12! ;; But the information is not available ;; due to the completion-style upgrade. (end . 18) ;; Identity highlighting function. (highlight . identity) (completions "inyy" "inzzz"))))) (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)) (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 (get-buffer-window "*Completions*" 0)) (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 (get-buffer-window "*Completions*" 0)) (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 (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- M-")) (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