refactor and fix regression

cover.rkt

@@ -35,6 +35,8 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
          "strace.rkt")
 
 (struct environment (namespace compile ann-top raw-cover))
+;; A special structure used for communicating information about programs that call `exit`
+(struct an-exit (code))
 
 ;;; ---------------------- Running Files ---------------------------------
 
@@ -52,61 +54,68 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
         (match p
           [(cons p _) p]
           [_ p])))
-    (define tests-failed #f)
-    (define old-check (current-check-handler))
-    (struct an-exit (code))
+    (define tests-failed
       (parameterize* ([current-load/use-compiled (make-cover-load/use-compiled abs-names)]
                       [current-output-port
                        (if (verbose) (current-output-port) (open-output-nowhere))]
-                    [exit-handler (lambda (x) (raise (an-exit x)))]
                       [current-namespace (get-namespace)])
-      (for ([the-file (in-list abs-names)])
-        #|
-        (define f (path->string (file-name-from-path p)))
-        (define ext (bytes->string/locale (filename-extension f)))
-        (define name (string->symbol (substring f 0 (- (string-length f) 1 (string-length ext)))))
-        ((current-load/use-compiled)
-         p
-         name)
-        |#
-        (dynamic-require `(file ,(if (path? the-file) (path->string the-file) the-file)) (void)))
-      (for ([p (in-list abs)])
-        (vprintf "attempting to run ~s\n" p)
-        (define the-file (if (list? p) (car p) p))
-        (define argv (if (list? p) (cadr p) #()))
-        (parameterize ([current-command-line-arguments argv]
-                       [current-check-handler ;(get-check-handler-parameter)
-                        (lambda x
-                          (set! tests-failed #t)
-                          (vprintf "file ~s had failed tests\n" p)
-                          (apply old-check x))])
-          (with-handlers ([(lambda (x) (or (not (exn? x)) (exn:fail? x)))
-                           (lambda (x)
-                             (cond [(an-exit? x)
-                                    (vprintf "file ~s exited code ~s" p (an-exit-code x))]
-                                   [else
-                                    (set! tests-failed #t)
-                                    (error-display x)]))])
-            (vprintf "running file: ~s with args: ~s\n" the-file argv)
-            (run-file the-file submod-name)))))
+        (for ([f (in-list abs-names)])
+          (compile-file f))
+        (for/fold ([tests-failed #f]) ([f (in-list abs)])
+          (define failed? (handle-file f submod-name))
+          (and failed? tests-failed))))
     (vprintf "ran ~s\n" files)
     (remove-unneeded-results! abs-names)
     (not tests-failed)))
 
 ;;; ---------------------- Running Aux ---------------------------------
 
-(define (run-file the-file submod-name)
-  (define sfile `(file ,(if (path? the-file) (path->string the-file) the-file)))
+
+;; PathString -> Void
+(define (compile-file the-file)
+  (dynamic-require (build-file-require the-file) (void)))
+
+;; (or PathString (list PathString Vector)) Symbol -> Boolean
+;; returns if any tests failed or errors occured
+(define (handle-file maybe-path submod-name)
+  (define tests-failed #f)
+  (define old-check (current-check-handler))
+  (vprintf "attempting to run ~s\n" maybe-path)
+  (define the-file (if (list? maybe-path) (first maybe-path) maybe-path))
+  (define argv (if (list? maybe-path) (second maybe-path) #()))
+  (with-handlers ([(lambda (x) (or (not (exn? x)) (exn:fail? x)))
+                   (lambda (x)
+                     (cond [(an-exit? x)
+                            (vprintf "file ~s exited code ~s" maybe-path (an-exit-code x))]
+                           [else
+                            (set! tests-failed #t)
+                            (error-display x)]))])
+    (parameterize ([current-command-line-arguments argv]
+                   [exit-handler (lambda (x) (raise (an-exit x)))]
+                   [current-check-handler ;(get-check-handler-parameter)
+                    (lambda x
+                      (set! tests-failed #t)
+                      (vprintf "file ~s had failed tests\n" maybe-path)
+                      (apply old-check x))])
+      (vprintf "running file: ~s with args: ~s\n" the-file argv)
+      (exec-file the-file submod-name)))
+  tests-failed)
+
+;; PathString Symbol -> Void
+(define (exec-file the-file submod-name)
+  (define sfile (build-file-require the-file))
   (define submod `(submod ,sfile ,submod-name))
   (run-mod (if (module-declared? submod #t) submod sfile)))
 
+;; ModulePath -> Any
 (define (run-mod to-run)
   (vprintf "running ~s\n" to-run)
-  (do-dyn-req-expr to-run)
+  (dynamic-require to-run 0)
   (vprintf "finished running ~s\n" to-run))
 
-(define (do-dyn-req-expr to-run)
-  (dynamic-require to-run 0))
+;; PathString -> ModulePath
+(define (build-file-require the-file)
+  `(file ,(if (path? the-file) (path->string the-file) the-file)))
 
 ;; [Listof Any] -> Void
 ;; remove any files not in paths from the raw coverage

strace.rkt

@@ -11,21 +11,14 @@
          "private/file-utils.rkt"
          "private/shared.rkt")
 
-(define (make-annotate-top c cover-name)
-  (define (with-mark src dest phase) dest)
-  (define test-coverage-enabled (make-parameter #t))
 
+(define (make-annotate-top c cover-name)
   (define lift-name #'do-lift)
   (define set-box-name #'set-box!)
   (define hash-ref-name #'hash-ref)
 
+  ;;  -------- Specific `stacktrace^` Imports --------------
 
-  (define profile-key (gensym))
-
-  (define profiling-enabled (make-parameter #f))
-  (define initialize-profile-point void)
-  (define (register-profile-start . a) #f)
-  (define register-profile-done void)
   (define (initialize-test-coverage-point stx)
     (define srcloc (stx->srcloc stx))
     (when srcloc
@@ -41,32 +34,8 @@
       #`(#%plain-app set-box! (do-lift (#%plain-app hash-ref c loc)) #t)))
 
 
-  (define (make-srcloc-maker f)
-    (lambda (stx)
-      (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
-                  (f src #f #f pos span))))))
-
-  (define stx->srcloc
-    (make-srcloc-maker list))
-
-  (define stx->srcloc/stx
-    (make-srcloc-maker
-     (lambda (src a b pos span)
-       (with-syntax ([src src]
-                     [pos pos]
-                     [a a]
-                     [b b]
-                     [span span])
-         #'(quote (src a b pos span))))))
-
-  (define o (current-output-port))
-  (define (in:annotate-top annotate-top)
+  ;;  -------- Cover's Specific Annotators --------------
+  (define (make-cover-annotate-top annotate-top)
     (lambda (stx phase)
       (define e (add-cover-require stx))
       (if e (expand-syntax (annotate-clean (annotate-top (expand-syntax e) phase))) stx)))
@@ -76,7 +45,8 @@
                        (#%variable-reference)))
     (let loop ([expr expr] [top #t])
       (define disarmed (syntax-disarm expr inspector))
-      (kernel-syntax-case disarmed #f
+      (kernel-syntax-case
+       disarmed #f
        [(module name lang (#%module-begin e ...))
         (member '(#%declare #:cross-phase-persistent) (syntax->datum #'(e ...)))
         #f]
@@ -108,21 +78,11 @@
                       (#%module-begin add ... body ...)))
                (rebuild-syntax stx disarmed expr))]))]
        [_ (if top #f expr)])))
-
-  (define (rebuild-syntax stx disarmed armed)
-    (syntax-rearm
-     (namespace-syntax-introduce
-      (datum->syntax
-       disarmed
-       (syntax-e stx)
-       disarmed
-       disarmed))
-     armed))
-
   ;; 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
+    (kernel-syntax-case
+     e #f
      [(begin e mod)
       (begin
         (syntax-case #'e (#%plain-app set-box! do-lift make-srcloc hash-ref)
@@ -132,5 +92,56 @@
         #'mod)]
      [_ e]))
 
+
+  ;; ---- IN ----
   (define-values/invoke-unit/infer stacktrace@)
-  (in:annotate-top annotate-top))
+  (make-cover-annotate-top annotate-top))
+
+
+
+
+
+;;  -------- Generic `stacktrace^` Imports --------------
+(define (with-mark src dest phase) dest)
+(define test-coverage-enabled (make-parameter #t))
+(define profile-key (gensym))
+(define profiling-enabled (make-parameter #f))
+(define initialize-profile-point void)
+(define (register-profile-start . a) #f)
+(define register-profile-done void)
+
+;;  -------- Annotation Helpers --------------
+
+(define (make-srcloc-maker f)
+  (lambda (stx)
+    (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
+                (f src #f #f pos span))))))
+
+(define stx->srcloc
+  (make-srcloc-maker list))
+
+(define stx->srcloc/stx
+  (make-srcloc-maker
+   (lambda (src a b pos span)
+     (with-syntax ([src src]
+                   [pos pos]
+                   [a a]
+                   [b b]
+                   [span span])
+       #'(quote (src a b pos span))))))
+
+(define (rebuild-syntax stx disarmed armed)
+  (syntax-rearm
+   (namespace-syntax-introduce
+    (datum->syntax
+     disarmed
+     (syntax-e stx)
+     disarmed
+     disarmed))
+   armed))

tests/do-dont-run.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require rackunit "../main.rkt" racket/runtime-path)
+(require rackunit "../main.rkt" racket/runtime-path racket/port)
 (define-runtime-path dont-run.rkt "dont-run.rkt")
 (check-not-exn
- (lambda () (test-files! (path->string dont-run.rkt))))
+ (lambda ()
+   (check-true (test-files! (path->string dont-run.rkt)))))