236 lines
7.3 KiB
Racket
236 lines
7.3 KiB
Racket
#lang racket/base
|
|
(require racket/cmdline
|
|
racket/match
|
|
racket/format
|
|
racket/list
|
|
racket/function
|
|
racket/port
|
|
racket/path
|
|
raco/command-name
|
|
rackunit/log
|
|
pkg/lib)
|
|
|
|
(define submodules '())
|
|
(define run-anyways? #t)
|
|
(define quiet? #f)
|
|
(define quiet-program? #f)
|
|
(define table? #f)
|
|
|
|
(define (dynamic-require* p d)
|
|
(parameterize
|
|
([current-output-port
|
|
(if quiet-program?
|
|
(open-output-nowhere)
|
|
(current-output-port))]
|
|
[current-error-port
|
|
(if quiet-program?
|
|
(open-output-nowhere)
|
|
(current-error-port))])
|
|
(dynamic-require p d)))
|
|
|
|
(struct summary (failed total label body-res))
|
|
(define-syntax-rule (with-summary label . body)
|
|
(let ()
|
|
(match-define (cons before-failed before-total)
|
|
(test-log #:display? #f #:exit? #f))
|
|
(define res (begin . body))
|
|
(match-define (cons after-failed after-total)
|
|
(test-log #:display? #f #:exit? #f))
|
|
(summary (- after-failed before-failed)
|
|
(- after-total before-total)
|
|
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 (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))))
|
|
|
|
(define (do-test e [check-suffix? #f])
|
|
(match e
|
|
[(? string? s)
|
|
(do-test (string->path s))]
|
|
[(? path? p)
|
|
(cond
|
|
[(directory-exists? p)
|
|
(with-summary
|
|
`(directory ,p)
|
|
(map
|
|
(λ (dp)
|
|
(do-test (build-path p dp) #t))
|
|
(directory-list p)))]
|
|
[(and (file-exists? p)
|
|
(or (not check-suffix?)
|
|
(regexp-match #rx#"\\.rkt$" (path->bytes p))))
|
|
(with-summary
|
|
`(file ,p)
|
|
(parameterize ([current-command-line-arguments '#()])
|
|
(define something-wasnt-declared? #f)
|
|
(for ([submodule (in-list (if (null? submodules)
|
|
'(test)
|
|
(reverse submodules)))])
|
|
(define mod `(submod ,p ,submodule))
|
|
(cond
|
|
[(module-declared? mod #t)
|
|
(unless quiet?
|
|
(printf "raco test: ~s\n" `(submod ,(if (absolute-path? p)
|
|
`(file ,(path->string p))
|
|
(path->string p))
|
|
,submodule)))
|
|
(dynamic-require* mod 0)]
|
|
[else
|
|
(set! something-wasnt-declared? #t)]))
|
|
(when (and run-anyways? something-wasnt-declared?)
|
|
(unless quiet?
|
|
(printf "raco test: ~s\n" (if (absolute-path? p)
|
|
`(file ,(path->string p))
|
|
(path->string p))))
|
|
(dynamic-require* p 0))))]
|
|
[(not (file-exists? p))
|
|
(error 'test "given path ~e does not exist" p)])]))
|
|
|
|
(module paths racket/base
|
|
(require setup/link
|
|
racket/list)
|
|
|
|
(struct col (name path) #:transparent)
|
|
|
|
(define (get-linked user? version?)
|
|
(define version-re
|
|
(and version?
|
|
(regexp-quote (version))))
|
|
(append
|
|
(for/list ([c+p (in-list (links #:user? user? #:version-regexp version-re #:with-path? #t))])
|
|
(col (car c+p)
|
|
(cdr c+p)))
|
|
(for/list ([cp (in-list (links #:root? #t #:user? user? #:version-regexp version-re))]
|
|
#: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 ([user? (in-list '(#t #f))]
|
|
[version? (in-list '(#t #f))])
|
|
(get-linked 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)
|
|
(for/list ([col (all-collections)]
|
|
#:when (string=? c (col-name col)))
|
|
(col-path col)))
|
|
|
|
(provide collection-paths))
|
|
|
|
(require (submod "." paths))
|
|
|
|
(define collections? #f)
|
|
(define packages? #f)
|
|
|
|
(define (do-test-wrap e)
|
|
(cond
|
|
[collections?
|
|
(match (collection-paths e)
|
|
[(list)
|
|
(error 'test "Collection ~e is not installed" e)]
|
|
[l
|
|
(with-summary
|
|
`(collection ,e)
|
|
(map do-test l))])]
|
|
[packages?
|
|
(define pd (pkg-directory e))
|
|
(if pd
|
|
(with-summary
|
|
`(package ,e)
|
|
(do-test pd))
|
|
(error 'test "Package ~e is not installed" e))]
|
|
[else
|
|
(do-test e)]))
|
|
|
|
(command-line
|
|
#:program (short-program+command-name)
|
|
#: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
|
|
[("--quiet" "-q")
|
|
"Suppress `raco test: ...' message"
|
|
(set! quiet? #t)]
|
|
[("--table" "-t")
|
|
"Print a summary table"
|
|
(set! table? #t)]
|
|
[("--quiet-program" "-Q")
|
|
"Quiet the program"
|
|
(set! quiet-program? #t)]
|
|
#:once-any
|
|
[("--collection" "-c")
|
|
"Interpret arguments as collections"
|
|
(set! collections? #t)]
|
|
[("--package" "-p")
|
|
"Interpret arguments as packages"
|
|
(set! packages? #t)]
|
|
#:args file-or-directory
|
|
(begin (define sum (map do-test-wrap file-or-directory))
|
|
(when table?
|
|
(display-summary sum))
|
|
(void (test-log #:display? #t #:exit? #t))))
|