Skip to content

Extend the set of comparison operations permitted #92

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 4 commits into
base: master
Choose a base branch
from
Open

Extend the set of comparison operations permitted #92

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
bdf4dfd
Replace use of home-brewed matching construct.
rpgoldman Dec 16, 2022
84e3f43
Use new matcher to rewrite the `is` macro.
rpgoldman Dec 16, 2022
7230964
Add tests based on set-equal.
rpgoldman Dec 16, 2022
8884523
Bump minor version number.
rpgoldman Dec 16, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 2 additions & 1 deletion fiveam.asd
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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"))
Expand Down
18 changes: 12 additions & 6 deletions src/check.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand All @@ -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)))
Expand All @@ -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)
Expand All @@ -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)
Expand Down
29 changes: 29 additions & 0 deletions src/utils.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -146,6 +147,34 @@ ELSE will be executed."
,@progn)
(list-match-case ,tgt ,@others))))))
nil))
|#

(defun list-match-pattern->trivia (pattern)
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Does this make a dependency on trivia?

Copy link
Contributor Author

@rpgoldman rpgoldman Dec 16, 2022 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, it does. I looked at list-match-case and it was too much trouble to figure it out to fix a single case statement.

If one doesn't like the dependency on trivia, it would probably be better to rewrite the case statement in the is macro into a hand-coded multi-way branch: that would be easier than trying to understand the hand-written matcher well enough to fix it.

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

OK. I'm not the maintainer of fiveam.
But there are Cl implementations that don't work well with trivia, like ABCL.
fiveam should work with the largest set of CL implementations.

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is there a workaround to not using Trivia but make your set-equa usecase work?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@mdbergmann

OK. I'm not the maintainer of fiveam. But there are Cl implementations that don't work well with trivia, like ABCL. fiveam should work with the largest set of CL implementations.

I did not know about that. Do you have any pointers to information about trivia's (in)compatibility with various lisp implementations?

I agree with you that 5AM should aim to be as portable as possible.

Copy link
Contributor Author

@rpgoldman rpgoldman Dec 17, 2022 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@mdbergmann I believe that the best work-around -- although it is not good -- would be simply to rip out the use of pattern-matching and have a hand-written cond expression with destructuring-bind.

As I implied earlier, there's a lot more code to make list-match-case work than there is actual use of this macro!

Another possibility is that the uses of trivia here are so limited that maybe they will work on any lisp implementation even ABCL. Again, it would help to know what breaks on ABCL.

It would be nice if 5AM had some github-actions to run the tests on multiple lisp implementations (like we have for ASDF and ITERATE on common-lisp.net).

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I just tried on ABCL. Trivia can be compiled and basic pattern matching works.
But running the whole test suite for some reason fails, though for some other reason than trivia.

(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

Expand Down
22 changes: 22 additions & 0 deletions t/tests.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)))
Expand Down
2 changes: 1 addition & 1 deletion version.sexp
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,2 +1,2 @@
;; -*- lisp -*-
"1.4.2"
"2.0.0"