[plt-scheme] schemeunit and multiple-values

On Mon, Dec 11, 2006 at 08:18:07AM -0700, Chongkai Zhu wrote:
> In SchemeUnit (version 2 in my case), there seems to be no standard way to
> express a test of an expression that returns multiple-values. Is is possible
> to have check-eq? etc. support:
>
> (check-eq? <expression> (values <expression> ...))
>
> Thanks.

Yes, I've run into that problem before.  Carl Eastlund and I developed a
solution to this for the previous SchemeUnit interface.  I've sent an
updated version to the Schematics folks for inclusion; hopefully it will
show up soon.  To get you started in the interim, I've included the macro
definitions below.

Usage:

  (check-values same? actual (expected ...) msg)
     same?: predicate used to compare individual results with the
       corresponding expected values
     actual: expression to be tested.  Unlike other checks, you should
       *NOT* wrap this in a thunk.
     expected: expected values.
     msg: optional message

  (check-values* actual ([same? expected] ...) msg)
     basically the same as check-values, but you can specify a different
     equality predicate for each value.

The macros do basic error checking and will also give you somewhat
informative error messages should one of the checks fail.  In particular,
if it fails because you expected 2 results and got 3, the message will
indicate that; likewise, the message will indicate which of the results
didn't match the expected value, should that happen.

So, for instance:

    (check-values = (quotient/remainder 5 2) (2 1))       succeeds
    (check-values = (quotient/remainder 5 2) (2))
        fails with msg "expected 1 result, got 2"
    (check-values = (quotient/remainder 5 2) (2 3))
        fails with msg "result 2: expected 3, got 2"

Note that I use format and ~a to display the values in the messages in the
last case, so setting print-struct to #t will give you more informative
output.  (I should probably do that in the macros themselves, so you don't
have to run the code to be tested in a specific parameterization.)

Comments on the macros welcome.

Richard

  (define-syntax check-values
    (lambda (stx)
      (syntax-case stx ()
        [(check-values same? actual (expected ...))
         #'(check-values same? actual (expected ...) "")]
        [(check-values same? actual (expected ...) msg)
         #'(let ([pred same?])
             (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] ...))
         #'(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
                 (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)))
                 (recur loop ([actuals actual-vals]
                              [expecteds expected-vals]
                              [eq-preds eq-preds]
                              [index 1])
                   (unless (null? actuals)
                     (check (car eq-preds) (car actuals) (car expecteds)
                            (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)])))