add check-equal?/values and check-match/values

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)

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))))
+

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)
 
 

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"