diff --git a/cover.rkt b/cover.rkt index 8e39ad1..e1dbd0b 100644 --- a/cover.rkt +++ b/cover.rkt @@ -38,15 +38,15 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (if (list? p) (cons (->absolute (car p)) (cdr p)) (->absolute p)))) - (parameterize ([current-load/use-compiled (make-cover-load/use-compiled paths)] + (define abs-paths (map (lambda (p) (if (list? p) (first p) p)) abs)) + (parameterize ([current-load/use-compiled (make-cover-load/use-compiled abs-paths)] [use-compiled-file-paths (cons (build-path "compiled" "cover") (use-compiled-file-paths))] - [current-compile (make-cover-compile)] [current-output-port (if (verbose) (current-output-port) (open-output-nowhere))]) (define tests-failed #f) - (for ([p (in-list paths)]) + (for ([p (in-list abs)]) (vprintf "attempting to run ~s\n" p) (define old-check (current-check-handler)) (define path (if (list? p) (car p) p)) @@ -72,6 +72,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (define submod `(submod ,file ,submod-name)) (run-mod (if (module-declared? submod #t) submod file))))) (vprintf "ran ~s\n" paths) + (remove-unneeded-results abs-paths) (not tests-failed))) ;; ModulePath -> Void @@ -81,24 +82,26 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (eval `(dynamic-require ',to-run #f)) (vprintf "finished running ~s\n" to-run)) -;; [Listof Path] -> Loader +;; [Listof Path] -> Loader Compiler ;; returns a value that can be set of `current-load/use-compiled` ;; forces the given files to be recompiled whenever load/use-compiled is called (define (make-cover-load/use-compiled paths) (define load/use-compiled (current-load/use-compiled)) (define load (current-load)) + (define compile (current-compile)) + (define cover-compile (make-cover-compile)) (lambda (path sym) (define abs (->absolute path)) (define lst (explode-path abs)) (define dir-list (take lst (sub1 (length lst)))) (parameterize ([current-load-relative-directory (apply build-path dir-list)]) (if (member abs paths) - (load path sym) - (load/use-compiled path sym))))) + (parameterize ([current-compile cover-compile]) + (load path sym)) + (parameterize ([current-compile compile]) + (load/use-compiled path sym)))))) ;; -> Compiler -;; returns a value that can be set of `current-compiled` -;; compiles anything begin compiled in `ns` to be compiled with coverage annotations (define (make-cover-compile) (define compile (current-compile)) (define reg (namespace-module-registry ns)) @@ -117,22 +120,23 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (or (syntax-source-file-name e) (syntax-source e) (syntax->datum e)))) - (annotate-top (if (syntax? e) (expand-syntax e) (datum->syntax #f e)) - phase)])) + (annotate-top (if (syntax? e) (expand-syntax e) (datum->syntax #f e)) + phase)])) (compile to-compile immediate-eval?))) -(define-runtime-path cov "coverage.rkt") -(define abs-cover (->absolute cov)) -(define-runtime-path strace "strace.rkt") -(define abs-strace (->absolute strace)) +(define (remove-unneeded-results paths) + (define c (get-raw-coverage)) + (for ([s (in-list (hash-keys c))] + #:when (not (member (srcloc-source s) paths))) + (hash-remove! c s))) ;; -> Void ;; clear coverage map. Effectively recreates and rebuilds `ns` (define (clear-coverage!) (set! ns (make-base-namespace)) (parameterize ([current-namespace ns]) - (namespace-require `(file ,abs-cover)) - (namespace-require `(file ,abs-strace)) + (namespace-require 'cover/coverage) + (namespace-require 'cover/strace) (namespace-require 'rackunit)) (load-names!)) diff --git a/info.rkt b/info.rkt index a87ed9a..bb85619 100644 --- a/info.rkt +++ b/info.rkt @@ -12,6 +12,7 @@ (define scribblings '(("scribblings/cover.scrbl" (multi-page)))) (define test-omit-paths (list "tests/error-file.rkt" "scribblings")) +(define cover-omit-paths (list "strace.rkt" "coverage.rkt")) (define cover-formats '(("html" cover generate-html-coverage) ("coveralls" cover generate-coveralls-coverage) diff --git a/raco.rkt b/raco.rkt index 9a2e1c3..d74b35f 100644 --- a/raco.rkt +++ b/raco.rkt @@ -118,13 +118,8 @@ ;; -> (HorribyNestedListsOf (or PathString (list path-string vector)) (define (expand-directory exts [omit-paths null] [args null]) - (define new-omits (get-info-var (current-directory) 'test-omit-paths)) - (define expanded-omits - (case new-omits - [(#f) null] - [(all) (->absolute (current-directory))] - [else (map ->absolute new-omits)])) - (define full-omits (append expanded-omits omit-paths)) + (define new-omits (get-new-omits)) + (define full-omits (append new-omits omit-paths)) (define new-argv (get-info-var (current-directory) 'test-command-line-arguments)) (define expanded-argv (if (not new-argv) @@ -158,6 +153,16 @@ (check-false (member o dirs) (format "~s ~s" o dirs))))) +(define (get-new-omits) + (append (get-omits 'test-omit-paths) + (get-omits 'cover-omit-paths))) +(define (get-omits s) + (define new-omits (get-info-var (current-directory) s)) + (case new-omits + [(#f) null] + [(all) (->absolute (current-directory))] + [else (map ->absolute new-omits)])) + (define (path-add-argv path argvs) (define x (assoc path argvs)) (or x path)) diff --git a/strace.rkt b/strace.rkt index 5322c4d..7311ffd 100644 --- a/strace.rkt +++ b/strace.rkt @@ -7,6 +7,7 @@ racket/unit racket/runtime-path "private/file-utils.rkt" + "private/shared.rkt" "coverage.rkt") (define cover-name #'coverage) @@ -61,10 +62,9 @@ #'(make-srcloc src a b pos span))))) (define (in:annotate-top stx phase) - (define e (add-cover-require stx phase)) - (if e (annotate-top e phase) stx)) + (define e (add-cover-require stx)) + (if e (annotate-clean (annotate-top e phase)) stx)) -(define-runtime-path coverage.rkt "coverage.rkt") (define (add-cover-require expr [top #t]) (define inspector (variable-reference->module-declaration-inspector (#%variable-reference))) @@ -72,11 +72,9 @@ #:literal-sets (kernel-literals) [(module name lang mb) (with-syntax ([cover cover-name] - [srcloc srcloc-name] - ) + [srcloc srcloc-name]) (syntax-parse (syntax-disarm #'mb inspector) - #:literal-sets (kernel-literals) - [(#%module-begin b ...) + [(#%module-begin b ...) (with-syntax ([(body ...) (map (lambda (e) (add-cover-require e #f)) (syntax->list #'(b ...)))]) (syntax-rearm @@ -84,8 +82,18 @@ (quasisyntax/loc expr (module name lang (#%module-begin - (#%require (rename (file #,(->absolute coverage.rkt)) cover coverage)) + (#%require (rename cover/coverage cover coverage)) (#%require (rename racket/base srcloc make-srcloc)) body ...)))) expr))]))] [_ (if top #f expr)])) + +;; in order to write modules to disk the top level needs to +;; be a module. so we trust that the module is loaded and trim the expression +(define (annotate-clean e) + (syntax-parse e + #:literal-sets (kernel-literals) + [(begin e mod) + (eval #'e) + #'mod] + [_ e]))