;;!
;; 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")

  (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 form ...)
       (let loop ([forms (syntax->list #'(form ...))]
                  [setups null]
                  [teardowns null]
                  [exprs null])
         (cond [(pair? forms)
                (let ((form0 (car forms))
                      (forms (cdr forms)))
                  (syntax-case form0 (setup teardown)
                    [setup
                     (unless (pair? forms)
                       (raise-syntax-error 
                        'make-test-case 
                        "expected subsequent expression" 
                        form0))
                     (loop (cdr forms) (cons (car forms) setups) teardowns exprs)]
                    [teardown
                     (unless (pair? forms)
                       (raise-syntax-error
                        'make-test-case
                        "expected subsequent expression"
                        form0))
                     (loop (cdr forms) setups (cons (car forms) teardowns) exprs)]
                    [else
                     (loop forms setups teardowns (cons form0 exprs))]))]
               [else
                (with-syntax ([(setup ...) (reverse setups)]
                              [(teardown ...) (reverse teardowns)]
                              [(expr ...) (reverse exprs)])
                  (syntax/loc stx
                    (raw:make-test-case 
                     name
                     (lambda () (begin (void) expr ...))
                     (lambda () setup ... (void))
                     (lambda () teardown ... (void)))))]))]))
  
  ;;!
  ;; 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)))

  )