The (aux unittest) module

Bootstrapping a unittest framework

 Posted on February 5, 2026  (Last modified on February 11, 2026)  |   8 min  |   Massimo Nocentini

This test suite drove the implementation of the unittest framework itself.

(module
  (aux unittest)
  *
  (import
    scheme
    (scheme case-lambda)
    (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-guard result testcase-name witness thunk)
    (condition-case
      (thunk)
      (c (exn unittest-assert-equal)
         (unittest/result-failed!
           result
           (cons testcase-name
                 (get-condition-property
                   c
                   'unittest-assert-equal
                   'comparison)))
         witness)
      (c (exn)
         (unittest/result-failed!
           result
           (list testcase-name
                 (call-with-output-string
                   (lambda (port) (print-error-message c port)))))
         witness)
      (c () (unittest/result-failed! result (list testcase-name c)) witness)))
  (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))
           (witness (gensym))
           (guarded
             (lambda (thunk)
               (unittest/testcase-guard result testcase-name witness thunk))))
      (unittest/result-started! result)
      (let ((args (if setup
                    (guarded
                      (lambda ()
                        (call-with-values
                          (lambda () ((car setup) testcase))
                          list)))
                    '())))
        (let-values
          (((f code) (apply values (alist-ref testcase-name methods))))
          (let* ((v witness)
                 (eta-time 0)
                 (outstr "")
                 (errstr
                   (if (eq? args witness)
                     ""
                     (with-error-output-to-string
                       (lambda ()
                         (set! outstr
                           (with-output-to-string
                             (lambda ()
                               (let-values
                                 (((u s) (cpu-time)))
                                 (set! v
                                   (guarded (lambda () (apply f testcase args))))
                                 (let-values
                                   (((uu ss) (cpu-time)))
                                   (set! eta-time (- (+ uu ss) (+ u s))))))))))))
                 (hasdoc (and (pair? v) (eq? (car v) 'doc)))
                 (torn (cond ((or (not teardown) (eq? args witness)) (void))
                             ((eq? v witness)
                              (condition-case
                                (apply (car teardown) testcase args)
                                (c ()
                                   (set! errstr
                                     (string-append
                                       errstr
                                       (call-with-output-string
                                         (lambda (port) (print-error-message c port)))))
                                   witness)))
                             (else
                              (guarded
                                (lambda () (apply (car teardown) testcase args)))))))
            (let ((header-id (symbol->string testcase-name)))
              `((h2 (@ (id ,header-id))
                    (a (@ (href ,(string-append "#" header-id)))
                       (code ,header-id)
                       ": "
                       ,(if (or (eq? v witness) (eq? torn 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 (unittest/suite sut)
    (let loop ((names (map car (cdr sut))))
      (cond ((null? names) sut)
            ((memq (car names) (cdr names))
             (error 'define-suite
                    "duplicate test case name"
                    (car sut)
                    (car names)))
            (else (loop (cdr names))))))
  (define-syntax
    define-suite
    (syntax-rules
      ()
      ((_ sutname ((casename formal ...) body ...) ...)
       (define sutname
         (unittest/suite
           `(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))
                         (or (= a b) (< (abs (- a b)) p)))
                        ((and (pair? a) (pair? b))
                         (and (? (car a) (car b)) (? (cdr a) (cdr b))))
                        ((and (vector? a) (vector? b))
                         (and (= (vector-length a) (vector-length b))
                              (every ? (vector->list a) (vector->list 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)
        (unless
          (null? (unittest/result-failed r))
          (implicit-exit-handler (lambda () (exit 1))))
        r)))
  (define unittest/condition-expected-actual
    (case-lambda
      ((a b)
       (condition
         `(exn message "assert-equal failed")
         `(unittest-assert-equal comparison ((expected ,a) (got ,b)))))
      (args (condition
              `(exn message "assert failed")
              `(unittest-assert-equal comparison ((got ,@args)))))))
  (define-syntax
    ⊦⧳
    (syntax-rules
      ()
      ((_ ((exn ...) ...) body ...)
       (condition-case (begin body ...) ((exn ...) (void)) ...))))
  (define-syntax
    ⊦raises
    (syntax-rules
      ()
      ((_ (kind ...) body ...)
       (⊦= 'raised
           (condition-case
             (begin body ... 'not-raised)
             ((kind ...) 'raised)))))))

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.004) (memory #(12582912 2155096 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.003) (memory #(12582912 2156592 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.002) (memory #(12582912 2157976 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.002) (memory #(12582912 2159296 1048576)) (stdout "") (stderr ""))

test-raising-setup: pass

(define (test-raising-setup tc _ r)
  (lettest
    ((t 'test-method))
    (unittest/testcase-run t r raising-setup-sut)
    (⊦= '() (unittest/testcase-log t))
    (⊦= '((ran 1) (failed 1 (test-method "\nError: setup exploded\n")))
        (unittest/result-summary r))))

((eta 0.002) (memory #(12582912 2160264 1048576)) (stdout "") (stderr ""))

test-raising-setup-suite: pass

(define (test-raising-setup-suite tc _ r)
  (letsuite
    ((suite '(test-method test-other)))
    (unittest/testsuite-run suite r raising-setup-sut)
    (⊦= '((ran 2)
          (failed
            2
            (test-other "\nError: setup exploded\n")
            (test-method "\nError: setup exploded\n")))
        (unittest/result-summary r))))

((eta 0.003) (memory #(12582912 2161712 1048576)) (stdout "") (stderr ""))

test-raising-teardown-after-failure: pass

(define (test-raising-teardown-after-failure tc _ r)
  (lettest
    ((t 'test-broken))
    (let ((report
            (cadr (car (reverse
                         (unittest/testcase-run t r raising-teardown-sut))))))
      (⊦= '("\nError: teardown exploded\n") (alist-ref 'stderr report))
      (⊦= '((ran 1) (failed 1 (test-broken (expected 1) (got 2))))
          (unittest/result-summary r)))))

((eta 0.002) (memory #(12582912 2163376 1048576)) (stdout "") (stderr ""))

test-raising-teardown: pass

(define (test-raising-teardown tc _ r)
  (lettest
    ((t 'test-method))
    (unittest/testcase-run t r raising-teardown-sut)
    (⊦= '(test-method) (unittest/testcase-log t))
    (⊦= '((ran 1) (failed 1 (test-method "\nError: teardown exploded\n")))
        (unittest/result-summary r))))

((eta 0.001) (memory #(12582912 2164312 1048576)) (stdout "") (stderr ""))

test-duplicate-case-name: pass

(define (test-duplicate-case-name tc _ _)
  (⊦= '("duplicate test case name" (dup-sut t1))
      (condition-case
        (let ()
          (define-suite
            dup-sut
            ((t1 _) (⊦= 1 1))
            ((t2 _) (⊦= 1 1))
            ((t1 _) (⊦= 1 2)))
          dup-sut)
        (c (exn)
           (list (get-condition-property c 'exn 'message)
                 (get-condition-property c 'exn 'arguments))))))

((eta 0.0) (memory #(12582912 2168544 1048576)) (stdout "") (stderr ""))

test-exit-status: pass

(define (test-exit-status tc _ _)
  (⊦= 0 (suite-exit-status "(⊦= 1 1)"))
  (⊦= 1 (suite-exit-status "(⊦= 1 2)")))

((eta 0.001) (memory #(12582912 2166136 1048576)) (stdout "") (stderr ""))

test-failed-output: pass

(define (test-failed-output tc _ r)
  (lettest
    ((t 'test-printing-broken))
    (let ((report (cadr (last (unittest/testcase-run t r wasrun-sut)))))
      (⊦= '("printed before failing\n") (alist-ref 'stdout report))
      (⊦= '("warned before failing") (alist-ref 'stderr report))
      (⊦= '((ran 1) (failed 1 (test-printing-broken (expected 1) (got 2))))
          (unittest/result-summary r)))))

((eta 0.002) (memory #(12582912 2167400 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 #(12582912 2168776 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.008) (memory #(12582912 2169800 1048576)) (stdout "") (stderr ""))

test-⊦=-infinities: pass

(define (test-⊦=-infinities tc _ _)
  (⊦= +inf.0 +inf.0)
  (⊦= -inf.0 -inf.0)
  (⊦= '(1 +inf.0) (list 1.0000001 +inf.0))
  (⊭ ((equal-approx? 1e-06) +inf.0 -inf.0))
  (⊭ ((equal-approx? 1e-06) +inf.0 1e+300))
  (⊭ ((equal-approx? 1e-06) +nan.0 +nan.0)))

((eta 0.0) (memory #(12582912 2169976 1048576)) (stdout "") (stderr ""))

test-⊦=-vectors: pass

(define (test-⊦=-vectors tc _ _)
  (⊦= (vector 1.0000000001 '(2.0000000001 #(3.0000000001)))
      (vector 1 '(2 #(3))))
  (⊦= #() #())
  (⊭ ((equal-approx? 1e-06) #(1 2) #(1)))
  (⊭ ((equal-approx? 1e-06) #(1.1) #(1)))
  (⊭ ((equal-approx? 1e-06) #(1) '(1))))

((eta 0.0) (memory #(12582912 2171136 1048576)) (stdout "") (stderr ""))

test-⊦-arity: pass

(define (test-⊦-arity tc _ _)
  (⊦= '(((got 4)) ((got 1 2 3 1)) ((got)))
      (map (lambda (thunk)
             (condition-case
               (thunk)
               (c (exn unittest-assert-equal)
                  (get-condition-property
                    c
                    'unittest-assert-equal
                    'comparison))))
           (list (lambda () (⊦ odd? 4))
                 (lambda () (⊦ < 1 2 3 1))
                 (lambda () (⊦ (lambda () #f)))))))

((eta 0.0) (memory #(12582912 2176232 1048576)) (stdout "") (stderr ""))

test-⊨: pass

(define (test-⊨ tc _ _) (⊨ #t))

((eta 0.0) (memory #(12582912 2177024 1048576)) (stdout "") (stderr ""))

test-⊭: pass

(define (test-⊭ tc _ _) (⊭ #f))

((eta 0.0) (memory #(12582912 2178424 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.0) (memory #(12582912 2178976 1048576)) (stdout "") (stderr ""))

test-should-raise: pass

(define (test-should-raise tc _ _)
  (⊦raises (exn) (car '()))
  (⊦raises (exn-a) (signal (condition '(exn-a message "useless"))))
  (⊦= '((expected raised) (got not-raised))
      (condition-case
        (⊦raises (exn) 99)
        (c (unittest-assert-equal)
           (get-condition-property c 'unittest-assert-equal 'comparison))))
  (⊦= 'escaped
      (condition-case
        (⊦raises (exn) (signal (condition '(exn-a message "useless"))))
        ((exn-a) 'escaped))))

((eta 0.0) (memory #(12582912 2180024 1048576)) (stdout "") (stderr ""))
Categories: scheme 

See also

The (aux anthropic) module The Anthropic Messages API, offline The (aux cml) module Events, threads, synchronous variables, the library and I/O The (aux hakaru10) modules Random sources, distributions, the language, exact inference and examples The (aux kanren) modules Arithmetic, dates, presentation of answers and a union-find miniKanren The (aux games dice-of-doom) module Dice of Doom The (aux machine) modules Environments, the SC machine and the SECD machine The (aux schemer seasoned) module The Seasoned Schemer The (aux continuation) modules Classic operators, escapers, amb and Collatz sequences The (aux category) modules Monads: list, maybe, probability, ziplist, difference lists and state The (aux timsort) module Sorting and the trace buffer The (aux fds) modules Functional queues and union-find The (aux sxml) module Rendering SXML to HTML The (aux variable) module Logic variables introduced by fresh The (aux tabling) module Memoization and tabled definitions The (aux commons) module Learning tests for CHICKEN Scheme Promises delay and make-promise The Ackermann function On unary numbers, as lists Concurrent ML for CHICKEN Scheme Porting SML/NJ CML as the (aux cml) library 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) modules Inference, random sources, lazy lists, logic programming and example models The (aux nondeterministic) module Learning tests for Scheme The (aux stream) modules Streams, streams after SICP, and sequences and power series 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