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

Author: AlexKnauth

rackunit-doc/rackunit/scribblings/check.scrbl

@@ -1,10 +1,11 @@
 #lang scribble/doc
 @(require "base.rkt")
 
-@(require (for-label racket/match))
+@(require (for-label racket/match racket/list))
 
 @(define rackunit-eval (make-base-eval))
 @(interaction-eval #:eval rackunit-eval (require rackunit))
+@(interaction-eval #:eval rackunit-eval (require racket/list))
 @(interaction-eval #:eval rackunit-eval (error-print-context-length 0))
 
 @title{Checks}
@@ -17,8 +18,9 @@ for customizing how failures are handled).
 
 Although checks are implemented as macros, which is
 necessary to grab source location, they are conceptually
-functions (with the exception of @racket[check-match] below).
-This means, for instance, checks always evaluate
+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 checks as first class
 functions, though you will lose precision in the reported
 source locations if you do so.
@@ -224,6 +226,36 @@ This check fails because of a failure to match:
 
 }
 
+@defform[(check-equal?/values expr expr)]{
+
+Like @racket[check-equal?], except handling multiple values.  
+
+@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.  
+
+@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

@@ -39,6 +39,8 @@
          check-not-eqv?
          check-not-equal?
          check-match
+         check-equal?/values
+         check-match/values
          fail)
 
 ;; parameter current-check-handler : (-> any any)
@@ -221,8 +223,65 @@
               (make-check-actual actual-val)
               (make-check-expected '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 (cons 'values (map printed actual-lst)))
+                 (make-check-expected (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 (cons 'values (map printed actual-lst)))
+                 (make-check-expected '(values expected ...)))
+           (lambda ()
+             (check-not-false (match actual-lst
+                                [(list expected ...) pred]
+                                [_ #f]))))))])))
+
+;; A helper struct for check-equal?/values and check-match/values
+(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

@@ -111,6 +111,8 @@
          check-not-equal?
          check-regexp-match
          check-match
+         check-equal?/values
+         check-match/values
          fail)
 
 

rackunit-test/tests/rackunit/check-test.rkt

@@ -126,6 +126,29 @@
                 (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"
@@ -157,11 +180,28 @@
    (make-failure-test "check-= failure"
                       check-= 1.0 2.0 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))