test and base expantion bugs

main.rkt

@@ -1,39 +1,55 @@
 #lang racket/base
-(provide test-files clear-coverage!)
+(provide test-files! clear-coverage! get-test-coverage)
+(require (for-syntax racket/base))
 (require racket/dict
          racket/function
          syntax/modread
          syntax/parse
          "coverage.rkt"
-         "strace.rkt")
+         "strace.rkt"
+         racket/runtime-path)
 
 
-(define ns (make-base-empty-namespace))
-(namespace-attach-module (current-namespace) "coverage.rkt" ns)
 
-(define (test-files . paths)
+(define ns (make-base-namespace))
+(define-runtime-path cov "coverage.rkt")
+(namespace-attach-module (current-namespace) cov ns)
+
+(define-syntax (with-ns stx)
+  (syntax-case stx ()
+    [(_ b ...)
+     #'(parameterize ([current-namespace ns])
+         b ...)]))
+
+;; PathString * -> Void
+;; Test files and build coverage map
+(define (test-files! . paths)
   (for ([p paths])
     (define stx
       (with-module-reading-parameterization
           (thunk (read-syntax p (open-input-file p)))))
     (define-values (name anned)
-      (syntax-parse (expand stx)
+      (syntax-parse (with-ns (expand stx))
         #:datum-literals (module)
         [(~and s (module name:id lang forms ...))
          (values (syntax-e #'name)
                  (annotate-top #'s (namespace-base-phase ns)))]))
     (eval-syntax anned ns)
     ;; TODO run test/given submodule
-    (parameterize ([current-namespace ns])
-      (namespace-require `',name)))
-  coverage)
+    (with-ns (namespace-require `',name))))
 
+;; -> Void
+;; clear coverage map
 (define (clear-coverage!)
   (dict-clear! coverage)
-  (set! ns (make-base-empty-namespace))
-  (namespace-attach-module (current-namespace) "coverage.rkt" ns))
+  (set! ns (make-base-namespace))
+  (namespace-attach-module (current-namespace) cov ns))
 
-(define (test-coverage-annotations)
+;; -> [Hashof PathString (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
@@ -47,29 +63,30 @@
                          [span (syntax-span stx)])
                      (and pos
                           span
-                          #;
-                          (hash-ref! port-name-cache src
-                                     (λ () (send (get-defs) port-name-matches? src)))
                           (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
-    ;; actions-ht : (list src number number) -> (list boolean syntax)
-    (let ([actions-ht (make-hash)])
-      (for-each
-       (λ (pr)
-         (let* ([on? (list-ref pr 0)]
-                [key (list-ref pr 1)]
-                [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)
-      (hash-map actions-ht (λ (k v) (list v k)))))
-  filtered)
+  (define filtered (hash-map actions-ht (λ (k v) (list v k))))
+
+  (for/hash ([v filtered])
+    (values (srcloc-source (cadr v))
+            v)))

tests/basic/coverage.rktl

@@ -0,0 +1 @@
+((1 21))

tests/main.rkt

@@ -0,0 +1,43 @@
+#lang racket
+(require better-test racket/runtime-path rackunit)
+
+(define (test-dir d)
+  (define program (string-append d "/prog.rkt"))
+  (define covered (string-append d "/coverage.rktl"))
+
+  (test-files! program)
+
+  (define actual-coverage (hash-ref (get-test-coverage) program))
+  (define expected-coverage (ranges->numbers (with-input-from-file covered read)))
+
+  (test-begin
+   (for ([i expected-coverage])
+     (check-true (covered? i actual-coverage)
+                 (format "expected char ~a to be covered, but it was not, in: ~s"
+                         i d))))
+
+  (clear-coverage!))
+
+(define (ranges->numbers range)
+  (match range
+    [(list) null]
+    [(cons (list a b) r)
+     (if (equal? a b)
+         (ranges->numbers r)
+         (cons a (ranges->numbers (cons (list (add1 a) b) r))))]))
+
+(define (covered? i map)
+  (for*/and ([l map]
+             [b (in-value (first map))]
+             [srcloc (in-value (second map))]
+             #:when (within? i srcloc))
+    b))
+
+(define (within? i src)
+  (match src
+    [(srcloc _ _ _ start range)
+     (>= start i (+ start range))]))
+
+(module+ test
+  (define-runtime-path-list test-dirs '("basic"))
+  (for-each (compose test-dir path->string) test-dirs))