;;!
;; The core types and functions of the testing framework, before
;; adornment with syntatic sugar to make a nice interface.
(module schemeunit mzscheme
  
  (require "assert.ss"
           (lib "list.ss" "mzlib")
           (lib "plt-match.ss" "mzlib"))
  
  (provide (struct test-case (name action setup teardown))
           (struct test-suite (name tests setup teardown))
           (struct test-result (test-case-name))
           (struct test-failure (result))
           (struct test-error (result))
           (struct test-success (result))
           foldts
           fold-test-results
           run-test-case
           run-test)

  
  (define-struct test-result (test-case-name))
  (define-struct (test-failure test-result)  (result))
  (define-struct (test-error test-result) (result))
  (define-struct (test-success test-result) (result))
	 
  (define-struct test ())

  ;;!
  ;; struct test-case : string thunk thunk thunk
  (define-struct (test-case test) (name action setup teardown))

  ;;!
  ;; struct test-suite : string (list-of test) thunk thunk
  (define-struct (test-suite test) (name tests setup teardown))


  ;; foldts :
  ;;   (string thunk thunk 'a -> 'a)
  ;;   (string thunk thunk 'a 'a -> 'a)
  ;;   (string thunk thunk thunk 'a -> 'a)
  ;;   'a
  ;;   test
  ;;  ->
  ;;   'a
  ;;
  ;; Extended tree fold ala SSAX for tests
  (define (foldts fdown fup fhere seed test)
    (match test
      ((struct test-case (name action setup teardown))
       (fhere name action setup teardown seed))
      
      ((struct test-suite (name tests setup teardown))
       (let loop ((kid-seed (fdown name setup teardown seed))
                  (kids tests))
         (if (null? kids)
             (fup name setup teardown seed kid-seed)
             (loop (foldts fdown fup fhere kid-seed (car kids))
                   (cdr kids)))))))

             
  ;;!
  ;; fold-test-results: suite-fn result-fn cons-fn seed test
  ;; (type (((String 'a) -> 'a) (Test-Result -> 'a) 'a Test) -> 'a)
  ;;
  ;; Fold collector pre-order L-to-R depth-first over test
  ;; results.
  (define (fold-test-results suite-fn case-fn seed test)
    (foldts
     (lambda (name setup teardown seed)
       (setup)
       (suite-fn name seed))
     (lambda (name setup teardown seed kid-seed)
       (teardown)
       kid-seed)
     (lambda (name action setup teardown seed)
       (case-fn
        (run-test-case name action setup teardown)
        seed))
     seed
     test))

  ;;!
  ;; run-test-case : string thunk thunk thunk -> test-result
  (define (run-test-case name action setup teardown)
    (with-handlers
        ([exn:test:assertion?
          (lambda (exn)
            (make-test-failure name exn))]
         [(lambda _ #t)
          (lambda (exn)
            (make-test-error name exn))])
      (let ((value (begin (setup) (action) (teardown))))
        (make-test-success name value))))
  
  ;;!
  ;; (function (run-test test))
  ;; (type Test -> (listof Test-Result))
  ;;
  ;; Run test returning a tree of test-results.  Results are
  ;; ordered L-to-R as they occur in the tree.
  (define (run-test test)
    (reverse!
     (fold-test-results
      (lambda (name seed)
        seed)
      (lambda (result seed) (cons result seed))
      (list)
      test)))
  
  )