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