diff --git a/rackunit-doc/rackunit/scribblings/check.scrbl b/rackunit-doc/rackunit/scribblings/check.scrbl index 3288485..b0995b6 100644 --- a/rackunit-doc/rackunit/scribblings/check.scrbl +++ b/rackunit-doc/rackunit/scribblings/check.scrbl @@ -1,10 +1,10 @@ #lang scribble/doc @(require "base.rkt") -@(require (for-label racket/match racket/flonum)) +@(require (for-label racket/match racket/flonum racket/list)) @(define rackunit-eval (make-base-eval)) -@(interaction-eval #:eval rackunit-eval (require rackunit racket/flonum)) +@(interaction-eval #:eval rackunit-eval (require rackunit racket/flonum racket/list)) @(interaction-eval #:eval rackunit-eval (error-print-context-length 0)) @title{Checks} @@ -17,7 +17,8 @@ check will report the failure using the current @tech{check-info stack} Although checks are implemented as macros, which is necessary to grab source locations (see @secref{rackunit:custom-checks}), they are conceptually -functions (with the exception of @racket[check-match] below). +functions (with the exception of @racket[check-match], @racket[check-equal?/values], and +@racket[check-match/values] below). This means, for instance, checks always evaluate their arguments. You can use a check as a first class function, though this will affect the source location that the check grabs. @@ -250,6 +251,41 @@ This check fails because of a failure to match: } +@defform[(check-equal?/values actual-expr expected-expr)]{ + +Like @racket[check-equal?], except handling multiple values. +For the check to pass, the @racket[actual-expr] and +@racket[expected-expr] must produce the same number of values +and the two lists of values must be equal. + +@interaction[#:eval rackunit-eval + (check-equal?/values (quotient/remainder 67 12) + (values 5 7)) + (check-equal?/values (split-at (list 'a 'b 'c 'd 'e) 2) + (values (list 'a 'b) + (list 'c 'd 'e))) +] +} + +@defform*[#:literals (values) + ((check-match/values expr (values pattern ...)) + (check-match/values expr (values pattern ...) #:when pred) + (check-match/values expr (values pattern ...) #:unless pred))]{ + +Like @racket[check-match], except handling multiple values. +For the check to pass, the @racket[expr] must produce the same +number of values as the number of @racket[pattern]s, each +value must match the corresponding pattern, and the +`#:when`/`#:unless` conditions must pass if they exist. + +@interaction[#:eval rackunit-eval + (check-match/values (split-at (list 1 3 4 6 8) 2) + (values (list (? odd?) ...) + (list (? even?) ...))) +] +} + + @defproc[(check (op (-> any any any)) (v1 any) diff --git a/rackunit-lib/rackunit/private/check.rkt b/rackunit-lib/rackunit/private/check.rkt index cccf23e..8b8d492 100644 --- a/rackunit-lib/rackunit/private/check.rkt +++ b/rackunit-lib/rackunit/private/check.rkt @@ -42,6 +42,8 @@ check-not-eqv? check-not-equal? check-match + check-equal?/values + check-match/values fail) (define current-check-handler (make-parameter display-test-failure/error)) @@ -229,10 +231,71 @@ (syntax->location (quote-syntax #,(datum->syntax #f 'loc stx)))) (make-check-expression '#,(syntax->datum stx)) (make-check-actual actual-val) - (make-check-expected 'expected)) + (make-check-expected (written 'expected))) (lambda () - (check-true (match actual-val - [expected pred] - [_ #f]))))))] + (check-not-false (match actual-val + [expected pred] + [_ #f]))))))] [(_ actual expected) (syntax/loc stx (check-match actual expected #t))])) + +;; NOTE: Like check-match, the check-equal?/values and check-match/values forms +;; do not evaluate their arguments like functions would, so they're defined +;; with define-syntax instead +(define-syntax check-equal?/values + (lambda (stx) + (syntax-case stx () + [(_ actual expected) + (quasisyntax + (let ([actual-lst (call-with-values (λ () actual) list)] + [expected-lst (call-with-values (λ () expected) list)]) + (with-check-info* + (list (make-check-name 'check-equal?/values) + (make-check-location + (syntax->location (quote-syntax #,(datum->syntax #f 'loc stx)))) + (make-check-expression '#,(syntax->datum stx)) + (make-check-actual (written (cons 'values (map printed actual-lst)))) + (make-check-expected (written (cons 'values (map printed expected-lst))))) + (lambda () + (check-equal? actual-lst expected-lst)))))]))) + +(define-syntax check-match/values + (lambda (stx) + (syntax-case stx (values) + [(_ actual (values expected ...)) + (syntax/loc stx + (check-match/values actual + (values expected ...) + #:when #t))] + [(_ actual (values expected ...) #:unless unless-condition) + (syntax/loc stx + (check-match/values actual + (values expected ...) + #:when (not unless-condition)))] + [(_ actual (values expected ...) #:when pred) + (quasisyntax + (let ([actual-lst (call-with-values (λ () actual) list)]) + (with-check-info* + (list (make-check-name 'check-match/values) + (make-check-location + (syntax->location (quote-syntax #,(datum->syntax #f 'loc stx)))) + (make-check-expression '#,(syntax->datum stx)) + (make-check-actual (written (cons 'values (map printed actual-lst)))) + (make-check-expected (written '(values expected ...)))) + (lambda () + (check-not-false (match actual-lst + [(list expected ...) pred] + [_ #f]))))))]))) + +;; Helper structs for check-equal?/values and check-match/values +(struct written (val) #:transparent + #:property prop:custom-write + (lambda (this out mode) (write (written-val this) out))) + +(struct printed (val) #:transparent + #:property prop:custom-write + (lambda (this out mode) + (if (integer? mode) + (print (printed-val this) out mode) + (print (printed-val this) out)))) + diff --git a/rackunit-lib/rackunit/private/test.rkt b/rackunit-lib/rackunit/private/test.rkt index de5a12c..3b68b1e 100644 --- a/rackunit-lib/rackunit/private/test.rkt +++ b/rackunit-lib/rackunit/private/test.rkt @@ -112,6 +112,8 @@ check-not-equal? check-regexp-match check-match + check-equal?/values + check-match/values fail) diff --git a/rackunit-test/tests/rackunit/check-test.rkt b/rackunit-test/tests/rackunit/check-test.rkt index f2cde7e..eb1581a 100644 --- a/rackunit-test/tests/rackunit/check-test.rkt +++ b/rackunit-test/tests/rackunit/check-test.rkt @@ -138,7 +138,30 @@ (check-match (data 1 2 (data 1 2 3)) (data _ _ (data x y z)) (equal? (+ x y z) 6)))) - + + (test-case "Trivial check-match/values test" + (check-match/values "whatever" (values _))) + + (test-case "Simple check-match/values test" + (check-match/values (values 1 2 3) (values _ _ 3))) + + (test-case "Using check-match/values with ellipses" + (check-match/values (values 1 2 4 5) + (values 1 (? even? es) ... 5) + #:when (equal? (apply + es) 6))) + + (test-case "check-match/values with nested struct" + (let () + (struct data (f1 f2 f3)) + (define (f) + (values (data 1 2 (data 1 2 3)) + (data 4 5 (data 6 7 8)))) + (check-match/values (f) + (values (data _ 2 (data x y z)) + (data _ 5 (data a b c))) + #:when (equal? (+ x y z a b c) 27)))) + + ;; Failures (make-failure-test "check-equal? failure" check-equal? 1 2) @@ -180,12 +203,31 @@ (hash 'a 3.0 'b 98.6) 0.0) + + ;; check-match (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 _)) - + + ;; check-match/values + (make-failure-test/stx "check-match/values: wrong number of values" + check-match/values (values 3 4) (values _)) + + (make-failure-test/stx "check-match/values: right number, one value wrong" + check-match/values (values 1 2 3) (values 1 2 4)) + + (make-failure-test/stx "check-match/values: when-condition failure" + check-match/values (values 1 2 3) (values x y z) + #:when (odd? (+ x y z))) + + (make-failure-test/stx "check-match/values: failure with ellipses" + check-match/values + (values 1 2 4 5) + (values 1 (? even? es) ...)) + + (test-case "check-= allows differences within epsilon" (check-= 1.0 1.09 1.1)) (test-case "check-within allows differences within epsilon"