diff --git a/collects/rackunit/private/check.rkt b/collects/rackunit/private/check.rkt index 3ad4b58f36..a0679bdc5d 100644 --- a/collects/rackunit/private/check.rkt +++ b/collects/rackunit/private/check.rkt @@ -1,6 +1,7 @@ #lang racket/base -(require (for-syntax racket/base +(require racket/match + (for-syntax racket/base "location.rkt") "base.rkt" "check-info.rkt" @@ -31,6 +32,7 @@ check-not-eq? check-not-eqv? check-not-equal? + check-match fail) ;; default-check-handler : any -> any @@ -274,3 +276,28 @@ (define-simple-check (fail) #f) +;; NOTE(jpolitz): This match form isn't eager like the others, hence the +;; define-syntax and the need to carry around location information +(define-syntax (check-match stx) + (syntax-case stx () + [(_ actual expected pred) + (quasisyntax + (let ([actual-val actual]) + (with-check-info* + (list (make-check-name 'check-match) + (make-check-location + (list '(unsyntax (syntax-source stx)) + '(unsyntax (syntax-line stx)) + '(unsyntax (syntax-column stx)) + '(unsyntax (syntax-position stx)) + '(unsyntax (syntax-span stx)))) + (make-check-expression '#,(syntax->datum stx)) + (make-check-actual actual-val) + (make-check-expected 'expected)) + (lambda () + (check-true (match actual-val + [expected pred] + [_ #f]))))))] + [(_ actual expected) + (syntax/loc stx (check-match actual expected #t))])) + diff --git a/collects/rackunit/private/test.rkt b/collects/rackunit/private/test.rkt index 69ee78b1f2..f025cb7f9e 100644 --- a/collects/rackunit/private/test.rkt +++ b/collects/rackunit/private/test.rkt @@ -104,6 +104,7 @@ check-not-eqv? check-not-equal? check-regexp-match + check-match fail) (define (void-thunk) (void)) diff --git a/collects/rackunit/scribblings/check.scrbl b/collects/rackunit/scribblings/check.scrbl index 168afc64ff..0d6c496784 100644 --- a/collects/rackunit/scribblings/check.scrbl +++ b/collects/rackunit/scribblings/check.scrbl @@ -15,7 +15,8 @@ information detailing the failure. Although checks are implemented as macros, which is necessary to grab source location, they are conceptually -functions. This means, for instance, checks always evaluate +functions (with the exception of @racket[check-match] below). +This means, for instance, checks always evaluate their arguments. You can use checks as first class functions, though you will lose precision in the reported source locations if you do so. @@ -180,6 +181,47 @@ The following check fails: ] } +@defform*[((check-match v pattern) + (check-match v pattern pred))]{ + +A check that pattern matches on the test value. Matches the test value +@racket[v] against @racket[pattern] as a @racket[match] clause. If no +@racket[pred] is provided, then if the match succeeds, the entire check +succeeds. For example, this use succeeds: + +@interaction[#:eval rackunit-eval + (check-match (list 1 2 3) (list _ _ 3)) +] + +This check fails to match: + +@interaction[#:eval rackunit-eval + (check-match (list 1 2 3) (list _ _ 4)) +] + +If @racket[pred] is provided, it is evaluated with the bindings from the +match pattern. If it produces @racket[#t], the entire check succeeds, +otherwise it fails. For example, this use succeeds, binding @racket[x] +in the predicate: + +@interaction[#:eval rackunit-eval + (check-match (list 1 (list 3)) (list x (list _)) (odd? x)) +] + +This check fails because the @racket[pred] fails: + +@interaction[#:eval rackunit-eval + (check-match 6 x (odd? x)) +] + +This check fails because of a failure to match: + +@interaction[#:eval rackunit-eval + (check-match (list 1 2) (list x) (odd? x)) +] + +} + @defproc[(check (op (-> any any any)) (v1 any) diff --git a/collects/tests/rackunit/check-test.rkt b/collects/tests/rackunit/check-test.rkt index 4952d7570c..f790a6bbaa 100644 --- a/collects/tests/rackunit/check-test.rkt +++ b/collects/tests/rackunit/check-test.rkt @@ -44,6 +44,18 @@ (lambda () (apply pred args))))) +;; NOTE(jpolitz): Not generalizing make-failure-test above because (at +;; least) util-test expects it to be present, not exported, and a +;; 2-argument procedure to test require/expose +(define-syntax make-failure-test/stx + (syntax-rules () + [(_ name pred arg ...) + (test-case + name + (check-exn exn:test:check? + (lambda () + (pred arg ...))))])) + (define-check (good) #t) @@ -92,6 +104,28 @@ (define-simple-check (check-symbol? x) (symbol? x)) (for-each check-symbol? '(a b c)))) + + (test-case "Trivial check-match test" + (check-match "dirigible" _)) + + (test-case "Simple check-match test" + (check-match (list 1 2 3) (list _ _ 3))) + + (test-case "check-match with a nested struct" + (let () + (struct data (f1 f2 f3)) + (check-match (data 1 2 (data 1 2 3)) + (data _ 2 (data _ _ _))))) + + (test-case "Simple check-match test with a binding pred" + (check-match 3 x (odd? x))) + + (test-case "check-match with a nested struct and a binding pred" + (let () + (struct data (f1 f2 f3)) + (check-match (data 1 2 (data 1 2 3)) + (data _ _ (data x y z)) + (equal? (+ x y z) 6)))) ;; Failures (make-failure-test "check-equal? failure" @@ -122,6 +156,12 @@ check-not-false #f) (make-failure-test "check-= failure" check-= 1.0 2.0 0.0) + + (make-failure-test/stx "check-match failure pred" + check-match 5 x (even? x)) + + (make-failure-test/stx "check-match failure match" + check-match (list 4 5) (list _)) (test-case "check-= allows differences within epsilon" (check-= 1.0 1.09 1.1))