timeout-testsuite.rkt

#lang racket

(require
 racket/engine
 rackunit
 rackunit/text-ui)

(define current-test-timeout (make-parameter 3000))
(struct exn:fail:timeout (exn:fail))

(define (setup-test-timeouts!)
  (let ([cua (current-check-around)]
        [ctca (current-test-case-around)])
    (begin
      (current-check-around
       (lambda (th)
         (let ([e (engine th)])
           (if (engine-run (current-test-timeout) e)
               (engine-result e)
               (raise (exn:fail:timeout "Test timed out" (current-continuation-marks)))))))
      (current-test-case-around
       (lambda (th)
         (let ([e (engine th)])
           (if (engine-run (current-test-timeout) e)
               (engine-result e)
               (raise (exn:fail:timeout "Test timed out" (current-continuation-marks))))))))))

(run-tests
 (test-suite
  "loop tests"

  #:before
  (thunk
   (setup-test-timeouts!))

  (test-exn
   ""
   exn:fail:timeout?
   (thunk
    (let loop () (loop))))))