2014-07-20 04:24:03 -04:00
|
|
|
|
(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
|
|
|
|
|
2014-07-20 04:24:03 -04:00
|
|
|
|
(define test-counter 0)
|
|
|
|
|
(define counter 0)
|
|
|
|
|
(define failure-counter 0)
|
|
|
|
|
|
|
|
|
|
(define fails '())
|
|
|
|
|
|
|
|
|
|
(define (print-statistics)
|
|
|
|
|
(newline)
|
|
|
|
|
(display "[0;34mTest Result: ")
|
|
|
|
|
(write (- counter failure-counter))
|
|
|
|
|
(display " / ")
|
|
|
|
|
(write counter)
|
|
|
|
|
(display " (")
|
|
|
|
|
(write (* (/ (- counter failure-counter) counter) 100))
|
|
|
|
|
(display "%)")
|
|
|
|
|
(display " [PASS/TOTAL]")
|
|
|
|
|
(display "[0;39m")
|
|
|
|
|
(newline)
|
|
|
|
|
(for-each
|
|
|
|
|
(lambda (fail)
|
|
|
|
|
(display fail))
|
2014-07-26 23:42:14 -04:00
|
|
|
|
(reverse fails)))
|
2014-07-20 04:24:03 -04:00
|
|
|
|
|
|
|
|
|
(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)
|
2015-07-21 02:12:43 -04:00
|
|
|
|
(if (equal? res expected)
|
|
|
|
|
(begin
|
|
|
|
|
(display "[0;32m PASS: ")
|
|
|
|
|
(write 'expr)
|
|
|
|
|
(display " equals ")
|
|
|
|
|
(write expected)
|
|
|
|
|
(display "[0;39m")
|
|
|
|
|
(newline))
|
|
|
|
|
(begin
|
|
|
|
|
(set! failure-counter (+ failure-counter 1))
|
|
|
|
|
(let ((out (open-output-string)))
|
|
|
|
|
(display " [0;31mFAIL: " out)
|
|
|
|
|
(write 'expr out)
|
|
|
|
|
(newline out)
|
|
|
|
|
(display " expected " out)
|
|
|
|
|
(write expected out)
|
|
|
|
|
(display " but got " out)
|
|
|
|
|
(write res out)
|
|
|
|
|
(display "[0;39m" out)
|
|
|
|
|
(newline out)
|
|
|
|
|
(let ((str (get-output-string out)))
|
|
|
|
|
(set! fails (cons str fails))
|
|
|
|
|
(display str)))))
|
2014-07-20 04:24:03 -04:00
|
|
|
|
(set! counter (+ counter 1))))))
|
|
|
|
|
|
|
|
|
|
(define-syntax test-values
|
|
|
|
|
(syntax-rules ()
|
|
|
|
|
((_ expect expr)
|
2014-07-21 09:56:53 -04:00
|
|
|
|
(test (call-with-values (lambda () expect) (lambda results results))
|
2014-07-20 04:24:03 -04:00
|
|
|
|
(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"))))
|
|
|
|
|
|
2015-01-17 10:32:52 -05:00
|
|
|
|
(export test test-begin test-end test-values test-syntax-error))
|