(module check-values mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
(planet "util.ss" ("schematics" "schemeunit.plt" 2)))
(provide check-values* check-values)
(define-syntax check-values*
(lambda (stx)
(syntax-case stx ()
[(check-values* same? actual (expected ...))
(syntax/loc stx (check-values* same? actual (expected ...) ""))]
[(check-values* same? actual (expected ...) msg)
#`(let ([pred same?])
#,(syntax/loc stx
(check-values actual ((pred expected) ...) msg)))]
[_
(raise-syntax-error
stx
"expected (check-values* pred actual-expr (expected ...) [msg])"
stx)])))
(define-syntax check-values
(lambda (stx)
(syntax-case stx ()
[(check-values actual ([same? expected] ...))
(syntax/loc stx (check-values actual ([same? expected] ...) ""))]
[(check-values actual ([same? expected] ...) msg-arg)
#`(let* ([expected-vals (list expected ...)]
[eq-preds (list same? ...)]
[raw-msg msg-arg]
[msg (if (string=? raw-msg "")
""
(string-append raw-msg ": "))])
(call-with-values (lambda () actual)
(lambda actual-vals
#,(syntax/loc stx
(check-equal? (length actual-vals)
(length expected-vals)
(format "~aexpected ~a result~a, got ~a"
msg
(length expected-vals)
(if (= (length expected-vals) 1) "" "s")
(length actual-vals))))
(let loop ([actuals actual-vals]
[expecteds expected-vals]
[eq-preds eq-preds]
[index 1])
(unless (null? actuals)
#,(syntax/loc stx
(check (car eq-preds) (car actuals) (car expecteds)
(parameterize ([print-struct #t])
(format "~aresult ~a: expected ~a, got ~a"
msg
index
(car expecteds)
(car actuals)))))
(loop (cdr actuals)
(cdr expecteds)
(cdr eq-preds)
(add1 index)))))))]
[_
(raise-syntax-error
stx
"expected (check-values actual ((same? expected) ...) [msg])"
stx)]))))