(define %tests-passed 0)
(define (tests-passed) %tests-passed)
(define (increment-tests-passed! x)
  (set! %tests-passed (+ %tests-passed x)))

(define %tests-failed 0)
(define (tests-failed) %tests-failed)
(define (increment-tests-failed! x)
  (set! %tests-failed (+ %tests-failed x)))

(define test-group-name '())
(define (test-group+ name)
  (reverse (cons name test-group-name)))
(define verbose? #f)

(define (call-as-test thunk on-success on-failure on-ex)
  (let ((returned-value
         (call/cc
          (lambda (return)
            (with-exception-handler
                (lambda (ex) (return (on-ex ex)))
              thunk)))))
    (if returned-value
        (on-success returned-value)
        (on-failure returned-value))))

(define (call-as-test-assert name thunk)
  (call-as-test thunk
                (lambda (x)
                  (increment-tests-passed! 1))
                (lambda (x)
                  (display (list (test-group+ name) 'failed))
                  (newline)
                  (increment-tests-failed! 1))
                (lambda (ex)
                  (display (list (test-group+ name) 'exception ex))
                  (newline)
                  #f)))

(define-syntax test-assert
  (syntax-rules ()
    ((_ expr) (test-assert "test" expr))
    ((_ name expr) (call-as-test-assert name (lambda () expr)))))

(define (call-as-test-equal name predicate? expected actual)
  (call-as-test (lambda () (predicate? expected actual))
                (lambda (x)
                  (increment-tests-passed! 1))
                (lambda (x)
                  (display (list (test-group+ name) expected '!= actual))
                  (newline)
                  (increment-tests-failed! 1))
                (lambda (ex)
                  (display (list (test-group+ name) 'exception ex))
                  (newline)
                  #f)))

(define-syntax test-equal
  (syntax-rules ()
    ((_ expected actual)
     (test-equal "equal?" expected actual))
    ((_ name expected actual)
     (call-as-test-equal name equal? expected actual))))

(define-syntax test-eqv
  (syntax-rules ()
    ((_ expected actual) (test-eqv "eqv?" expected actual))
    ((_ name expected actual)
     (call-as-test-equal name eqv? expected actual))))

(define-syntax test-eq
  (syntax-rules ()
    ((_ expected actual) (test-eq "eq?" expected actual))
    ((_ name expected actual)
     (call-as-test-equal name eq? expected actual))))

(define (call-as-test-exception name thunk predicate?)
  (let* ((raised? #f)
         (the-exception #f)
         (on-ex (lambda (obj)
                  (set! raised? #t)
                  (set! the-exception obj)
                  (cond
                    ((eq? predicate? #t) #t)
                    (else (predicate? obj))))))
    (call-as-test (lambda () (thunk) #f)
                  (lambda (x)
                    (increment-tests-passed! 1))
                  (lambda (_)
                    (if raised?
                        (display (list (test-group+ name) 'bad-exception
                                       the-exception))
                        (display (list (test-group+ name) 'no-exception)))
                    (newline)
                    (increment-tests-failed! 1))
                  on-ex)))

(define-syntax test-error
  (syntax-rules ()
    ((_ predicate? expr) (test-error "test-exception" predicate? expr))
    ((_ name predicate? expr)
     (call-as-test-exception name
                             (lambda () expr)
                             predicate?))))

(define-syntax test-group
  (syntax-rules ()
    ((_ name body ...)
     (let ((passed (tests-passed)) (failed (tests-failed)))
       (dynamic-wind
        (lambda ()
          (set! test-group-name (cons name test-group-name)))
        (lambda ()
          (when verbose?
            (display (list 'group name))
            (newline))
          (let () body ...)
          (when verbose?
            (let ((passed-in-group (- (tests-passed) passed))
                  (failed-in-group (- (tests-failed) failed)))
              (display (list 'group name
                             'passed passed-in-group
                             'failed failed-in-group))
              (newline))))
        (lambda ()
          (set! test-group-name (cdr test-group-name))))))))

(define (test-exit)
  (display (list 'passed (tests-passed)
                 'failed (tests-failed)))
  (newline)
  (exit (if (zero? (tests-failed)) 0 1)))