From bdf4dfd5a1a4b0f144a71f3c48fb00ea43bb7c54 Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Fri, 16 Dec 2022 13:53:48 -0600 Subject: [PATCH 1/4] Replace use of home-brewed matching construct. Previously FiveAM used a home-brewed matching construct to process `is` forms in tests. Replaced this home-brew matcher (which was only used in one place in the code) by a dependency on the "trivia" pattern-matching library. --- fiveam.asd | 3 ++- src/utils.lisp | 29 +++++++++++++++++++++++++++++ 2 files changed, 31 insertions(+), 1 deletion(-) diff --git a/fiveam.asd b/fiveam.asd index e364e2f..d88f74d 100644 --- a/fiveam.asd +++ b/fiveam.asd @@ -8,7 +8,8 @@ :version (:read-file-form "version.sexp") :description "A simple regression testing framework" :license "BSD" - :depends-on (:alexandria :net.didierverna.asdf-flv :trivial-backtrace) + :depends-on (:alexandria :net.didierverna.asdf-flv :trivial-backtrace + :trivia) :pathname "src/" :components ((:file "package") (:file "utils" :depends-on ("package")) diff --git a/src/utils.lisp b/src/utils.lisp index 8f4b58b..7c229c7 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -129,6 +129,7 @@ ELSE will be executed." (find-vars match-spec)) (delete-duplicates vars))) +#| (defmacro list-match-case (target &body clauses) (if clauses (destructuring-bind ((test &rest progn) &rest others) @@ -146,6 +147,34 @@ ELSE will be executed." ,@progn) (list-match-case ,tgt ,@others)))))) nil)) +|# + +(defun list-match-pattern->trivia (pattern) + (cond ((symbolp pattern) + ;; must be a variable that matches the entire list + (or (varsymp pattern) (error "Cannot match a list against a single constant: ~s" pattern)) + (let ((varname (string-trim (list #\?) (symbol-name pattern)))) + ;; to avoid unreferenced variables warnings, treat _-prefixed variables specially. + (if (eql (char varname 0) #\_) + '(list* _) + `(list* ,pattern)))) + ((eq (first pattern) 'not) + (or (= (length pattern) 2) (error "Ill-formed list-match pattern ~s" pattern)) + `(list 'not ,(list-match-pattern->trivia (second pattern)) + )) + (t + (if (proper-list-p pattern) + `(list ,@pattern) + (let ((final-var (cdr (last pattern))) + ;; everything but the final variable will be in the following + (other (reverse (reverse pattern)))) + `(list* ,@other ,final-var)))))) + +(defmacro list-match-case (target &body clauses) + `(trivia:match ,target + ,@(loop :for (pattern . code) :in clauses + :collecting (cons (list-match-pattern->trivia pattern) + code)))) ;;;; * def-special-environment From 84e3f43a0dcc25c6c8c36fdfee4ac63060af6214 Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Fri, 16 Dec 2022 13:56:24 -0600 Subject: [PATCH 2/4] Use new matcher to rewrite the `is` macro. The new matcher allows us to have comparisons with modifier arguments, such as (set-equal X Y :test 'equalp) which could not be handled by previous versions of FiveAM. --- src/check.lisp | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/check.lisp b/src/check.lisp index 57e95e1..964ff5e 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -131,7 +131,7 @@ REASON-ARGS is provided, is generated based on the form of TEST: "Argument to IS must be a list, not ~S" test) (let (bindings effective-test default-reason-args) (with-gensyms (e a v) - (flet ((process-entry (predicate expected actual &optional negatedp) + (flet ((process-entry (predicate expected actual &optional negatedp modifiers) ;; make sure EXPECTED is holding the entry that starts with 'values (when (and (consp actual) (eq (car actual) 'values)) @@ -157,11 +157,11 @@ REASON-ARGS is provided, is generated based on the form of TEST: (setf effective-test `(progn ,@setf-forms ,(if negatedp - `(not (,predicate ,e ,a)) - `(,predicate ,e ,a))))))) + `(not (,predicate ,e ,a ,@modifiers)) + `(,predicate ,e ,a ,@modifiers))))))) (list-match-case test - ((not (?predicate ?expected ?actual)) - (process-entry ?predicate ?expected ?actual t) + ((not (?predicate ?expected ?actual . ?modifiers)) + (process-entry ?predicate ?expected ?actual t ?modifiers) (setf default-reason-args (list "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (it should not be)" `',?actual a `',?predicate e))) @@ -176,6 +176,11 @@ REASON-ARGS is provided, is generated based on the form of TEST: (setf default-reason-args (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%" `',?actual a `',?predicate e))) + ((?predicate ?expected ?actual . ?modifiers) + (process-entry ?predicate ?expected ?actual nil ?modifiers) + (setf default-reason-args + (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%" + `',?actual a `',?predicate e))) ((?satisfies ?value) (setf bindings (list (list v ?value)) effective-test `(,?satisfies ,v) @@ -185,7 +190,8 @@ REASON-ARGS is provided, is generated based on the form of TEST: (?_ (setf bindings '() effective-test test - default-reason-args (list "~2&~S~2% was NIL." `',test))))) + default-reason-args (list "~2&~S~2% was NIL." `',test))) + )) `(let ,bindings (if ,effective-test (add-result 'test-passed :test-expr ',test) From 7230964d3086cb230d3f2fd0c3456e1bc9c53784 Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Fri, 16 Dec 2022 13:58:23 -0600 Subject: [PATCH 3/4] Add tests based on set-equal. --- t/tests.lisp | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/t/tests.lisp b/t/tests.lisp index b5136f5..eb24003 100644 --- a/t/tests.lisp +++ b/t/tests.lisp @@ -31,6 +31,28 @@ (is-true nil) (is-false t)) +(def-test is-set-equal (:suite test-suite) + (is (set-equal '(a b c) '(b c a))) + ;; parsing the modifiers correctly? + (is (set-equal '(a b c) '(b c a) :test 'eq)) + (is-false (set-equal '("a" "b" "c") '("b" "c" "a") :test 'eq)) + (is (set-equal '("a" "b" "c") '("b" "c" "a") :test 'string-equal)) + (is-false (set-equal '((a b c)) '((b c a)) :test 'equalp)) + ;; two permuted sets + (let ((ps1 + '((B A D C) (A B D C) (D B A C) (B D A C) (A D B C) (D A B C) (C A D B) + (A C D B) (D C A B) (C D A B) (A D C B) (D A C B) (C B D A) (B C D A) + (D C B A) (C D B A) (B D C A) (D B C A) (C B A D) (B C A D) (A C B D) + (C A B D) (B A C D) (A B C D))) + (ps2 + '((B A D C) (D B A C) (A B D C) (B D A C) (A D B C) (D A B C) (C A D B) + (A C D B) (D C A B) (C D A B) (A D C B) (D A C B) (C B D A) (B C D A) + (D C B A) (C D B A) (B D C A) (D B C A) (C B A D) (B C A D) (A C B D) + (C A B D) (B A C D) (A B C D)))) + (is-false (equalp ps1 ps2)) + (is-false (set-equal ps1 ps2)) + (is (set-equal ps1 ps2 :test 'equalp)))) + (def-test is (:profile t) (with-test-results (results is1) (is (= 6 (length results))) From 8884523ae262eece2cc17a3e2d8ad3488a467ae7 Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Fri, 16 Dec 2022 14:10:18 -0600 Subject: [PATCH 4/4] Bump minor version number. The change in this branch is backwards compatible, but tests that are constructed using some newly-available comparison operations will not be usable in the previous version of FiveAM. --- version.sexp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/version.sexp b/version.sexp index f36be25..925cb56 100644 --- a/version.sexp +++ b/version.sexp @@ -1,2 +1,2 @@ ;; -*- lisp -*- -"1.4.2" +"2.0.0"