(define-library (csc testing)
  (export
    assert
    assert-equal
    assert-raises
    test
    test-main)
  (import (scheme base)
          (only (csc compare) diff)
          (only (csc format)
            printf
            sprintf))
  (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-handle* (make-test-handle "global"))


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


    (define (fatalf format-string . format-args)
      (printf "{}: {}\n" (test-name *test-handle*) (apply sprintf format-string format-args))
      (raise (make-test-error)))


    (define-syntax assert
      (syntax-rules ()
        ((assert expr)
         (unless expr
           (fatalf "(assert {}) failed." 'expr)))))


    (define-syntax assert-equal
      (syntax-rules ()
        ((assert-equal left right transformers ...)
          (let* ((x left)
                 (y right)
                 (d (diff x y transformers ...)))
            (unless (string=? "" d)
              (fatalf "Fatal:\n  {}\nis not equal to\n  {}.\nleft is\n  {}\nright is\n  {}\ndiff (-left +right):\n{}" 'left 'right x y d))))
        ((assert-equal left right)
          (assert-equal equal? left right))))


    (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*
          (printf "PASS\n")
        (printf "FAIL\n")))))