(define-library (csc testing)
  (export
    define-test
    errorf
    fatalf
    test-main
    subtest)
  (import (scheme base)
          (only (csc format)
                printf
                sprintf)
          (only (csc vec)
                vec
                vec-append
                vec-length
                vec-ref))
  (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 subtest-name succeeded subtests-succeeded)
      test-handle?
      (test-name base-test-name)
      (subtest-name subtest-name)
      (succeeded test-succeeded? set-succeeded!)
      (subtests-succeeded subtests-succeeded set-subtests-succeeded!))


    (define (test-name t)
      (let ((sn (subtest-name t)))
        (if (equal? sn "")
            (base-test-name t)
          (sprintf "{}/{}" (base-test-name t) sn))))


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


    (define-syntax define-test
      (syntax-rules ()
                    ((_ (name t) body ...)
                     (let ((t (make-test-handle (symbol->string 'name) "" #t (vec))))
                       (printf "=== RUN   {}\n" 'name)
                       (guard (e ((test-error? e))
                                 #;(else
                                 (errorf t "{}" e)))
                       body ...)
                     (if (test-succeeded? t)
                         (printf "--- PASS: {}\n" 'name)
                       (begin
                         (printf "--- FAIL: {}\n" 'name)
                         (set-all-succeeded! #f)))
                     (do ((i 0 (+ 1 i)))
                         ((>= i (vec-length (subtests-succeeded t))))
                       (printf "    --- {}: {}/{}\n"
                               (if (cdr (vec-ref (subtests-succeeded t) i)) "PASS" "FAIL")
                               'name
                               (car (vec-ref (subtests-succeeded t) i))))))))


  (define-syntax subtest
    (syntax-rules ()
                  ((_ t name body ...)
                   (let ((old-t t)
                         (t (make-test-handle (test-name t) name #t (vec))))
                     (printf "=== RUN   {}\n" (test-name t))
                     (guard (e ((test-error? e))
                               #;(else
                               (errorf t "{}" e)))
                     body ...)
                   (let ((succ (test-succeeded? t)))
                     (set-subtests-succeeded! old-t (vec-append (subtests-succeeded old-t) (cons name succ)))
                     (unless succ
                       (set-succeeded! old-t #f)))))))


    (define-syntax errorf
      (syntax-rules ()
                    ((_ t format-string format-args ...)
                     (begin
                       (set-succeeded! t #f)
                       (printf "{}: {}\n" (test-name t) (sprintf format-string format-args ...))))))


    (define-syntax fatalf
      (syntax-rules ()
                    ((_ t format-string format-args ...)
                     (begin
                       (errorf t format-string format-args ...)
                       (raise (make-test-error))))))


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