Merge pull request #61 from florence/support-at-exp

Support at exp, fixing #55

info.rkt

@@ -5,7 +5,7 @@
                "syntax-color-lib" "compiler-lib"))
 (define build-deps
   '("racket-doc" "scribble-lib" "typed-racket-doc" "htdp-lib"
-    "net-doc" "scribble-doc"))
+    "net-doc" "scribble-doc" "at-exp-lib"))
 
 (define raco-commands
   '(("cover" (submod cover/raco main) "a code coverage tool" 30)))

private/format-utils.rkt

@@ -8,6 +8,7 @@
          racket/set
          racket/bool
          syntax-color/racket-lexer
+         syntax-color/lexer-contract
          syntax/modread
          syntax/parse
          "shared.rkt")
@@ -47,11 +48,12 @@
   (with-input-from-file f
     (thunk
      (define lexer
-       (with-handlers ([exn:fail:read? (const racket-lexer)])
-         (define f (read-language))
-         (if f
-             (f 'color-lexer racket-lexer)
-             racket-lexer)))
+       (maybe-wrap-lexer
+        (with-handlers ([exn:fail:read? (const racket-lexer)])
+          (define f (read-language))
+          (if f
+              (f 'color-lexer racket-lexer)
+              racket-lexer))))
      (define irrelevant? (make-irrelevant? lexer f submods))
      (define file-length (string-length (file->string f)))
      (define cache
@@ -61,6 +63,13 @@
                        [else (raw-covered? i c)]))))
      cache)))
 
+(define (maybe-wrap-lexer lexer)
+  (if (procedure-arity-includes? lexer 3)
+      lexer
+      (λ (in offset mode)
+        (define-values (a b c d e) (lexer in))
+        (values a b c d e 0 #f))))
+
 ;; Lexer(in the sence of color:text<%>) InputPort (Maybe (Listof Symbol)) -> (Natural -> Boolean)
 ;; builds a function that determines if a given location in that port is irrelivent.
 (define (make-irrelevant? lexer f submods)
@@ -72,15 +81,19 @@
 
   (define offset (make-byte->str-offset str))
 
-  (let loop ()
-    (define-values (v type _m start end) (lexer for-lex))
+  (let loop ([mode #f])
+    (define-values (v type _m start end backup-dist new-mode/ds)
+      (lexer for-lex 0 mode))
+    (define new-mode (if (dont-stop? new-mode/ds)
+                         (dont-stop-val new-mode/ds)
+                         new-mode/ds))
     (case type
       [(eof) (void)]
       [(comment sexp-comment no-color white-space)
        (for ([i (in-range (- start (offset start)) (- end (offset end)))])
          (set-add! s (+ init-offset i)))
-       (loop)]
-      [else (loop)]))
+       (loop new-mode)]
+      [else (loop new-mode)]))
   (define stx
     (with-input-from-file f
       (thunk (with-module-reading-parameterization read-syntax))))
@@ -149,19 +162,20 @@
 
 (module+ test
   (define-runtime-path path2 "../tests/prog.rkt")
-  (test-begin
-   (define f (path->string (simplify-path path2)))
-   (test-files! f)
-   (define coverage (hash-ref (get-test-coverage) f))
-   (define covered? (make-covered? coverage f))
-   (check-equal? (covered? 14) 'irrelevant)
-   (check-equal? (covered? 14 #:byte? #t) 'irrelevant)
-   (check-equal? (covered? 17) 'irrelevant)
-   (check-equal? (covered? 28) 'irrelevant)
-   (check-equal? (covered? 35) 'covered)
-   (check-equal? (covered? 50) 'uncovered)
-   (check-equal? (covered? 51 #:byte? #t) 'uncovered)
-   (check-equal? (covered? 52) 'irrelevant)
-   (check-equal? (covered? 53) 'irrelevant)
-   (check-equal? (covered? 54) 'irrelevant)
-   (clear-coverage!)))
+  (parameterize ([irrelevant-submodules #f])
+    (test-begin
+     (define f (path->string (simplify-path path2)))
+     (test-files! f)
+     (define coverage (hash-ref (get-test-coverage) f))
+     (define covered? (make-covered? coverage f))
+     (check-equal? (covered? 14) 'irrelevant)
+     (check-equal? (covered? 14 #:byte? #t) 'irrelevant)
+     (check-equal? (covered? 17) 'irrelevant)
+     (check-equal? (covered? 28) 'irrelevant)
+     (check-equal? (covered? 35) 'covered)
+     (check-equal? (covered? 50) 'uncovered)
+     (check-equal? (covered? 51 #:byte? #t) 'uncovered)
+     (check-equal? (covered? 52) 'irrelevant)
+     (check-equal? (covered? 53) 'irrelevant)
+     (check-equal? (covered? 54) 'irrelevant)
+     (clear-coverage!))))

tests/at-exp/at-exp.rkt

@@ -0,0 +1,2 @@
+#lang at-exp racket
+@void{1}

tests/at-exp/at-exp.rktl

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

tests/main.rkt

@@ -3,7 +3,8 @@
 ;; for every .rkt file in those directories it loads
 ;; tests that file and checks its coverage against an
 ;; .rktl file of the same name
-(require (only-in "../main.rkt" test-files! clear-coverage! get-test-coverage irrelevant-submodules)
+(require (only-in "../main.rkt" test-files! clear-coverage! get-test-coverage irrelevant-submodules
+                  make-covered?)
          "../private/file-utils.rkt"
          racket/runtime-path rackunit)
 
@@ -27,15 +28,17 @@
       (define-values (expected-coverage expected-uncoverage)
         (with-input-from-file cover (lambda () (values (ranges->numbers (read))
                                                        (ranges->numbers (read))))))
+      (define covered? (make-covered? actual-coverage program))
+      (define (test-range range type)
+        (for ([i range])
+          (define v (covered? i))
+          (unless (eq? v 'irrelevant)
+            (check-equal? v type
+                          (format "expected char ~a to be covered, but it was not, in: ~s"
+                                  i program)))))
       (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 program)))
-       (for ([i expected-uncoverage])
-         (check-true (not (covered? i actual-coverage))
-                     (format "expected char ~a to be uncovered, but it was, in: ~s"
-                             i program)))))
+       (test-range expected-coverage 'covered)
+       (test-range expected-uncoverage 'uncovered)))
 
     (clear-coverage!))
 
@@ -51,20 +54,8 @@
          (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 l))]
-             [srcloc (in-value (second l))]
-             #: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" "simple-multi" "syntax"))
+  (define-runtime-path-list test-dirs '("basic" "simple-multi" "syntax" "at-exp"))
   (for-each (compose test-dir path->string) test-dirs)
   (define-runtime-path submods "submods")
   (parameterize ([irrelevant-submodules null])