#lang scheme
(require scheme/sandbox)
(require scheme/path)

(define (ends-with? a b)
  (and (>= (string-length a) (string-length b))
       (equal? b (substring a (- (string-length a) (string-length b))))))

(define (test-name? path)
  (let ([ext (filename-extension path)])
    (cond 
      [(ends-with? (path->string path) "run-tests.scm") #f]
      [(false? ext) #f]
      [(equal? ext #"scm") #t]
      [(equal? ext #"ss") #t]
      [else #f])))

(sandbox-output (current-output-port))

(define (call-with-evaluator all-files proc)
  (let loop ([files all-files] [result null])
    (if (null? files) result
        (begin
          (let* ([file (car files)])
            (with-handlers ([exn:fail:contract:variable? (λ (e) (loop (cdr files) result))])
              (call-with-trusted-sandbox-configuration
               (λ ()
                 (let ([evaluator (make-module-evaluator file #:allow-read all-files)])
                   (proc file evaluator)
                   (loop (cdr files) (cons file result)))))))))))

(define (find-tests [files #f])
  (when (not files)
    (set! files (find-files test-name? (current-directory))))
  (let ([result 
         (call-with-evaluator 
          files
          (λ (file evaluator)
            (when (not (evaluator '(schemeunit-test-suite? tests)))
              (error (format "~s is not a test suite!" (evaluator 'tests))))))])
    (display (format "Found ~s test suite~a.~n" (length result) (if (= (length result) 1) "" "s")))
    result))

(define (run-tests [files #f])
  (when (not files) (set! files (find-tests)))
  (call-with-evaluator
   files
   (λ (file evaluator)
     (display (format "Running tests in ~a~n" file))
     (evaluator '(require (planet schematics/schemeunit/text-ui)))
     (evaluator '(run-tests tests 'verbose))))
  (void))

(run-tests)