picrin/contrib/30.test/test.scm

83 lines
2.2 KiB
Scheme
Raw Normal View History

(define-library (picrin test)
2015-07-08 13:21:57 -04:00
(import (scheme base)
(scheme write))
2014-09-08 04:08:38 -04:00
(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))