diff --git a/info.rkt b/info.rkt index 56a90fe..4e0331f 100644 --- a/info.rkt +++ b/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))) diff --git a/private/format-utils.rkt b/private/format-utils.rkt index ad9fec4..c92ec04 100644 --- a/private/format-utils.rkt +++ b/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!)))) diff --git a/tests/at-exp/at-exp.rkt b/tests/at-exp/at-exp.rkt new file mode 100644 index 0000000..ead7317 --- /dev/null +++ b/tests/at-exp/at-exp.rkt @@ -0,0 +1,2 @@ +#lang at-exp racket +@void{1} diff --git a/tests/at-exp/at-exp.rktl b/tests/at-exp/at-exp.rktl new file mode 100644 index 0000000..c5c5ef4 --- /dev/null +++ b/tests/at-exp/at-exp.rktl @@ -0,0 +1,2 @@ +() +() diff --git a/tests/main.rkt b/tests/main.rkt index 1466805..8c5e88c 100644 --- a/tests/main.rkt +++ b/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])