picrin/contrib/30.test/test.scm

(define-library (picrin test)
  (import (scheme base)
          (scheme write))

  (define test-counter 0)
  (define counter 0)
  (define failure-counter 0)

  (define fails '())

  (define (print-statistics)
    (newline)
    (display "Test Result: ")
    (write (- counter failure-counter))
    (display " / ")
    (write counter)
    (display " (")
    (write (* (/ (- counter failure-counter) counter) 100))
    (display "%)")
    (display " [PASS/TOTAL]")
    (display "")
    (newline)
    (for-each
     (lambda (fail)
       (display fail))
     (reverse fails)))

  (define (test-begin . o)
    (set! test-counter (+ test-counter 1)))

  (define (test-end . o)
    (set! test-counter (- test-counter 1))
    (if (= test-counter 0)
        (print-statistics)))

  (define-syntax test
    (syntax-rules ()
      ((test expected expr)
       (let ((res expr))
         (display "case ")
         (write counter)
         (cond
          ((equal? res expected)
           (display " PASS: ")
           (write 'expr)
           (display " equals ")
           (write expected)
           (display "")
           (newline)
           )
          ((not (equal? res expected))
           (set! failure-counter (+ failure-counter 1))
           (let ((out (open-output-string)))
             (display " FAIL: " out)
             (write 'expr out)
             (newline out)
             (display "   expected " out)
             (write expected out)
             (display " but got " out)
             (write res out)
             (display "" out)
             (newline out)
             (let ((str (get-output-string out)))
               (set! fails (cons str fails))
               (display str)))))
         (set! counter (+ counter 1))))))

  (define-syntax test-values
    (syntax-rules ()
      ((_ expect expr)
       (test (call-with-values (lambda () expect) (lambda results results))
             (call-with-values (lambda () expr) (lambda results results))))))


  (define (test-failure-count)
    (length fails))

  (define-syntax test-syntax-error
    (syntax-rules ()
      ((_) (syntax-error "invalid use of test-syntax-error"))))

  (export test test-begin test-end test-values test-syntax-error))