This test suite drove the implementation of the unittest framework itself.
(module
(aux unittest)
*
(import
scheme
(chicken base)
(chicken condition)
(chicken pretty-print)
(chicken port)
(chicken string)
(chicken syntax)
(chicken flonum)
(chicken time)
(chicken gc)
srfi-1
srfi-19
(aux sxml))
(define-record unittest/testcase name log)
(define (unittest/wasrun name) (make-unittest/testcase name '()))
(define (unittest/testcase-logcons! testcase msg)
(unittest/testcase-log-set!
testcase
(cons msg (unittest/testcase-log testcase))))
(define (unittest/testcase-run testcase result sut)
(let* ((methods (cdr sut))
(setup (alist-ref 'setup methods))
(teardown (alist-ref 'teardown methods))
(testcase-name (unittest/testcase-name testcase)))
(unittest/result-started! result)
(let-values
((args (if setup ((car setup) testcase) (values)))
((f code) (apply values (alist-ref testcase-name methods))))
(let* ((witness (gensym))
(no-outsrt "")
(eta-time 0)
(pair (condition-case
(let* ((res (void))
(outstr no-outsrt)
(errstr
(with-error-output-to-string
(lambda ()
(set! outstr
(with-output-to-string
(lambda ()
(let-values
(((u s) (cpu-time)))
(set! res (apply f testcase args))
(let-values
(((uu ss) (cpu-time)))
(set! eta-time (- (+ uu ss) (+ u s))))))))))))
(list res outstr errstr))
(c (exn unittest-assert-equal)
(begin
(unittest/result-failed!
result
(cons testcase-name
(get-condition-property
c
'unittest-assert-equal
'comparison)))
(list witness no-outsrt no-outsrt)))
(c (exn)
(begin
(unittest/result-failed!
result
(list testcase-name
(call-with-output-string
(lambda (port) (print-error-message c port)))))
(list witness no-outsrt no-outsrt)))
(c ()
(begin
(unittest/result-failed!
result
(list testcase-name c))
(list witness no-outsrt no-outsrt)))))
(v (first pair))
(outstr (second pair))
(errstr (third pair))
(hasdoc (and (pair? v) (eq? (car v) 'doc))))
(when teardown (apply (car teardown) testcase args))
(let ((header-id (symbol->string testcase-name)))
`((h2 (@ (id ,header-id))
(a (@ (href ,(string-append "#" header-id)))
(code ,testcase-name)
": "
,(if (eq? v witness)
'(span (@ (class "w3-text-red")) fail)
'(span (@ (class "w3-text-green")) pass))))
,@(if hasdoc (cdr v) '())
(code/scheme ,(if hasdoc (butlast code) code))
(code/scheme
((eta ,(exact->inexact (/ eta-time 1000)))
(memory ,(memory-statistics))
(stdout ,outstr)
(stderr ,errstr)))))))))
(define-syntax
define-suite
(syntax-rules
()
((_ sutname ((casename formal ...) body ...) ...)
(define sutname
`(sutname
(casename
,(lambda (formal ...) body ...)
,'(define (casename formal ...) body ...))
...)))))
(define-syntax
lettest
(syntax-rules
()
((_ ((test nameexp) ...) body ...)
(let ((test (unittest/wasrun nameexp)) ...) body ...))))
(define-record unittest/result ran failed)
(define (unittest/result-summary result)
`((ran ,(unittest/result-ran result))
(failed
,(length (unittest/result-failed result))
,@(unittest/result-failed result))))
(define (unittest/result-started! result)
(unittest/result-ran-set! result (add1 (unittest/result-ran result))))
(define (unittest/result-failed! result exn)
(unittest/result-failed-set!
result
(cons exn (unittest/result-failed result))))
(define (equal-approx? p)
(letrec ((? (lambda (a b)
(cond ((and (real? a) (real? b)) (< (abs (- a b)) p))
((and (pair? a) (pair? b))
(and (? (car a) (car b)) (? (cdr a) (cdr b))))
(else (equal=? a b))))))
?))
(define (⊦ pred? . args)
(unless
(apply pred? args)
(signal (apply unittest/condition-expected-actual args))))
(define (⊦= a b) (⊦ (equal-approx? 1e-06) a b))
(define (⊦≠ a b) (⊦ (complement equal?) a b))
(define (⊨ a) (⊦= #t a))
(define (⊭ a) (⊦= #f a))
(define-syntax
letsuite
(syntax-rules
()
((_ ((name '(method ...)) ...) body ...)
(letrec ((name (lettest ((method 'method) ...) (list method ...))) ...)
body
...))))
(define (unittest/testsuite-run suite r sut)
(map (lambda (testcase) (unittest/testcase-run testcase r sut)) suite))
(define (unittest/✓ sut)
(let* ((r (make-unittest/result 0 '()))
(sut-name (car sut))
(sut-methods (cdr sut))
(F (lambda (x)
(let ((name (car x)))
(and (not (eq? name 'setup))
(not (eq? name 'teardown))
(not (eq? name 'doc))))))
(methods (filter F sut-methods))
(s (map (lambda (pair) (lettest ((t (car pair))) t)) methods)))
(let ((docs (unittest/testsuite-run s r sut))
(res (unittest/result-summary r))
(sxml (alist-ref 'doc sut-methods)))
(SXML->HTML->file!
(sxml-tree sut-name `(,@(if sxml ((car sxml) r) '()) ,@docs))
(symbol-append 'testsuite- sut-name))
(pretty-print res)
r)))
(define (unittest/condition-expected-actual a b)
(condition
`(exn message "assert-equal failed")
`(unittest-assert-equal comparison ((expected ,a) (got ,b)))))
(define-syntax
⊦⧳
(syntax-rules
()
((_ ((exn ...) ...) body ...)
(condition-case (begin body ...) ((exn ...) (void)) ...)))))
test-running: pass
hello
(define (test-running tc t r)
(⊦= '() (unittest/testcase-log t))
(unittest/testcase-run t r wasrun-sut)
(⊦= '(teardown test-method setup) (unittest/testcase-log t)))
((eta 0.005) (memory #(6291456 1770736 1048576)) (stdout "") (stderr ""))
test-result: pass
(define (test-result tc t r)
(unittest/testcase-run t r wasrun-sut)
(⊦= '((ran 1) (failed 0)) (unittest/result-summary r)))
((eta 0.002) (memory #(6291456 1772056 1048576)) (stdout "") (stderr ""))
test-failed: pass
(define (test-failed tc _ r)
(lettest
((t 'test-broken))
(unittest/testcase-run t r wasrun-sut)
(⊦= '((ran 1) (failed 1 (test-broken (expected useless) (got _))))
(unittest/result-summary r))))
((eta 0.003) (memory #(6291456 1773264 1048576)) (stdout "") (stderr ""))
test-unbound-variable: pass
(define (test-unbound-variable tc _ r)
(lettest
((t 'test-unbound-variable))
(unittest/testcase-run t r wasrun-sut)
(⊦= '((ran 1)
(failed
1
(test-unbound-variable
"\nError: unbound variable: unbound-v\n")))
(unittest/result-summary r))))
((eta 0.005) (memory #(6291456 1774368 1048576)) (stdout "") (stderr ""))
test-failed-result: pass
(define (test-failed-result tc _ r)
(unittest/result-started! r)
(unittest/result-failed! r 'no-reason)
(⊦= '((ran 1) (failed 1 no-reason)) (unittest/result-summary r)))
((eta 0.0) (memory #(6291456 1775008 1048576)) (stdout "") (stderr ""))
test-suite: pass
(define (test-suite tc _ r)
(letsuite
((suite '(test-running test-failed)))
(unittest/testsuite-run suite r bootstrap-sut)
(⊦= '((ran 2) (failed 0)) (unittest/result-summary r))))
((eta 0.006) (memory #(6291456 1776376 1048576)) (stdout "") (stderr ""))
test-⊨: pass
(define (test-⊨ tc _ _) (⊨ #t))
((eta 0.0) (memory #(6291456 1777376 1048576)) (stdout "") (stderr ""))
test-⊭: pass
(define (test-⊭ tc _ _) (⊭ #f))
((eta 0.0) (memory #(6291456 1778488 1048576)) (stdout "") (stderr ""))
test-should-signal: pass
(define (test-should-signal tc _ _)
(⊦⧳ ((exn)) (signal (condition '(exn message "useless"))))
(⊦⧳ ((exn-a)) (signal (condition '(exn-a message "useless"))))
(⊦⧳ ((exn) (exn-a)) (signal (condition '(exn-a message "useless"))))
(condition-case
(⊦⧳ ((exn)) (signal (condition '(exn-a message "useless"))))
((exn-a) (void)))
(condition-case (⊦⧳ ((exn)) (signal 99)) (() (void)))
(⊦⧳ () 99))
((eta 0.001) (memory #(6291456 1781424 1048576)) (stdout "") (stderr ""))
Categories: scheme
See also
CHICKEN Scheme
Versions and implementation notes
The SBRAL data structure
Skew Binary Random-Access Lists
Pattern matching
Scheme macrology: a generalized pattern matcher
The (aux hansei) module
The (aux nondeterministic) module
Learning tests for Scheme
The (aux stream) module
Scheme lang: Chez, 48 and Chicken
Some docs, refs and containers, respectively.
The Reasoned Schemer
miniKanren, microKanren and some implementations
Aggregation predicates for µkanren
Groups, window functions, sets and enumerations
miniKanren, live and untagged
Quine generation via relational interpreters
Pure, declarative, and constructive arithmetic relations
A declarative pearl
Final shift for call/cc
Direct implementation of shift and reset
Call with Current Continuation Patterns
Cogen in six lines
The Seasoned Schemer
The Little Schemer
Adding generic functions to Scheme
Handling control