removing deps on racket/base, and checking cross-phase persistent modules

cover.rkt

@@ -30,9 +30,10 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
          racket/list
          racket/port
          "private/shared.rkt"
-         "private/file-utils.rkt")
+         "private/file-utils.rkt"
+         "strace.rkt")
 
-(struct environment (namespace compile ann-top raw-cover cch))
+(struct environment (namespace compile ann-top raw-cover))
 
 ;;; ---------------------- Running Files ---------------------------------
 
@@ -71,7 +72,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
                         [current-command-line-arguments argv]
                         [exit-handler (lambda (x) (raise (an-exit x)))]
                         [current-namespace (get-namespace)]
-                        [(get-check-handler-parameter)
+                        [current-check-handler ;(get-check-handler-parameter)
                          (lambda x
                            (set! tests-failed #t)
                            (vprintf "file ~s had failed tests\n" p)
@@ -90,18 +91,19 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
 
 (define (run-mod to-run)
   (vprintf "running ~s\n" to-run)
-  (eval (make-dyn-req-expr to-run))
+  (do-dyn-req-expr to-run)
   (vprintf "finished running ~s\n" to-run))
 
-(define (make-dyn-req-expr to-run)
+(define (do-dyn-req-expr to-run)
-  `(dynamic-require ',to-run 0))
+  (dynamic-require to-run 0))
 
 ;; [Listof Any] -> Void
 ;; remove any files not in paths from the raw coverage
 (define (remove-unneeded-results! names)
   (define c (get-raw-coverage))
   (for ([s (in-list (hash-keys c))]
-        #:when (not (member (srcloc-source s) names)))
+        ;; first here is like "srcloc-source", but its in list form...
+        #:when (not (member (first s) names)))
     (hash-remove! c s)))
 
 ;;; ---------------------- Compiling ---------------------------------
@@ -161,30 +163,40 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
 (define (clear-coverage!)
   (current-cover-environment (make-cover-environment)))
 
-(define (make-cover-environment [ns (make-base-namespace)])
+(define (make-kernel-namespace)
+  (define ns (make-empty-namespace))
+  (define cns (current-namespace))
+  (namespace-attach-module cns ''#%builtin ns)
+  ns)
+
+(define (make-cover-environment [ns (make-kernel-namespace)])
   (parameterize ([current-namespace ns])
     (define ann (load-annotate-top))
     (environment
      ns
      (make-cover-compile ns ann)
      ann
-     (load-raw-coverage)
+     (load-raw-coverage))))
-     (load-current-check-handler))))
 
 (define (get-annotate-top)
   (get-val environment-ann-top))
 (define (load-annotate-top)
-  (dynamic-require 'cover/strace 'annotate-top))
+  (make-annotate-top (load-raw-coverage) (load-cover-name)))
 
 (define (get-raw-coverage)
   (get-val environment-raw-cover))
 (define (load-raw-coverage)
   (dynamic-require 'cover/coverage 'coverage))
 
+(define (load-cover-name)
+  (dynamic-require 'cover/coverage 'cover-name))
+(define (load-cover-setter)
+  (dynamic-require 'cover/coverage '!))
+
+#;
 (define (get-check-handler-parameter)
-  (get-val environment-cch))
+  (namespace-variable-value (module->namespace 'rackunit)
-(define (load-current-check-handler)
+                            'current-check-handler))
-  (dynamic-require 'rackunit 'current-check-handler))
 
 (define (get-namespace)
   (get-val environment-namespace))
@@ -205,7 +217,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
 
     ;; filtered : (listof (list boolean srcloc))
     ;; remove redundant expressions
-    (define filtered (hash-map (get-raw-coverage) (λ (k v) (list v k))))
+    (define filtered (hash-map (get-raw-coverage) (λ (k v) (list v (apply make-srcloc k)))))
 
     (define out (make-hash))
 
@@ -215,7 +227,8 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
                     file
                     (lambda (l) (cons v l))
                     null))
-    out))
+    ;; Make the hash map immutable
+    (for/hash ([(k v) (in-hash out)]) (values k v))))
 
 (define current-cover-environment
   (make-parameter (make-cover-environment)))
@@ -253,6 +266,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
   (define ns (environment-namespace env))
   (parameterize ([current-cover-environment env]
                  [current-namespace ns])
+    (namespace-require 'racket/base)
     (test-begin
      (define file (path->string simple-multi/2.rkt))
      (define modpath file)

coverage.rkt

@@ -1,3 +1,4 @@
 (module coverage '#%kernel
-  (#%provide coverage)
+  (#%provide coverage cover-name)
+  (define-values (cover-name) (quote-syntax coverage))
   (define-values (coverage) (make-hash)))

scribblings/basics.scrbl

@@ -68,3 +68,5 @@ first is to include @racketmodname[scribble/manual] and @racket[planet] in the c
 exclude them from the output with the @Flag{e} flag. The other is to add the files that cause the
 cyclic dependencies to @racket[_test-omit-paths] or @racket[_cover-omit-paths] in that collections
 @filepath{info.rkt}.
+
+Cover will automatically skip any module declared @tech{cross-phase persistent}.

strace.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(provide (rename-out [in:annotate-top annotate-top]))
+(provide make-annotate-top)
 (require errortrace/stacktrace
          racket/function
          racket/syntax
@@ -7,92 +7,94 @@
          syntax/kerncase
          racket/runtime-path
          "private/file-utils.rkt"
-         "private/shared.rkt"
+         "private/shared.rkt")
-         "coverage.rkt")
 
-(define cover-name #'coverage)
+(define (make-annotate-top c cover-name)
-(define srcloc-name  #'make-srcloc)
+  (define (initialize-test-coverage-point stx)
+    (define srcloc (stx->srcloc stx))
+    (when srcloc
+      (hash-set! c srcloc #f)))
+  (define (with-mark src dest phase) dest)
+  (define test-coverage-enabled (make-parameter #t))
 
-(define (with-mark src dest phase) dest)
+  (define (test-covered stx)
-(define test-coverage-enabled (make-parameter #t))
+    (with-syntax ([c cover-name]
+                  [loc (stx->srcloc/stx stx)])
+      #'(#%plain-app hash-set! c loc #t)))
 
-(define (initialize-test-coverage-point stx)
+  (define profile-key (gensym))
-  (define srcloc (stx->srcloc stx))
-  (when srcloc
-    (hash-set! coverage srcloc #f)))
 
-(define (test-covered stx)
+  (define profiling-enabled (make-parameter #f))
-  (define loc/stx (stx->srcloc/stx stx))
+  (define initialize-profile-point void)
-  (with-syntax ([c cover-name]
+  (define (register-profile-start . a) #f)
-                [loc loc/stx])
+  (define register-profile-done void)
-    #'(#%plain-app hash-set! c loc #t)))
 
-(define profile-key (gensym))
 
-(define profiling-enabled (make-parameter #f))
+  (define (make-srcloc-maker f)
-(define initialize-profile-point void)
+    (lambda (stx)
-(define (register-profile-start . a) #f)
+      (and (syntax? stx)
-(define register-profile-done void)
+           (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
+                  (f src #f #f pos span))))))
 
-(define-values/invoke-unit/infer stacktrace@)
+  (define stx->srcloc
+    (make-srcloc-maker list))
 
-(define (make-srcloc-maker f)
+  (define stx->srcloc/stx
-  (lambda (stx)
+    (make-srcloc-maker
-    (and (syntax? stx)
+     (lambda (src a b pos span)
-         (let* ([orig-src (syntax-source stx)]
+       (with-syntax ([src src]
-                [src (if (path? orig-src) (path->string orig-src) orig-src)]
+                     [pos pos]
-                [pos (syntax-position stx)]
+                     [a a]
-                [span (syntax-span stx)])
+                     [b b]
-           (and pos
+                     [span span])
-                span
+         #'(quote (src a b pos span))))))
-                (f src #f #f pos span))))))
 
-(define stx->srcloc
+  (define (in:annotate-top annotate-top)
-  (make-srcloc-maker make-srcloc))
+    (lambda (stx phase)
+      (define e (add-cover-require stx))
+      (if e (annotate-clean (annotate-top e phase)) stx)))
 
-(define stx->srcloc/stx
+  (define (add-cover-require expr)
-  (make-srcloc-maker
+    (define inspector (variable-reference->module-declaration-inspector
-   (lambda (src a b pos span)
+                       (#%variable-reference)))
-     (with-syntax ([src src]
+    (let loop ([expr expr] [top #t])
-                   [pos pos]
+      (define disarmed (syntax-disarm expr inspector))
-                   [a a]
+      (kernel-syntax-case disarmed #f
-                   [b b]
+                          [(module name lang (#%module-begin e ...))
-                   [span span]
+                           (member '(#%declare #:cross-phase-persistent) (syntax->datum #'(e ...)))
-                   [make-srcloc srcloc-name])
+                           #f]
-       #'(make-srcloc src a b pos span)))))
+                          [(module name lang mb)
+                           (with-syntax ([cover cover-name])
+                             (syntax-case (syntax-disarm #'mb inspector) ()
+                               [(#%module-begin b ...)
+                                (with-syntax ([(body ...)
+                                               (map (lambda (e) (loop e #f)) (syntax->list #'(b ...)))])
+                                  (syntax-rearm
+                                   (namespace-syntax-introduce
+                                    (datum->syntax
+                                     expr
+                                     (syntax-e
+                                      #'(module name lang
+                                          (#%module-begin
+                                           (#%require (rename cover/coverage cover coverage))
+                                           body ...)))
+                                     expr expr))
+                                   expr))]))]
+                          [_ (if top #f expr)])))
 
-(define (in:annotate-top stx phase)
+  ;; in order to write modules to disk the top level needs to
-  (define e (add-cover-require stx))
+  ;; be a module. so we trust that the module is loaded and trim the expression
-  (if e (annotate-clean (annotate-top e phase)) stx))
+  (define (annotate-clean e)
+    (kernel-syntax-case e #f
+                        [(begin e mod)
+                         (eval #'e)
+                         #'mod]
+                        [_ e]))
 
-(define (add-cover-require expr)
+  (define-values/invoke-unit/infer stacktrace@)
-  (define inspector (variable-reference->module-declaration-inspector
+  (in:annotate-top annotate-top))
-                     (#%variable-reference)))
-  (let loop ([expr expr] [top #t])
-    (kernel-syntax-case (syntax-disarm expr inspector) #f
-      [(module name lang mb)
-       (with-syntax ([cover cover-name]
-                     [srcloc srcloc-name])
-         (syntax-case (syntax-disarm #'mb inspector) ()
-           [(#%module-begin b ...)
-            (with-syntax ([(body ...)
-                           (map (lambda (e) (loop e #f)) (syntax->list #'(b ...)))])
-              (syntax-rearm
-               (namespace-syntax-introduce
-                (quasisyntax/loc expr
-                  (module name lang
-                    (#%module-begin
-                     (#%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)
-  (kernel-syntax-case e #f
-    [(begin e mod)
-     (eval #'e)
-     #'mod]
-    [_ e]))