;;!
;; Exports all the main functions of the test framework and provides
;; several utility functions to make it easier to create tests.
(module test mzscheme
  
  (require "keyword.ss"
           (all-except
            "schemeunit.ss"
            make-test-case
            make-test-suite)
           (rename
            "schemeunit.ss"
            raw:make-test-case make-test-case)
           (rename
            "schemeunit.ss"
            raw:make-test-suite make-test-suite)
           "assert.ss")

  (require-for-syntax "keyword.ss")
  
  (provide (all-from "assert.ss")
           make-test-case
           make-test-suite
           (all-from-except "schemeunit.ss" raw:make-test-case raw:make-test-suite))

  (define void-thunk (lambda () (void)))
  
  ;;!
  ;; macro make-test-case : expr ... [setup thunk] [teardown thunk]
  ;;                          -> test-case
  (define-syntax (make-test-case stx)
    (syntax-case stx ()
      [(_ name . exprs)
       (let ((sexp (syntax-object->datum (syntax exprs))))
         (with-syntax
             ((setup
               (datum->syntax-object
                stx
                (get-keyword-arg 'setup sexp '(void))
                stx))
              (teardown
               (datum->syntax-object
                stx
                (get-keyword-arg 'teardown sexp '(void))
                stx))
              (actions
               (datum->syntax-object
                stx
                `(lambda ()
                   ,@(get-positional-args '(setup teardown) sexp '((void))))
                stx)))
           (syntax
            (raw:make-test-case
             name
             actions
             (lambda () setup)
             (lambda () teardown)))))]))
  
  ;;!
  ;; make-test-suite : name test ... ['setup thunk] ['teardown thunk]
  ;;                     -> 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 symbol setup or
  ;; teardown.
  (define (make-test-suite name . tests)
    (let ((setup (get-keyword-arg 'setup tests void-thunk))
          (teardown (get-keyword-arg 'teardown tests void-thunk))
          (rest (get-positional-args '(setup teardown) tests)))
      (raw:make-test-suite name rest setup teardown)))

  )