(define-library (csc testing)
  (export
    assert
    assert-equal
    assert-raises
    test
    test-main)
  (import (scheme base)
          (only (scheme write)
            display
            write)
          (only (csc compare) diff))
  (begin


    (define *all-tests-succeeded* #t)


    (define (set-all-succeeded! val) (set! *all-tests-succeeded* val))


    (define-record-type <test-handle>
      (make-test-handle test-name)
      test-handle?
      (test-name test-name set-name!))


    (define-record-type <test-error>
      (make-test-error)
      test-error?)


    (define *test-error* (make-test-error))


    (define *test-handle* (make-test-handle "global"))


    (define (print . xs)
      (unless (null? xs)
        (let ((x (car xs)))
          (if (or (string? x)
                  (symbol? x))
            (display x)
            (write x)))
        (apply print (cdr xs))))


    (define-syntax test
      (syntax-rules ()
        ((test name body body* ...)
         (begin
           (set-name! *test-handle* (symbol->string 'name))
           (print "=== RUN   " 'name "\n")
           (guard (e ((test-error? e)
                       (print "--- FAIL: " 'name "\n")
                       (set-all-succeeded! #f)))
             body body* ...
             (print "--- PASS: " 'name "\n"))))))


    (define-syntax assert
      (syntax-rules ()
        ((assert expr)
         (unless expr
           (print (test-name *test-handle*) ": (assert " 'expr ") failed.\n")
           (raise *test-error*)))))


    (define-syntax assert-equal
      (syntax-rules ()
        ((assert-equal left right transformers ...)
          (let ((d (diff left right transformers ...)))
            (unless (string=? "" d)
              (print "Fatal:\n  " 'left "\nis not equal to\n  " 'right "\ndiff (-left +right):\n" d "\n")
              (raise *test-error*))))))


    (define-syntax assert-raises
      (syntax-rules ()
        ((assert-raises predicate body body* ...)
          (assert
            (guard (e ((predicate e) #t))
              body body* ...
              #f)))))


    (define (test-main)
      (if *all-tests-succeeded*
        (print "PASS\n")
        (print "FAIL\n")))))