better compile and omit-paths

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)
+          (parameterize ([current-compile cover-compile])
-          (load/use-compiled path sym)))))
+            (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))
@@ -121,18 +124,19 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
                             phase)]))
     (compile to-compile immediate-eval?)))
 
-(define-runtime-path cov "coverage.rkt")
+(define (remove-unneeded-results paths)
-(define abs-cover (->absolute cov))
+  (define c (get-raw-coverage))
-(define-runtime-path strace "strace.rkt")
+  (for ([s (in-list (hash-keys c))]
-(define abs-strace (->absolute strace))
+        #: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 'cover/coverage)
-    (namespace-require `(file ,abs-strace))
+    (namespace-require 'cover/strace)
     (namespace-require 'rackunit))
   (load-names!))
 

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)

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 new-omits (get-new-omits))
-  (define expanded-omits
+  (define full-omits (append new-omits omit-paths))
-    (case new-omits
-      [(#f) null]
-      [(all) (->absolute (current-directory))]
-      [else (map ->absolute new-omits)]))
-  (define full-omits (append expanded-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))

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))
+  (define e (add-cover-require stx))
-  (if e (annotate-top e phase) 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,10 +72,8 @@
     #: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 ...)
           (with-syntax ([(body ...)
                          (map (lambda (e) (add-cover-require e #f)) (syntax->list #'(b ...)))])
@@ -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]))