check-values.ss
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; check-values.ss
;; Version 1.0
;;
;; Copyright (c) 2007 Richard Cobbe.  All rights reserved.
;;
;; Defines macros for use with SchemeUnit, to test functions and forms
;; that return multiple values.
;;
;; See doc.txt for info.
;;
;; TODO: wrap everything in syntax/loc to preserve source location info.  In
;; second-case of check-values, this means turning outside #' into #` and
;; putting #, right in front of syntax/loc.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(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)]))))