plt/test.ss
;;;
;;; Time-stamp: <2006-11-01 15:18:49 nhw>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;

;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.

;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE.  See the GNU Lesser General Public
;;; License for more details.

;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA

;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:

(module test mzscheme
  
  (require (lib "include.ss")
           (lib "kw.ss")
           "keyword.ss"
           "check.ss"
           "check-info.ss"
           "result.ss"
           "base.ss")
  
  (provide (struct exn:test:check (stack))
           (struct check-info (name value))
           (struct test-result (test-case-name))
           (struct test-failure (result))
           (struct test-error (result))
           (struct test-success (result))
           (struct schemeunit-test-case (name action))
           (struct schemeunit-test-suite (name tests before after))
           
           with-check-info
           with-check-info*

           make-check-name
           make-check-params
           make-check-location
           make-check-expression
           make-check-message

           check-name?
           check-params?
           check-location?
           check-expression?
           check-message?

           test-case
           test-suite

           before
           after
           around

           define-shortcut

           test-check
           test-pred
           test-equal?
           test-eq?
           test-eqv?
           test-=
           test-true
           test-false
           test-not-false
           test-exn
           test-not-exn
           
           foldts
           fold-test-results
           run-test-case
           run-test
           
           fail-check

           define-check
           define-simple-check
           define-binary-check
           
           check
           check*
           check-exn
           check-exn*
           check-not-exn
           check-not-exn*
           check-true
           check-true*
           check-false
           check-false*
           check-pred
           check-pred*
           check-eq?
           check-eq?*
           check-eqv?
           check-eqv?*
           check-equal?
           check-equal?*
           check-=
           check-=*
           check-not-false
           check-not-false*
           fail
           fail*)

  (define (void-thunk) (void))
  
  ;; macro test-case : expr ... -> test-case
  (define-syntax (test-case stx)
    (syntax-case stx ()
      [(_ name expr ...)
       (syntax/loc stx
         (make-schemeunit-test-case 
          name
          (lambda () (begin (void) expr ...))))]
      [_
       (raise-syntax-error
        #f
        "Correct form is (test-case name expr ...)"
        stx)]))
  
  ;;!
  ;; test-suite : name [#:before thunk] [#:after thunk] test ...
  ;;                     -> test-suite
  ;;
  ;; Creates a test-suite with the given name and tests.
  ;; Setup and teardown actions (thunks) may be specified by
  ;; preceding the actions with the keyword #:before or
  ;; #:after.
  (define/kw (test-suite name
                         #:key [before void-thunk]
                               [after void-thunk]
                         #:body tests)
    (make-schemeunit-test-suite name tests before after))

  (define-syntax before
    (syntax-rules ()
      ((_ before-e expr1 expr2 ...)
       (dynamic-wind
           (lambda ()
             before-e)
           (lambda ()
             expr1 expr2 ...)
           (lambda ()
             (void))))
      ((before error ...)
       (raise-syntax-error
        'before
        "Incorrect use of before macro.  Correct format is (before before-expr expr1 expr2 ...)"
        'before
        '(error ...)))))

  (define-syntax after
    (syntax-rules ()
      ((_ expr1 expr2 ... after-e)
       (dynamic-wind
           (lambda ()
             (void))
           (lambda ()
             expr1 expr2 ...)
           (lambda ()
             after-e)))
       ((after error ...)
        (raise-syntax-error
        'before
        "Incorrect use of after macro.  Correct format is (after expr1 expr2 ... after-expr)"
        'after
        '(error ...)))))

  (define-syntax around
    (syntax-rules ()
      ((_ before-e expr1 expr2 ... after-e)
       (dynamic-wind
           (lambda ()
             before-e)
           (lambda ()
             expr1 expr2 ...)
           (lambda ()
             after-e)))
      ((around error ...)
        (raise-syntax-error
        'around
        "Incorrect use of around macro.  Correct format is (around before-expr expr1 expr2 ... after-expr)"
        'around
        '(error ...)))))

  (define-syntax (define-shortcut stx)
    (syntax-case stx ()
      [(_ (name param ...) expr)
       (with-syntax ([expected-form (syntax-object->datum
                                     #`(#,(syntax name)
                                        test-desc
                                        #,@(syntax (param ...))))])
         (syntax/loc stx
           (define-syntax (name name-stx)
             (syntax-case name-stx ()
               [(name test-desc param ...)
                (with-syntax ([name-expr (syntax/loc name-stx expr)])
                  (syntax/loc name-stx
                    (test-case test-desc name-expr)))]
               [_
                (raise-syntax-error
                 #f
                 (format "Correct form is ~a" (quote expected-form))
                 name-stx)]))))]
      [_
       (raise-syntax-error
        #f
        "Correct form is (define-shortcut (name param ...) expr)"
        stx)]))

  (define-shortcut (test-check operator expr1 expr2)
    (check operator expr1 expr2))
  
  (define-shortcut (test-pred pred expr)
    (check-pred pred expr))

  (define-shortcut (test-equal? expr1 expr2)
    (check-equal? expr1 expr2))

  (define-shortcut (test-eq? expr1 expr2)
    (check-eq? expr1 expr2))

  (define-shortcut (test-eqv? expr1 expr2)
    (check-eqv? expr1 expr2))

  (define-shortcut (test-= expr1 expr2 epsilon)
    (check-= expr1 expr2 epsilon))
  
  (define-shortcut (test-true expr)
    (check-true expr))

  (define-shortcut (test-false expr)
    (check-false expr))

  (define-shortcut (test-not-false expr)
    (check-not-false expr))

  (define-shortcut (test-exn pred thunk)
    (check-exn pred thunk))

  (define-shortcut (test-not-exn thunk)
    (check-not-exn thunk))
  )