729 lines
24 KiB
Racket
729 lines
24 KiB
Racket
#lang racket/base
|
|
(require racket/cmdline
|
|
racket/match
|
|
racket/format
|
|
racket/list
|
|
racket/function
|
|
racket/port
|
|
racket/path
|
|
racket/place
|
|
racket/future
|
|
racket/file
|
|
compiler/find-exe
|
|
raco/command-name
|
|
racket/system
|
|
rackunit/log
|
|
pkg/lib
|
|
setup/collects
|
|
setup/getinfo)
|
|
|
|
(define rx:default-suffixes #rx#"\\.(?:rkt|scrbl)$")
|
|
;; For any other file suffix, a `test-command-line-arguments`
|
|
;; entry is required in "info.rkt".
|
|
|
|
(define submodules '()) ; '() means "default"
|
|
(define first-avail? #f)
|
|
(define run-anyways? #t)
|
|
(define quiet? #f)
|
|
(define quiet-program? #f)
|
|
(define check-stderr? #f)
|
|
(define table? #f)
|
|
|
|
(define jobs 0) ; 0 mean "default"
|
|
(define task-sema (make-semaphore 1))
|
|
|
|
(define default-timeout #f) ; #f means "none"
|
|
(define default-mode #f) ; #f => depends on how many files are provided
|
|
|
|
(define single-file? #t)
|
|
|
|
;; Stub for running a test in a process:
|
|
(module process racket/base
|
|
(require rackunit/log)
|
|
;; Arguments are a temp file to hold test results, the module
|
|
;; path to run, and the `dynamic-require` second argument:
|
|
(define argv (current-command-line-arguments))
|
|
(define result-file (vector-ref argv 0))
|
|
(define test-module (read (open-input-string (vector-ref argv 1))))
|
|
(define d (read (open-input-string (vector-ref argv 2))))
|
|
(define args (list-tail (vector->list argv) 3))
|
|
|
|
(parameterize ([current-command-line-arguments (list->vector args)])
|
|
(dynamic-require test-module d)
|
|
((executable-yield-handler) 0))
|
|
|
|
(call-with-output-file*
|
|
result-file
|
|
#:exists 'truncate
|
|
(lambda (o)
|
|
(write (test-log #:display? #f #:exit? #f) o)))
|
|
(exit 0))
|
|
|
|
;; Driver for running a test in a place:
|
|
(module place racket/base
|
|
(require racket/place
|
|
rackunit/log)
|
|
(provide go)
|
|
(define (go pch)
|
|
(define l (place-channel-get pch))
|
|
;; Run the test:
|
|
(parameterize ([current-command-line-arguments (list->vector
|
|
(cadddr l))]
|
|
[current-directory (caddr l)])
|
|
(dynamic-require (car l) (cadr l))
|
|
((executable-yield-handler) 0))
|
|
;; If the tests use `rackunit`, collect result stats:
|
|
(define test-results
|
|
(test-log #:display? #f #:exit? #f))
|
|
;; Return test results. If we don't get this far, the result
|
|
;; code of the place determines whether it the test counts as
|
|
;; successful.
|
|
(place-channel-put pch
|
|
;; If the test did not use `rackunit`, claim
|
|
;; success:
|
|
(if (zero? (car test-results))
|
|
(cons 0 1)
|
|
test-results))))
|
|
|
|
;; Run each test in its own place or process, and collect both test
|
|
;; results and whether any output went to stderr.
|
|
(define (dynamic-require-elsewhere p d args
|
|
#:mode [mode (or default-mode
|
|
(if single-file?
|
|
'direct
|
|
'process))]
|
|
#:timeout [timeout default-timeout])
|
|
(define c (make-custodian))
|
|
(with-handlers ([exn:fail? (lambda (exn)
|
|
(custodian-shutdown-all c)
|
|
(unless quiet?
|
|
(eprintf "~a: ~a\n"
|
|
(extract-file-name p)
|
|
(exn-message exn)))
|
|
(summary 1 1 (current-label) #f))])
|
|
(define e (open-output-bytes))
|
|
|
|
(define stdout (if quiet-program?
|
|
(open-output-nowhere)
|
|
(current-output-port)))
|
|
(define stderr (if quiet-program?
|
|
e
|
|
(if check-stderr?
|
|
(tee-output-port (current-error-port) e)
|
|
(current-error-port))))
|
|
|
|
(define-values (result-code test-results)
|
|
(case mode
|
|
[(direct)
|
|
(define pre (test-log #:display? #f #:exit? #f))
|
|
(define done? #f)
|
|
(define t
|
|
(parameterize ([current-output-port stdout]
|
|
[current-error-port stderr]
|
|
[current-command-line-arguments (list->vector args)])
|
|
(thread
|
|
(lambda ()
|
|
(dynamic-require p d)
|
|
((executable-yield-handler) 0)
|
|
(set! done? #t)))))
|
|
(unless (thread? (sync/timeout timeout t))
|
|
(error 'test "timeout after ~a seconds" timeout))
|
|
(unless done?
|
|
(error 'test "test raised an exception"))
|
|
(define post (test-log #:display? #f #:exit? #f))
|
|
(values 0
|
|
(cons (- (car post) (car pre))
|
|
(- (cdr post) (cdr pre))))]
|
|
[(place)
|
|
;; Start the test place:
|
|
(define-values (pl in out/f err/f)
|
|
(parameterize ([current-custodian c])
|
|
(dynamic-place* '(submod compiler/commands/test place)
|
|
'go
|
|
#:in (current-input-port)
|
|
#:out stdout
|
|
#:err stderr)))
|
|
|
|
;; Send the module path to test:
|
|
(place-channel-put pl (list p d (current-directory) args))
|
|
|
|
;; Wait for the place to finish:
|
|
(unless (sync/timeout timeout (place-dead-evt pl))
|
|
(error 'test "timeout after ~a seconds" timeout))
|
|
|
|
;; Get result code and test results:
|
|
(values (place-wait pl)
|
|
(sync/timeout 0 pl))]
|
|
[(process)
|
|
(define tmp-file (make-temporary-file))
|
|
(define ps
|
|
(parameterize ([current-output-port stdout]
|
|
[current-error-port stderr]
|
|
[current-subprocess-custodian-mode 'kill]
|
|
[current-custodian c])
|
|
(apply process*/ports
|
|
stdout
|
|
(current-input-port)
|
|
stderr
|
|
(find-exe)
|
|
"-l"
|
|
"racket/base"
|
|
"-e"
|
|
"(dynamic-require '(submod compiler/commands/test process) #f)"
|
|
tmp-file
|
|
(format "~s" (normalize-module-path p))
|
|
(format "~s" d)
|
|
args)))
|
|
(define proc (list-ref ps 4))
|
|
|
|
(unless (sync/timeout timeout (thread (lambda () (proc 'wait))))
|
|
(error 'test "timeout after ~a seconds" timeout))
|
|
|
|
(define results
|
|
(with-handlers ([exn:fail:read? (lambda () #f)])
|
|
(call-with-input-file* tmp-file read)))
|
|
|
|
(values (proc 'exit-code)
|
|
(and (pair? results)
|
|
(exact-positive-integer? (car results))
|
|
(exact-positive-integer? (cdr results))
|
|
results))]))
|
|
|
|
;; Shut down the place/process (usually a no-op unless it timed out):
|
|
(custodian-shutdown-all c)
|
|
|
|
;; Check results:
|
|
(when check-stderr?
|
|
(unless (equal? #"" (get-output-bytes e))
|
|
(error 'test "non-empty stderr: ~e" (get-output-bytes e))))
|
|
(unless (zero? result-code)
|
|
(error 'test "non-zero exit: ~e" result-code))
|
|
(cond
|
|
[test-results
|
|
(summary (car test-results) (cdr test-results) (current-label) #f)]
|
|
[else
|
|
(summary 0 1 (current-label) #f)])))
|
|
|
|
;; For recording stderr while also propagating to the original stderr:
|
|
(define (tee-output-port p1 p2)
|
|
(make-output-port
|
|
(object-name p1)
|
|
p1
|
|
(lambda (bstr start end non-block? enable-break?)
|
|
(cond
|
|
[(= start end)
|
|
(flush-output p1)
|
|
0]
|
|
[else
|
|
(define n (write-bytes-avail* bstr p1 start end))
|
|
(cond
|
|
[(or (not n)
|
|
(zero? n))
|
|
(wrap-evt p1 (lambda (v) 0))]
|
|
[else
|
|
(write-bytes bstr p2 start (+ start n))
|
|
n])]))
|
|
(lambda ()
|
|
(close-output-port p1)
|
|
(close-output-port p2))))
|
|
|
|
(define (extract-file-name p)
|
|
(cond
|
|
[(and (pair? p) (eq? 'submod (car p)))
|
|
(cadr p)]
|
|
[else p]))
|
|
|
|
(define (add-submod mod sm)
|
|
(if (and (pair? mod) (eq? 'submod (car mod)))
|
|
(append mod '(config))
|
|
(error 'test "cannot add test-config submodule to path: ~s" mod)))
|
|
|
|
(define (dynamic-require* p d args try-config?)
|
|
(define lookup
|
|
(or (cond
|
|
[(not try-config?) #f]
|
|
[(module-declared? (add-submod p 'config) #t)
|
|
(dynamic-require (add-submod p 'config) '#%info-lookup)]
|
|
[else #f])
|
|
(lambda (what get-default) (get-default))))
|
|
(dynamic-require-elsewhere
|
|
p d args
|
|
#:timeout (if default-timeout
|
|
(lookup 'timeout
|
|
(lambda () default-timeout))
|
|
+inf.0)))
|
|
|
|
(define current-label (make-parameter "???"))
|
|
(struct summary (failed total label body-res))
|
|
|
|
(define-syntax-rule (with-summary label . body)
|
|
(call-with-summary label (lambda () . body)))
|
|
|
|
(define (call-with-summary label thunk)
|
|
(define res
|
|
;; Produces either a summary or a list of summary:
|
|
(parameterize ([current-label label])
|
|
(thunk)))
|
|
(if (summary? res)
|
|
res
|
|
(summary
|
|
(apply + (map summary-failed res))
|
|
(apply + (map summary-total res))
|
|
(current-label)
|
|
res)))
|
|
|
|
|
|
(define (iprintf i fmt . more)
|
|
(for ([j (in-range i)])
|
|
(display #\space))
|
|
(apply printf fmt more))
|
|
(define (display-summary top)
|
|
(define files
|
|
(let flatten ([sum top])
|
|
(match sum
|
|
[(list sum ...)
|
|
(append-map flatten sum)]
|
|
[(summary failed total `(file ,p) body)
|
|
(list sum)]
|
|
[(summary failed total label body)
|
|
(flatten body)]
|
|
[(? void?)
|
|
empty])))
|
|
(define sfiles
|
|
(sort files
|
|
(λ (x y)
|
|
(cond
|
|
[(= (summary-failed x) (summary-failed y))
|
|
(> (summary-total x) (summary-total y))]
|
|
[else
|
|
(< (summary-failed x) (summary-failed y))]))))
|
|
(define (max-width f)
|
|
(string-length
|
|
(number->string
|
|
(apply max 0 (map f sfiles)))))
|
|
(define failed-wid (max-width summary-failed))
|
|
(define total-wid (max-width summary-total))
|
|
(for ([f (in-list sfiles)])
|
|
(match-define (summary failed total `(file ,p) _) f)
|
|
(displayln (~a (~a #:min-width failed-wid
|
|
#:align 'right
|
|
(if (zero? failed)
|
|
""
|
|
failed))
|
|
" "
|
|
(~a #:min-width total-wid
|
|
#:align 'right
|
|
total)
|
|
" " p))))
|
|
|
|
;; Like `map`, but allows `run-one-test`s in parallel while starting
|
|
;; tasks in the order that a plain `map` would run them. The #:sema
|
|
;; argument everywhere makes tests start in a deterministic order
|
|
;; and keeps a filesystem traversal from getting far ahead of the
|
|
;; test runs.
|
|
(define (map/parallel f l #:sema continue-sema)
|
|
(cond
|
|
[(jobs . <= . 1) (map (lambda (v) (f v #:sema continue-sema)) l)]
|
|
[else
|
|
(struct task (th result-box))
|
|
(define ts
|
|
(for/list ([i (in-list l)])
|
|
(define b (box #f))
|
|
(define c-sema (make-semaphore))
|
|
(define t (thread
|
|
(lambda ()
|
|
(set-box! b (with-handlers ([exn? values])
|
|
(f i #:sema c-sema)))
|
|
;; If no parallel task was ever created,
|
|
;; count that as progress to the parent
|
|
;; thread:
|
|
(semaphore-post c-sema))))
|
|
(sync c-sema)
|
|
(task t b)))
|
|
(semaphore-post continue-sema)
|
|
(map sync (map task-th ts))
|
|
(for/list ([t (in-list ts)])
|
|
(define v (unbox (task-result-box t)))
|
|
(if (exn? v)
|
|
(raise v)
|
|
v))]))
|
|
|
|
(define (normalize-module-path p)
|
|
(cond
|
|
[(path? p) (path->string p)]
|
|
[(and (pair? p) (eq? 'submod (car p)))
|
|
(list* 'submod (normalize-module-path (cadr p)) (cddr p))]
|
|
[else p]))
|
|
|
|
(define ids '(1))
|
|
(define ids-lock (make-semaphore 1))
|
|
|
|
(define (set-jobs! n)
|
|
(set! jobs n)
|
|
(set! task-sema (make-semaphore jobs))
|
|
(set! ids (for/list ([i (in-range jobs)]) i)))
|
|
|
|
;; Perform test of one module (in parallel, as allowed by
|
|
;; `task-sema`):
|
|
(define (test-module p mod args try-config? #:sema continue-sema)
|
|
(call-with-semaphore
|
|
task-sema ; limits parallelism
|
|
(lambda ()
|
|
(semaphore-post continue-sema) ; allow next to try to start
|
|
(define id
|
|
(call-with-semaphore
|
|
ids-lock
|
|
(lambda ()
|
|
(define id (car ids))
|
|
(set! ids (cdr ids))
|
|
(unless quiet?
|
|
;; in lock, so printouts are not interleaved
|
|
(printf "raco test: ~a~s~a\n"
|
|
(if (jobs . <= . 1)
|
|
""
|
|
(format "~a " id))
|
|
(let ([m (normalize-module-path p)])
|
|
(if (and (pair? mod) (eq? 'submod (car mod)))
|
|
(list* 'submod m (cddr mod))
|
|
m))
|
|
(apply string-append
|
|
(for/list ([a (in-list args)])
|
|
(format " ~s" (format "~a" a)))))
|
|
(flush-output))
|
|
id)))
|
|
(begin0
|
|
(dynamic-require* mod 0 args try-config?)
|
|
(call-with-semaphore
|
|
ids-lock
|
|
(lambda ()
|
|
(set! ids (cons id ids))))))))
|
|
|
|
;; Perform all tests in path `e`:
|
|
(define (test-files e
|
|
#:check-suffix? [check-suffix? #f]
|
|
#:sema continue-sema)
|
|
(match e
|
|
[(? string? s)
|
|
(test-files (string->path s)
|
|
#:check-suffix? check-suffix?
|
|
#:sema continue-sema)]
|
|
[(? path? p)
|
|
(cond
|
|
[(directory-exists? p)
|
|
(set! single-file? #f)
|
|
(if (omit-path? (path->directory-path p))
|
|
(summary 0 0 #f 0)
|
|
(with-summary
|
|
`(directory ,p)
|
|
(map/parallel
|
|
(λ (dp #:sema s)
|
|
(test-files (build-path p dp)
|
|
#:check-suffix? #t
|
|
#:sema s))
|
|
(directory-list p)
|
|
#:sema continue-sema)))]
|
|
[(and (file-exists? p)
|
|
(or (not check-suffix?)
|
|
(regexp-match rx:default-suffixes p)
|
|
(get-cmdline p #f))
|
|
(not (omit-path? p)))
|
|
(define args (get-cmdline p))
|
|
(parameterize ([current-directory (let-values ([(base name dir?) (split-path p)])
|
|
(if (path? base)
|
|
base
|
|
(current-directory)))])
|
|
(define file-name (file-name-from-path p))
|
|
(with-summary
|
|
`(file ,p)
|
|
(let ([something-wasnt-declared? #f]
|
|
[did-one? #f])
|
|
(filter
|
|
values
|
|
(append
|
|
(for/list ([submodule (in-list (if (null? submodules)
|
|
'(test)
|
|
(reverse submodules)))])
|
|
(define mod `(submod ,file-name ,submodule))
|
|
(cond
|
|
[(and did-one? first-avail?)
|
|
#f]
|
|
[(module-declared? mod #t)
|
|
(set! did-one? #t)
|
|
(test-module p mod args #t #:sema continue-sema)]
|
|
[else
|
|
(set! something-wasnt-declared? #t)
|
|
#f]))
|
|
(list
|
|
(and (and run-anyways? something-wasnt-declared?)
|
|
(test-module p file-name args #f #:sema continue-sema))))))))]
|
|
[(not (file-exists? p))
|
|
(error 'test "given path ~e does not exist" p)]
|
|
[else (summary 0 0 #f null)])]))
|
|
|
|
(module paths racket/base
|
|
(require setup/link
|
|
racket/match
|
|
racket/list)
|
|
|
|
(struct col (name path) #:transparent)
|
|
|
|
(define (get-linked file user? version?)
|
|
(define version-re
|
|
(and version?
|
|
(regexp-quote (version))))
|
|
(append
|
|
(for/list ([c+p
|
|
(in-list
|
|
(links #:file file #:user? user? #:version-regexp version-re
|
|
#:with-path? #t))])
|
|
(col (car c+p)
|
|
(cdr c+p)))
|
|
(for/list ([cp
|
|
(in-list
|
|
(links #:file file #:user? user? #:version-regexp version-re
|
|
#:root? #t))]
|
|
#:when (directory-exists? cp)
|
|
[collection (directory-list cp)]
|
|
#:when (directory-exists? (build-path cp collection)))
|
|
(col (path->string collection)
|
|
(build-path cp collection)))))
|
|
|
|
;; A list of `col's, where each collection may be represented
|
|
;; by multiple elements of the list, each with its own path.
|
|
(define (all-collections)
|
|
(remove-duplicates
|
|
(append*
|
|
(for/list ([cp (current-library-collection-paths)]
|
|
#:when (directory-exists? cp)
|
|
[collection (directory-list cp)]
|
|
#:when (directory-exists? (build-path cp collection)))
|
|
(col (path->string collection)
|
|
(build-path cp collection)))
|
|
(for*/list ([file (in-list (current-library-collection-links))]
|
|
[user? (in-list '(#t #f))]
|
|
[version? (in-list '(#t #f))])
|
|
(get-linked file user? version?)))))
|
|
|
|
;; This should be in Racket somewhere and return all the collection
|
|
;; paths, rather than just the first as collection-path does.
|
|
(define (collection-paths c)
|
|
(match-define (list-rest sc more) (map path->string (explode-path c)))
|
|
(append*
|
|
(for/list ([col (all-collections)]
|
|
#:when (string=? sc (col-name col)))
|
|
(define p (col-path col))
|
|
(define cp (apply build-path p more))
|
|
(if (directory-exists? cp)
|
|
(list cp)
|
|
empty))))
|
|
|
|
(provide collection-paths))
|
|
|
|
(require (submod "." paths))
|
|
|
|
(define collections? #f)
|
|
(define packages? #f)
|
|
|
|
(define (test-top e #:sema continue-sema)
|
|
(cond
|
|
[collections?
|
|
(match (collection-paths e)
|
|
[(list)
|
|
(error 'test "Collection ~e is not installed" e)]
|
|
[l
|
|
(with-summary
|
|
`(collection ,e)
|
|
(map/parallel test-files l #:sema continue-sema))])]
|
|
[packages?
|
|
(define pd (pkg-directory e))
|
|
(if pd
|
|
(with-summary
|
|
`(package ,e)
|
|
(test-files pd #:sema continue-sema))
|
|
(error 'test "Package ~e is not installed" e))]
|
|
[else
|
|
(test-files e #:sema continue-sema)]))
|
|
|
|
;; --------------------------------------------------
|
|
;; Reading "info.rkt" files
|
|
|
|
(define omit-paths (make-hash))
|
|
(define command-line-arguments (make-hash))
|
|
|
|
(define collects-cache (make-hash))
|
|
(define info-done (make-hash))
|
|
|
|
(define (check-info p check-up?)
|
|
(define-values (base name dir?) (split-path p))
|
|
(define dir (normalize-info-path
|
|
(if dir?
|
|
p
|
|
(if (path? base)
|
|
(path->complete-path base)
|
|
(current-directory)))))
|
|
|
|
(when (and check-up? (not dir?))
|
|
;; Check enclosing collection
|
|
(define c (path->collects-relative p #:cache collects-cache))
|
|
(when (list? c)
|
|
(check-info/parents dir
|
|
(apply build-path (map bytes->path (reverse (cdr (reverse (cdr c)))))))))
|
|
|
|
(unless (hash-ref info-done dir #f)
|
|
(hash-set! info-done dir #t)
|
|
(define info (get-info/full dir))
|
|
(when info
|
|
(define v (info 'test-omit-paths (lambda () '())))
|
|
(define (bad what v)
|
|
(log-error "bad `~a' in \"info.rkt\": ~e" what v))
|
|
(cond
|
|
[(eq? v 'all)
|
|
(hash-set! omit-paths dir #t)]
|
|
[(list? v)
|
|
(for ([i (in-list v)])
|
|
(unless (path-string? i) (bad 'test-omit-paths v))
|
|
(define p (normalize-info-path (path->complete-path i dir)))
|
|
(define dp (if (directory-exists? p)
|
|
(path->directory-path p)
|
|
p))
|
|
(hash-set! omit-paths dp #t))]
|
|
[else (bad 'test-omit-paths v)])
|
|
|
|
(define a (info 'test-command-line-arguments (lambda () '())))
|
|
(unless (list? a) (bad 'test-command-line-arguments a))
|
|
(for ([arg (in-list a)])
|
|
(unless (and (list? arg)
|
|
(= 2 (length arg))
|
|
(path-string? (car arg))
|
|
(list? (cadr arg))
|
|
(andmap path-string? (cadr arg)))
|
|
(bad 'test-command-line-arguments a))
|
|
(hash-set! command-line-arguments
|
|
(normalize-info-path (path->complete-path (car arg) dir))
|
|
(cadr arg))))))
|
|
|
|
(define (check-info/parents dir subpath)
|
|
(let loop ([dir dir] [subpath subpath])
|
|
(unless (hash-ref info-done dir #f)
|
|
(check-info dir #f)
|
|
(define-values (next-subpath subpath-name subpath-dir?) (split-path subpath))
|
|
(define-values (next-dir dir-name dir-dir?) (split-path dir))
|
|
(when (path? next-subpath)
|
|
(loop next-dir next-subpath)))))
|
|
|
|
(define (normalize-info-path p)
|
|
(simplify-path (path->complete-path p) #f))
|
|
|
|
(define (omit-path? p)
|
|
(check-info p #t)
|
|
(let ([p (normalize-info-path p)])
|
|
(or (hash-ref omit-paths p #f)
|
|
(let-values ([(base name dir?) (split-path p)])
|
|
(and (path? base)
|
|
(omit-path? base))))))
|
|
|
|
(define (get-cmdline p [default null])
|
|
(let ([p (normalize-info-path p)])
|
|
(hash-ref command-line-arguments p default)))
|
|
|
|
;; --------------------------------------------------
|
|
|
|
(define (string->number* what s check)
|
|
(define n (string->number s))
|
|
(unless (check n)
|
|
(raise-user-error (string->symbol (short-program+command-name))
|
|
"invalid ~a: ~s"
|
|
what
|
|
s))
|
|
n)
|
|
|
|
(command-line
|
|
#:program (short-program+command-name)
|
|
#:once-any
|
|
[("--collection" "-c")
|
|
"Interpret arguments as collections"
|
|
(set! collections? #t)]
|
|
[("--package" "-p")
|
|
"Interpret arguments as packages"
|
|
(set! packages? #t)]
|
|
#:once-each
|
|
[("--drdr")
|
|
"Configure defaults to imitate DrDr"
|
|
(set! first-avail? #t)
|
|
(when (zero? jobs)
|
|
(set-jobs! (processor-count)))
|
|
(unless default-timeout
|
|
(set! default-timeout 90))
|
|
(set! check-stderr? #t)
|
|
(set! quiet-program? #t)
|
|
(set! table? #t)
|
|
(unless default-mode
|
|
(set! default-mode 'process))]
|
|
#:multi
|
|
[("--submodule" "-s") name
|
|
"Runs submodule <name>\n (defaults to running just the `test' submodule)"
|
|
(let ([n (string->symbol name)])
|
|
(set! submodules (cons n submodules)))]
|
|
#:once-any
|
|
[("--run-if-absent" "-r")
|
|
"Require module if submodule is absent (on by default)"
|
|
(set! run-anyways? #t)]
|
|
[("--no-run-if-absent" "-x")
|
|
"Require nothing if submodule is absent"
|
|
(set! run-anyways? #f)]
|
|
#:once-each
|
|
[("--first-avail")
|
|
"Run only the first available submodule"
|
|
(set! first-avail? #f)]
|
|
#:once-any
|
|
[("--direct")
|
|
"Run tests directly (default for a single file)"
|
|
(set! default-mode 'direct)]
|
|
[("--process")
|
|
"Run tests in separate processes (default for multiple files)"
|
|
(set! default-mode 'process)]
|
|
[("--place")
|
|
"Run tests in places"
|
|
(set! default-mode 'place)]
|
|
#:once-each
|
|
[("--jobs" "-j") n
|
|
"Run up to <n> tests in parallel"
|
|
(set-jobs! (string->number* "jobs" n exact-positive-integer?))]
|
|
[("--timeout") seconds
|
|
"Set default timeout to <seconds>"
|
|
(set! default-timeout (string->number* "timeout" seconds real?))]
|
|
[("--quiet-program" "-Q")
|
|
"Quiet the program"
|
|
(set! quiet-program? #t)]
|
|
[("--check-stderr" "-e")
|
|
"Treat stderr output as a test failure"
|
|
(set! check-stderr? #t)]
|
|
[("--quiet" "-q")
|
|
"Suppress `raco test: ...' message"
|
|
(set! quiet? #t)]
|
|
[("--table" "-t")
|
|
"Print a summary table"
|
|
(set! table? #t)]
|
|
#:args file-or-directory
|
|
(begin (unless (= 1 (length file-or-directory))
|
|
(set! single-file? #f))
|
|
(define sum
|
|
;; The #:sema argument everywhre makes tests start
|
|
;; in a deterministic order:
|
|
(map/parallel test-top file-or-directory
|
|
#:sema (make-semaphore)))
|
|
(when table?
|
|
(display-summary sum))
|
|
(unless (or (eq? default-mode 'direct)
|
|
(and (not default-mode) single-file?))
|
|
;; Re-log failures and successes, and then report using `test-log`.
|
|
;; (This is awkward; is it better to not try to use `test-log`?)
|
|
(for ([s (in-list sum)])
|
|
(for ([i (in-range (summary-failed s))])
|
|
(test-log! #f))
|
|
(for ([i (in-range (- (summary-total s)
|
|
(summary-failed s)))])
|
|
(test-log! #t))))
|
|
(define r (test-log #:display? #t #:exit? #t))
|
|
(exit (if (zero? (car r)) 0 1))))
|