~ chicken-core (chicken-5) /tests/test.scm

  1;;;; test.scm - minimal testing framework
  2;
  3; by Alex Shinn, lifted from match-test by felix
  4
  5(import (only chicken.string ->string))
  6(import (only chicken.time current-process-milliseconds))
  7
  8(define *current-group-name* "")
  9(define *pass* 0)
 10(define *fail* 0)
 11(define *start* 0)
 12(define *total-pass* 0)
 13(define *total-fail* 0)
 14(define *total-start* 0)
 15(define *fail-token* (gensym))
 16
 17(define (run-test name thunk expect eq pass-msg fail-msg)
 18  (let ((result (thunk)))
 19    (cond
 20      ((eq expect result)
 21       (set! *pass* (+ *pass* 1))
 22       (format-result pass-msg name expect result))
 23      (else
 24       (set! *fail* (+ *fail* 1))
 25       (format-result fail-msg name expect result)))))
 26
 27(define (format-result ls name expect result)
 28  (let lp ((ls ls))
 29    (cond
 30      ((null? ls) (newline))
 31      ((eq? (car ls) 'expect) (write expect) (lp (cdr ls)))
 32      ((eq? (car ls) 'result) (write result) (lp (cdr ls)))
 33      ((eq? (car ls) 'name) (if name (begin (display #\space) (display name))) (lp (cdr ls)))
 34      (else (display (car ls)) (lp (cdr ls))))))
 35
 36(define (test-begin . o)
 37  (set! *current-group-name* (if (null? o) "<unnamed>" (car o)))
 38  (print "== " *current-group-name* " ==")
 39  (set! *total-pass* (+ *total-pass* *pass*))
 40  (set! *total-fail* (+ *total-fail* *fail*))
 41  (set! *pass* 0)
 42  (set! *fail* 0)
 43  (set! *start* (current-process-milliseconds))
 44  (when (= 0 *total-start*)
 45    (set! *total-start* (current-process-milliseconds))))
 46
 47(define (format-float n prec)
 48  (let* ((str (number->string n))
 49         (len (string-length str)))
 50    (let lp ((i (- len 1)))
 51      (cond
 52        ((negative? i)
 53         (string-append str "." (make-string prec #\0)))
 54        ((eqv? #\. (string-ref str i))
 55         (let ((diff (+ 1 (- prec (- len i)))))
 56           (cond
 57             ((positive? diff)
 58              (string-append str (make-string diff #\0)))
 59             ((negative? diff)
 60              (substring str 0 (+ i prec 1)))
 61             (else
 62              str))))
 63        (else
 64         (lp (- i 1)))))))
 65
 66(define (format-percent num denom)
 67  (let ((x (if (zero? denom) num (exact->inexact (/ num denom)))))
 68    (format-float (* 100 x) 2)))
 69
 70(define (test-end . o)
 71  (let ((end (current-process-milliseconds))
 72        (total (+ *pass* *fail*)))
 73    (print "  " total " tests completed in "
 74	   (format-float (exact->inexact (/ (- end *start*) 1000)) 3)
 75	   " seconds")
 76    (print "  " *pass* " ("
 77	   (format-percent *pass* total)
 78	   "%) tests passed")
 79    (print "  " *fail* " ("
 80	   (format-percent *fail* total)
 81	   "%) tests failed"))
 82    (print "-- " *current-group-name* " --\n\n"))
 83
 84(define (test-exit . o)
 85  (print " TOTALS: ")
 86  (set! *total-pass* (+ *total-pass* *pass*)) ; should be 0
 87  (set! *total-fail* (+ *total-fail* *fail*)) ; should be 0
 88  (let ((end (current-process-milliseconds))
 89        (total (+ *total-pass* *total-fail*)))
 90    (print "  " total " tests completed in "
 91	   (format-float (exact->inexact (/ (- end *total-start*) 1000)) 3)
 92	   " seconds")
 93    (print "  " *total-pass* " ("
 94	   (format-percent *total-pass* total)
 95	   "%) tests passed")
 96    (print "  " *total-fail* " ("
 97	   (format-percent *total-fail* total)
 98	   "%) tests failed")
 99    (exit (if (zero? *total-fail*) 0 1))))
100
101(define (run-equal name thunk expect eq)
102  (run-test name thunk expect eq
103            '("(PASS)" name)
104            '("(FAIL)" name ": expected " expect " but got " result)))
105
106(define current-test-epsilon (make-parameter 1e-5))
107
108(define (approx-equal? a b epsilon)
109  (cond
110   ((> (abs a) (abs b)) (approx-equal? b a epsilon))
111   ((zero? a) (< (abs b) epsilon))
112   (else (< (abs (/ (- a b) b)) epsilon))))
113
114(define (test-equal? expect res)
115  (or (equal? expect res)
116      (and (number? expect)
117           (inexact? expect)
118           (inexact? res)
119           (approx-equal? expect res (current-test-epsilon)))))
120
121(define current-test-comparator (make-parameter test-equal?))
122
123(define-syntax test-equal
124  (syntax-rules ()
125    ((_ name expr value eq) (run-equal name (lambda () expr) value eq))
126    ((_ name expr value) (run-equal name (lambda () expr) value (current-test-comparator)))
127    ((_ expr value) (run-equal (->string 'expr) (lambda () expr) value (current-test-comparator)))))
128
129(define-syntax test-error
130  (syntax-rules ()
131    ((_ name expr)
132     (run-equal
133      name
134      (lambda () (handle-exceptions ex *fail-token* expr))
135      *fail-token* eq?) )
136    ((_ expr) (test-error 'expr expr))))
137
138(define-syntax test-assert
139  (syntax-rules ()
140    ((_ name expr) (run-equal name (lambda () (if expr #t #f)) #t eq?))
141    ((_ expr) (run-equal (->string expr) (lambda () (if expr #t #f)) #t eq?))))
142
143(define-syntax test-group
144  (syntax-rules ()
145    ((_ name body ...)
146     (begin
147       (print "\n" name ":\n")
148       body ...))))