128 lines
4.1 KiB
Racket
128 lines
4.1 KiB
Racket
#lang racket/base
|
|
(provide test-files! clear-coverage! get-test-coverage)
|
|
(require (for-syntax racket/base))
|
|
(require racket/dict
|
|
syntax/modcode
|
|
racket/function
|
|
syntax/modread
|
|
syntax/parse
|
|
"coverage.rkt"
|
|
"strace.rkt"
|
|
racket/runtime-path
|
|
rackunit)
|
|
|
|
|
|
|
|
(define ns (make-base-namespace))
|
|
|
|
;; PathString * -> Boolean
|
|
;; Test files and build coverage map
|
|
;; returns true if all tests passed
|
|
(define (test-files! #:coverage [coverage? #t] . paths)
|
|
(parameterize ([test-coverage-enabled coverage?])
|
|
(clear-coverage!)
|
|
(for ([p paths])
|
|
(let loop ()
|
|
(define-values (loc type) (get-module-path (build-path p)))
|
|
(case type
|
|
[(zo so)
|
|
(delete-file loc)
|
|
(loop)]
|
|
[else (void)])))
|
|
(parameterize ([use-compiled-file-paths
|
|
(cons (build-path "compiled" "better-test")
|
|
(use-compiled-file-paths))]
|
|
[current-compile (make-better-test-compile)])
|
|
(define tests-failed #f)
|
|
(for ([p paths])
|
|
(define old-check (current-check-handler))
|
|
(parameterize* ([current-namespace ns]
|
|
[current-check-handler
|
|
(lambda x
|
|
(set! tests-failed #t)
|
|
(apply old-check x))])
|
|
(eval `(dynamic-require '(file ,p) #f))
|
|
(namespace-require `(file ,p))
|
|
(define submod `(submod (file ,p) test))
|
|
(when (module-declared? submod)
|
|
(namespace-require submod))))
|
|
(not tests-failed))))
|
|
|
|
(define (make-better-test-compile)
|
|
(define compile (current-compile))
|
|
(define reg (namespace-module-registry ns))
|
|
(define phase (namespace-base-phase ns))
|
|
(lambda (e immediate-eval?)
|
|
(define to-compile
|
|
(if (eq? reg (namespace-module-registry (current-namespace)))
|
|
(annotate-top
|
|
(if (syntax? e) (expand e) (datum->syntax #f e))
|
|
phase)
|
|
e))
|
|
(compile to-compile immediate-eval?)))
|
|
|
|
(define-runtime-path cov "coverage.rkt")
|
|
;; -> Void
|
|
;; clear coverage map
|
|
(define (clear-coverage!)
|
|
(dict-clear! coverage)
|
|
(set! ns (make-base-namespace))
|
|
(namespace-attach-module (current-namespace) cov ns)
|
|
(namespace-attach-module (current-namespace) 'rackunit ns)
|
|
(parameterize ([current-namespace ns])
|
|
(namespace-require 'rackunit)))
|
|
|
|
;; -> [Hashof PathString (Listof (List Boolean srcloc))]
|
|
;; returns a hash of file to a list, where the first of the list is if
|
|
;; that srcloc was covered or not
|
|
;; based on <pkgs>/drracket/drracket/private/debug.rkt
|
|
(define (get-test-coverage)
|
|
;; can-annotate : (listof (list boolean srcloc))
|
|
;; boolean is #t => code was run
|
|
;; #f => code was not run
|
|
;; remove those that cannot be annotated
|
|
(define can-annotate
|
|
(filter values
|
|
(for/list ([(stx covered?) coverage])
|
|
(and (syntax? stx)
|
|
(let* ([orig-src (syntax-source stx)]
|
|
[src (if (path? orig-src) (path->string orig-src) orig-src)]
|
|
[pos (syntax-position stx)]
|
|
[span (syntax-span stx)])
|
|
(and pos
|
|
span
|
|
(list covered?
|
|
(make-srcloc src #f #f pos span))))))))
|
|
|
|
;; actions-ht : (list src number number) -> (list boolean syntax)
|
|
(define actions-ht (make-hash))
|
|
|
|
(for-each
|
|
(λ (pr)
|
|
(let* ([on? (car pr)]
|
|
[key (cadr pr)]
|
|
[old (hash-ref actions-ht key 'nothing)])
|
|
(cond
|
|
[(eq? old 'nothing)
|
|
(hash-set! actions-ht key on?)]
|
|
[old ;; recorded as executed
|
|
(void)]
|
|
[(not old) ;; recorded as unexected
|
|
(when on?
|
|
(hash-set! actions-ht key #t))])))
|
|
can-annotate)
|
|
|
|
;; filtered : (listof (list boolean srcloc))
|
|
;; remove redundant expressions
|
|
(define filtered (hash-map actions-ht (λ (k v) (list v k))))
|
|
|
|
(define out (make-hash))
|
|
|
|
(for ([v filtered])
|
|
(define file (srcloc-source (cadr v)))
|
|
(hash-update! out
|
|
file
|
|
(lambda (l) (cons v l))
|
|
null))
|
|
out)
|