From 2ae091805ef706b2f9a1adc678f1b6aaf71aacdb Mon Sep 17 00:00:00 2001 From: Spencer Florence Date: Sat, 27 Jun 2015 18:04:16 -0500 Subject: [PATCH] Fixes #79 #77 and #59 Roughly this commit switches the instrumentation mechanism to use logging instead of a global hash table. This allows cover to work across phases, and means that cover no longer needs to lift definitions at compile time, fixing some submodule bugs. --- cover.rkt | 170 +++++++++++++++++++++++------------------- coverage.rkt | 4 - info.rkt | 4 +- private/coveralls.rkt | 60 +++++++-------- private/html/html.rkt | 94 ++++++++++++----------- private/shared.rkt | 7 +- strace.rkt | 80 ++++++++++---------- tests/do-eval.rkt | 4 +- tests/do-exit.rkt | 4 +- tests/do-syntax.rkt | 6 +- tests/error-file.rkt | 3 +- tests/error.rkt | 7 +- tests/main.rkt | 45 ++++++----- tests/nested.rkt | 34 +++++++++ tests/provide.rkt | 5 ++ tests/use-provide.rkt | 3 + 16 files changed, 295 insertions(+), 235 deletions(-) delete mode 100644 coverage.rkt create mode 100644 tests/nested.rkt create mode 100644 tests/provide.rkt create mode 100644 tests/use-provide.rkt diff --git a/cover.rkt b/cover.rkt index 60bd56e..30e8606 100644 --- a/cover.rkt +++ b/cover.rkt @@ -9,9 +9,8 @@ #| This module implements code coverage. It works by compiling and running the given modules with in a -separate namespace errortrace annotations that write coverage information to a hashmap exported from -in "coverage.rkt". This raw coverage information is converted to a usable form by -`get-test-coverage`. +separate namespace errortrace annotations that log coverage information. This raw coverage +information is converted to a usable form by `get-test-coverage`. |# @@ -27,7 +26,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b racket/runtime-path racket/match racket/path - rackunit + rackunit/log unstable/error racket/list racket/port @@ -40,8 +39,10 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b ;; a `namespace`, which shall always have `coverage.rkt` and ''#%builtin attached ;; a handler for `current-compile` ;; a function that will annoate expanded code -;; a reference to the raw coverage map -(struct environment (namespace compile ann-top raw-cover)) +;; a topic for logs to be reiceved on. Must be unique for every environment +;; a log receiver, for receiving log events about coverage +;; a hash map to store raw coverage read from the receiver +(struct environment (namespace compile ann-top receiver topic raw-coverage)) ;; A special structure used for communicating information about programs that call `exit` ;; `code` is the exit code that `exit` was called with (struct an-exit (code)) @@ -62,8 +63,9 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (match p [(cons p _) p] [_ p]))) + (define cover-load/use-compiled (make-cover-load/use-compiled abs-names)) (define tests-failed - (parameterize* ([current-load/use-compiled (make-cover-load/use-compiled abs-names)] + (parameterize* ([current-load/use-compiled cover-load/use-compiled] [current-output-port (if (verbose) (current-output-port) (open-output-nowhere))] [current-namespace (get-namespace)]) @@ -71,9 +73,8 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (compile-file f)) (for/fold ([tests-failed #f]) ([f (in-list abs)]) (define failed? (handle-file f submod-name)) - (and failed? tests-failed)))) + (or failed? tests-failed)))) (vprintf "ran ~s\n" files) - (remove-unneeded-results! abs-names) (not tests-failed))) ;;; ---------------------- Running Aux --------------------------------- @@ -81,33 +82,42 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b ;; PathString -> Void (define (compile-file the-file) - (dynamic-require (build-file-require the-file) (void))) + (parameterize ([current-compile (get-compile)] + [use-compiled-file-paths + (cons (build-path "compiled" "cover") + (use-compiled-file-paths))]) + (dynamic-require (build-file-require the-file) (void)))) ;; (or PathString (list PathString Vector)) Symbol -> Boolean -;; returns if any tests failed or errors occured +;; returns true 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 tests-errored #f) + (vprintf "attempting to run ~s in environment ~s\n" maybe-path (get-topic)) (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))) + (with-handlers ([(lambda (x) (not (exn:break? x))) (lambda (x) (cond [(an-exit? x) (vprintf "file ~s exited code ~s" maybe-path (an-exit-code x))] [else - (set! tests-failed #t) + (set! tests-errored #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))]) + [exit-handler (lambda (x) (raise (an-exit x)))]) (vprintf "running file: ~s with args: ~s\n" the-file argv) (exec-file the-file submod-name))) - tests-failed) + (define test-log (get-test-log)) + (or tests-errored + (let ([lg (test-log)]) + (and (not (= 0 (car lg))) + (not (= 0 (cdr lg))))))) + +(define (get-test-log) + (with-handlers ([exn:fail? (lambda _ + (lambda () (cons 0 0)))]) + (parameterize ([current-namespace (get-namespace)]) + (module->namespace 'rackunit/log);make sure its loaded first + (dynamic-require 'rackunit/log 'test-log)))) ;; PathString Symbol -> Void (define (exec-file the-file submod-name) @@ -117,7 +127,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b ;; ModulePath -> Any (define (run-mod to-run) - (vprintf "running ~s\n" to-run) + (vprintf "running ~s in envoronment ~s\n" to-run (get-topic)) (dynamic-require to-run 0) (vprintf "finished running ~s\n" to-run)) @@ -125,43 +135,30 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (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 -(define (remove-unneeded-results! names) - (define c (get-raw-coverage)) - (for ([s (in-list (hash-keys c))] - ;; first here is like "srcloc-source", but its in list form... - #:when (not (member (first s) names))) - (hash-remove! c s))) - ;;; ---------------------- Compiling --------------------------------- -;; (U [Listof Path] #f) -> Loader Compiler -;; returns a value that can be set of `current-load/use-compiled` +;; (U [Listof Path] #f) -> load/use-compiled +;; returns a value that can be set to `current-load/use-compiled` ;; forces the given files to be recompiled whenever load/use-compiled is called (define (make-cover-load/use-compiled paths) (define load/use-compiled (current-load/use-compiled)) - (define load (current-load)) - (define cover-compile (get-compile)) - (define cover-use-compiled-file-paths - (cons (build-path "compiled" "cover") - (use-compiled-file-paths))) - (lambda (path sym) - (define abs (->absolute path)) - (define lst (explode-path abs)) - (define dir-list (take lst (sub1 (length lst)))) - (parameterize ([current-load-relative-directory (apply build-path dir-list)]) - (if (implies paths (member abs paths)) - (parameterize ([current-compile cover-compile] - [use-compiled-file-paths - cover-use-compiled-file-paths]) - (load path sym)) - (load/use-compiled path sym))))) + (define (use-cover-compile? path) + (member (->absolute path) paths)) + (define cover-load/use-compiled + (lambda (path sym) + (define abs (->absolute path)) + (define lst (explode-path abs)) + (define dir-list (take lst (sub1 (length lst)))) + (parameterize ([current-load-relative-directory (apply build-path dir-list)]) + (if (use-cover-compile? path) + ((current-load) path sym) + (load/use-compiled path sym))))) + cover-load/use-compiled) ;; -> Compiler ;; makes a value sutable for current-compile, such that compile ;; annotates the source code with annotate-top. meant to be called -;; only by initialize-cover-environment +;; only by make-cover-environment (define (make-cover-compile ns annotate-top) (define compile (current-compile)) (define reg (namespace-module-registry ns)) @@ -175,12 +172,13 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (not (equal? phase (namespace-base-phase (current-namespace))))) e] [else - (vprintf "compiling ~s with coverage annotations\n" + (vprintf "compiling ~s with coverage annotations in enviornment ~s\n" (if (not (syntax? e)) e (or (syntax-source-file-name e) (syntax-source e) - (syntax->datum e)))) + (syntax->datum e))) + (get-topic)) (annotate-top (if (syntax? e) (expand-syntax e) (datum->syntax #f e)) phase)])) (compile to-compile immediate-eval?))) @@ -194,12 +192,20 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (define (make-cover-environment [ns (make-empty-namespace)]) (kernelize-namespace! ns) (parameterize ([current-namespace ns]) - (define ann (load-annotate-top)) + ;; we gensym the topic to isolate diverent coverage + ;; instances from each other + (define topic (gensym)) + (define ann (make-annotate-top topic)) (environment ns (make-cover-compile ns ann) ann - (load-raw-coverage)))) + (make-receiver topic) + topic + (make-hash)))) + +(define (make-receiver topic) + (make-log-receiver (current-logger) 'info topic)) (define (kernelize-namespace! ns) (define cns (current-namespace)) @@ -208,16 +214,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (define (get-annotate-top) (get-val environment-ann-top)) (define (load-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)) + (make-annotate-top)) (define (get-namespace) (get-val environment-namespace)) @@ -228,20 +225,39 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (define (get-val access) (access (current-cover-environment))) +(define (get-receiver) + (get-val environment-receiver)) + +(define (get-raw-coverage-map) + (get-val environment-raw-coverage)) + +(define (get-topic) + (get-val environment-topic)) + (struct coverage-wrapper (map function) #:property prop:procedure (struct-field-index function)) ;; -> coverage/c -;; returns a hash of file to a list, where the first of the list is if -;; that srcloc was covered or not -;; based on /drracket/drracket/private/debug.rkt (define (get-test-coverage [env (current-cover-environment)]) (parameterize ([current-cover-environment env]) (vprintf "generating test coverage\n") + (define raw-coverage (get-raw-coverage-map)) + (define r (get-receiver)) + + (let loop () + (match (sync/timeout (lambda () #f) r) + [(vector info type data _) + (cond [(regexp-match? (regexp-quote logger-init-message) type) + (unless (hash-has-key? raw-coverage data) + (hash-set! raw-coverage data #f))] + [(regexp-match? (regexp-quote logger-covered-message) type) + (hash-set! raw-coverage data #t)]) + (loop)] + [#f (void)])) ;; filtered : (listof (list boolean srcloc)) - (define filtered (hash-map (get-raw-coverage) - (λ (k v) (list (unbox v) (apply make-srcloc k))))) + (define filtered (hash-map raw-coverage + (λ (k v) (list v (apply make-srcloc k))))) (define out (make-hash)) @@ -251,6 +267,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b file (lambda (l) (cons v l)) null)) + ;; Make the hash map immutable (define coverage (for/hash ([(k v) (in-hash out)]) (values k v))) (define file-map (make-hash)) @@ -281,8 +298,9 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (check-false (ormap file-exists? compiled)) (check-not-exn (lambda () - (parameterize ([current-load/use-compiled - (make-cover-load/use-compiled (list (->absolute prog.rkt)))] + (define l/c (make-cover-load/use-compiled (list (->absolute prog.rkt)))) + (parameterize ([current-load/use-compiled l/c] + [current-compile (get-compile)] [current-namespace (get-namespace)]) (managed-compile-zo prog.rkt)))) (check-true (andmap file-exists? compiled))))) @@ -302,14 +320,16 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (test-begin (define file (path->string simple-multi/2.rkt)) (define modpath file) - (parameterize ([current-load/use-compiled - (make-cover-load/use-compiled (list file))]) + (define l/c (make-cover-load/use-compiled (list file))) + (parameterize ([current-load/use-compiled l/c] + [current-compile (get-compile)]) (namespace-require `(file ,modpath))) (check-equal? (eval `(two)) 10) (define x (get-test-coverage env)) (define covered? (curry x file)) (for ([_ (in-string (file->string file))] [i (in-naturals 1)]) + (check-not-exn (thunk (covered? i))) (define c (covered? i)) (check-true (or (eq? c 'covered) (eq? c 'irrelevant)) diff --git a/coverage.rkt b/coverage.rkt deleted file mode 100644 index 8b10caa..0000000 --- a/coverage.rkt +++ /dev/null @@ -1,4 +0,0 @@ -(module coverage '#%kernel - (#%provide coverage cover-name) - (define-values (cover-name) (quote-syntax coverage)) - (define-values (coverage) (make-hash))) diff --git a/info.rkt b/info.rkt index a02c6b7..f3f936a 100644 --- a/info.rkt +++ b/info.rkt @@ -13,7 +13,7 @@ (define scribblings '(("scribblings/cover.scrbl" (multi-page)))) (define test-omit-paths (list "tests/error-file.rkt" "scribblings")) -(define cover-omit-paths (list "coverage.rkt")) +(define cover-omit-paths (list "tests/nested.rkt")) (define cover-formats '(("html" cover generate-html-coverage) ("coveralls" cover generate-coveralls-coverage) @@ -21,4 +21,4 @@ (define test-command-line-arguments '(("tests/arg.rkt" ("a")))) -(define version "2.0.1") +(define version "2.0.2") diff --git a/private/coveralls.rkt b/private/coveralls.rkt index 4e6cf28..983931c 100644 --- a/private/coveralls.rkt +++ b/private/coveralls.rkt @@ -83,21 +83,20 @@ (module+ test (test-begin - (parameterize ([current-directory root]) - (after - (define file (path->string (simplify-path tests/prog.rkt))) - (test-files! (path->string (simplify-path tests/prog.rkt))) - (define coverage (get-test-coverage)) - (define report - (with-env ("COVERALLS_REPO_TOKEN" "abc") - (generate-coveralls-report coverage (list (->absolute file))))) - (check-equal? - (hash-ref report 'source_files) - (list (hasheq 'source (file->string tests/prog.rkt) - 'coverage (line-coverage coverage file) - 'name "tests/prog.rkt"))) - (check-equal? (hash-ref report 'repo_token) "abc") - (clear-coverage!))))) + (parameterize ([current-directory root] + [current-cover-environment (make-cover-environment)]) + (define file (path->string (simplify-path tests/prog.rkt))) + (test-files! (path->string (simplify-path tests/prog.rkt))) + (define coverage (get-test-coverage)) + (define report + (with-env ("COVERALLS_REPO_TOKEN" "abc") + (generate-coveralls-report coverage (list (->absolute file))))) + (check-equal? + (hash-ref report 'source_files) + (list (hasheq 'source (file->string tests/prog.rkt) + 'coverage (line-coverage coverage file) + 'name "tests/prog.rkt"))) + (check-equal? (hash-ref report 'repo_token) "abc")))) ;; -> [Hasheq String String ;; Determine the type of build (e.g. repo token, travis, etc) and return the appropriate metadata @@ -139,18 +138,17 @@ (module+ test (test-begin - (parameterize ([current-directory root]) - (after - (define file (path->string (simplify-path tests/prog.rkt))) - (test-files! (path->string (simplify-path tests/prog.rkt))) - (define coverage (get-test-coverage)) - (check-equal? - (generate-source-files coverage (list file)) - (hasheq 'source_files - (list (hasheq 'source (file->string tests/prog.rkt) - 'coverage (line-coverage coverage file) - 'name "tests/prog.rkt")))) - (clear-coverage!))))) + (parameterize ([current-directory root] + [current-cover-environment (make-cover-environment)]) + (define file (path->string (simplify-path tests/prog.rkt))) + (test-files! (path->string (simplify-path tests/prog.rkt))) + (define coverage (get-test-coverage)) + (check-equal? + (generate-source-files coverage (list file)) + (hasheq 'source_files + (list (hasheq 'source (file->string tests/prog.rkt) + 'coverage (line-coverage coverage file) + 'name "tests/prog.rkt"))))))) ;; CoverallsCoverage = Nat | json-null @@ -181,10 +179,10 @@ (module+ test (define-runtime-path path "../tests/basic/not-run.rkt") (let () - (define file (path->string (simplify-path path))) - (test-files! file) - (check-equal? (line-coverage (get-test-coverage) file) '(1 0)) - (clear-coverage!))) + (parameterize ([current-cover-environment (make-cover-environment)]) + (define file (path->string (simplify-path path))) + (test-files! file) + (check-equal? (line-coverage (get-test-coverage) file) '(1 0))))) (define (hash-merge h1 h2) (for/fold ([res h1]) ([(k v) h2]) (hash-set res k v))) diff --git a/private/html/html.rkt b/private/html/html.rkt index 9faa199..06fa567 100644 --- a/private/html/html.rkt +++ b/private/html/html.rkt @@ -34,14 +34,13 @@ (delete-directory/files asset-path #:must-exist? #f) (copy-directory/files assets asset-path)) (module+ test - (after - (parameterize ([current-directory root] [verbose #t]) - (define temp-dir (make-temporary-file "covertmp~a" 'directory)) - (test-files! tests/basic/prog.rkt) - (define coverage (get-test-coverage)) - (generate-html-coverage coverage (list (->absolute tests/basic/prog.rkt)) temp-dir) - (check-true (file-exists? (build-path temp-dir "tests/basic/prog.html")))) - (clear-coverage!))) + (parameterize ([current-directory root] + [current-cover-environment (make-cover-environment)]) + (define temp-dir (make-temporary-file "covertmp~a" 'directory)) + (test-files! tests/basic/prog.rkt) + (define coverage (get-test-coverage)) + (generate-html-coverage coverage (list (->absolute tests/basic/prog.rkt)) temp-dir) + (check-true (file-exists? (build-path temp-dir "tests/basic/prog.html"))))) (define (get-files coverage files dir) (define file-list @@ -70,23 +69,22 @@ (module+ test (test-begin - (parameterize ([current-directory root]) - (after - (define f (path->string (simplify-path tests/basic/prog.rkt))) - (define d "coverage") - (test-files! f) - (define coverage (get-test-coverage)) - (define files (get-files coverage (list f) d)) - (define (maybe-path->string p) - (if (string? p) p (path->string p))) - (check-equal? (list->set (map (compose maybe-path->string first) - files)) - (set "coverage/index.html" - "coverage/tests/basic/prog.html")) - (check-equal? (list->set (map (compose maybe-path->string second) files)) - (set "coverage" - "coverage/tests/basic")) - (clear-coverage!))))) + (parameterize ([current-directory root] + [current-cover-environment (make-cover-environment)]) + (define f (path->string (simplify-path tests/basic/prog.rkt))) + (define d "coverage") + (test-files! f) + (define coverage (get-test-coverage)) + (define files (get-files coverage (list f) d)) + (define (maybe-path->string p) + (if (string? p) p (path->string p))) + (check-equal? (list->set (map (compose maybe-path->string first) + files)) + (set "coverage/index.html" + "coverage/tests/basic/prog.html")) + (check-equal? (list->set (map (compose maybe-path->string second) files)) + (set "coverage" + "coverage/tests/basic"))))) ;; (Listof (list file-path directory-path xexpr)) -> Void (define (write-files f) @@ -129,20 +127,20 @@ (module+ test (test-begin - (define f (path->string (simplify-path tests/basic/prog.rkt))) - (test-files! f) - (define cov (get-test-coverage)) - (define covered? (curry cov f)) - (check-equal? (make-html-file cov f "assets/") - `(html () - (head () - (meta ([charset "utf-8"])) - (link ([rel "stylesheet"] [type "text/css"] [href "assets/main.css"]))) - (body () - (p () "expr: 100%" (br ())) - (div ([class "code"]) - ,(file->html f covered?))))) - (clear-coverage!))) + (parameterize ([current-cover-environment (make-cover-environment)]) + (define f (path->string (simplify-path tests/basic/prog.rkt))) + (test-files! f) + (define cov (get-test-coverage)) + (define covered? (curry cov f)) + (check-equal? (make-html-file cov f "assets/") + `(html () + (head () + (meta ([charset "utf-8"])) + (link ([rel "stylesheet"] [type "text/css"] [href "assets/main.css"]))) + (body () + (p () "expr: 100%" (br ())) + (div ([class "code"]) + ,(file->html f covered?)))))))) (define (file->html path covered?) (define file (file->string path)) @@ -153,15 +151,15 @@ (module+ test (test-begin - (define f (path->string (simplify-path tests/basic/prog.rkt))) - (test-files! f) - (define covered? (curry (get-test-coverage) f)) - (define lines (string-split (file->string f) "\n")) - (check-equal? (file->html f covered?) - `(div () - ,(div:line-numbers (length lines)) - ,(div:file-lines lines covered?))) - (clear-coverage!))) + (parameterize ([current-cover-environment (make-cover-environment)]) + (define f (path->string (simplify-path tests/basic/prog.rkt))) + (test-files! f) + (define covered? (curry (get-test-coverage) f)) + (define lines (string-split (file->string f) "\n")) + (check-equal? (file->html f covered?) + `(div () + ,(div:line-numbers (length lines)) + ,(div:file-lines lines covered?)))))) ;; File Report ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/private/shared.rkt b/private/shared.rkt index 91a3cff..131ca16 100644 --- a/private/shared.rkt +++ b/private/shared.rkt @@ -1,7 +1,12 @@ #lang racket/base -(provide verbose vprintf) +(provide verbose vprintf + logger-init-message + logger-covered-message) (define verbose (make-parameter #f)) +(define logger-init-message "init") +(define logger-covered-message "covered") + ;; like printf but only in verbose mode (define o (current-output-port)) (define (vprintf #:printer [printer printf] . a) diff --git a/strace.rkt b/strace.rkt index 8489035..94c50eb 100644 --- a/strace.rkt +++ b/strace.rkt @@ -11,40 +11,41 @@ "private/file-utils.rkt" "private/shared.rkt") - -(define (make-annotate-top c cover-name) - (define lift-name #'do-lift) - (define set-box-name #'set-box!) - (define box-name #'box) - (define hash-ref-name #'hash-ref) +(define (make-annotate-top topic) + (define log-message-name #'log-message) + (define current-logger-name #'current-logger) ;; -------- Specific `stacktrace^` Imports -------------- (define (initialize-test-coverage-point stx) (define srcloc (stx->srcloc stx)) - (when srcloc - (hash-set! c srcloc (box #f)))) + (log-message (current-logger) + 'info + topic + logger-init-message + srcloc #f)) (define (test-covered stx) (define loc/stx (stx->srcloc/stx stx)) - (with-syntax ([c cover-name] + (with-syntax ([current-logger current-logger-name] + [log-message log-message-name] [loc loc/stx] - [set-box! set-box-name] - [box box-name] - [hash-ref hash-ref-name] - [do-lift lift-name]) - #`(#%plain-app set-box! (do-lift (#%plain-app hash-ref c loc (box #f))) #t))) + [logger-covered-message logger-covered-message]) + #`(#%plain-app log-message (current-logger) + 'info '#,topic + logger-covered-message loc #f))) ;; -------- Cover's Specific Annotators -------------- (define (make-cover-annotate-top annotate-top) (lambda (stx phase) - ;(define e (add-cover-require stx)) - (cond [(cross-phase-persist? stx) - stx] - [(add-cover-require (annotate-clean (annotate-top stx phase))) - => expand-syntax] - [else stx]))) + (define e + (cond [(cross-phase-persist? stx) + stx] + [(add-cover-require (annotate-clean (annotate-top stx phase))) + => expand-syntax] + [else stx])) + e)) (define (cross-phase-persist? stx) (define disarmed (disarm stx)) @@ -63,11 +64,8 @@ [(m name lang mb) (or (eq? 'module (syntax-e #'m)) (eq? 'module* (syntax-e #'m))) - (with-syntax ([cover cover-name] - [set-box set-box-name] - [box box-name] - [hash-rf hash-ref-name] - [do-lift lift-name]) + (with-syntax ([log-message log-message-name] + [current-logger current-logger-name]) (define lexical? (eq? #f (syntax-e #'lang))) (syntax-case (syntax-disarm #'mb inspector) () [(#%module-begin b ...) @@ -76,15 +74,8 @@ (map (lambda (e) (loop e #f)) (syntax->list #'(b ...)))) (define/with-syntax (add ...) - #'((#%require (rename cover/coverage cover coverage) - (rename '#%kernel set-box set-box!) - (rename '#%kernel hash-rf hash-ref) - (rename '#%kernel box box)) - (#%require (for-syntax '#%kernel)) - (define-syntaxes (do-lift) - (lambda (stx) - (syntax-local-lift-expression - (cadr (syntax-e stx))))))) + #'((#%require (rename '#%kernel log-message log-message) + (rename '#%kernel current-logger current-logger)))) (define stx #'(m name lang (#%module-begin add ... body ...))) @@ -109,10 +100,9 @@ e #f [(begin e mod) (begin - (syntax-case #'e (#%plain-app set-box! do-lift make-srcloc hash-ref) - [(#%plain-app set-box! (lift (#%plain-app hash-ref _ (quote v) b)) _) - (let ([location (syntax->datum #'v)]) - (set-box! (hash-ref c location) #t))]) + (syntax-case #'e (#%plain-app log-message) + [(#%plain-app log-message _ _ _ "covered" (_ loc) #f) + (log-message (current-logger) 'info topic "covered" (syntax->datum #'loc))]) #'mod)] [_ e])) @@ -168,3 +158,17 @@ disarmed disarmed) armed)) + + +#; +(module+ test + (let () + (define ns (make-base-namespace)) + (parameterize ([current-namespace ns]) + (define ann (make-annotate-top)) + (define test + (expand #'(module a racket 1))) + (define r (make-log-receiver (current-logger) 'info logger-topic)) + (eval (ann test (namespace-base-phase ns)) ns) + (eval '(require 'a) ns) + (check-not-false (sync/timeout 0 r))))) diff --git a/tests/do-eval.rkt b/tests/do-eval.rkt index c322dfb..ea62da5 100644 --- a/tests/do-eval.rkt +++ b/tests/do-eval.rkt @@ -1,5 +1,5 @@ #lang racket/base (require racket/runtime-path "../main.rkt" rackunit) (define-runtime-path eval.rkt "eval.rkt") -(check-true (test-files! eval.rkt)) -(clear-coverage!) +(parameterize ([current-cover-environment (make-cover-environment)]) + (check-true (test-files! eval.rkt))) diff --git a/tests/do-exit.rkt b/tests/do-exit.rkt index 6f40279..30a4a9a 100644 --- a/tests/do-exit.rkt +++ b/tests/do-exit.rkt @@ -1,5 +1,5 @@ #lang racket/base (require "../main.rkt" racket/runtime-path) (define-runtime-path exit.rkt "exit.rkt") -(test-files! exit.rkt) -(clear-coverage!) +(parameterize ([current-cover-environment (make-cover-environment)]) + (test-files! exit.rkt)) diff --git a/tests/do-syntax.rkt b/tests/do-syntax.rkt index 4ba0ee4..2ee4af9 100644 --- a/tests/do-syntax.rkt +++ b/tests/do-syntax.rkt @@ -2,13 +2,11 @@ (require cover rackunit racket/runtime-path) (define-runtime-path syntax.rkt "syntax.rkt") (test-begin - (after - (clear-coverage!) + (parameterize ([current-cover-environment (make-cover-environment)]) (test-files! syntax.rkt) (define x (get-test-coverage)) (define c? (curry x (path->string syntax.rkt))) (for ([i (in-naturals 1)] [_ (in-string (file->string syntax.rkt))]) - (check-not-eq? (c? i) 'uncovered (~a i))) - (clear-coverage!))) + (check-not-eq? (c? i) 'uncovered (~a i))))) diff --git a/tests/error-file.rkt b/tests/error-file.rkt index 8bc5d6e..2329a60 100644 --- a/tests/error-file.rkt +++ b/tests/error-file.rkt @@ -1,4 +1,5 @@ #lang racket (require rackunit) (check-true #f) -(error "this is supposed to happend") +(test-begin + (error "this is supposed to happend")) diff --git a/tests/error.rkt b/tests/error.rkt index 2c17c9f..1b72d9a 100644 --- a/tests/error.rkt +++ b/tests/error.rkt @@ -4,12 +4,12 @@ (define-runtime-path error "error-file.rkt") (define-runtime-path main "main.rkt") (test-begin - (after + (parameterize ([current-cover-environment (make-cover-environment)]) (define (do-test files) (parameterize ([current-cover-environment (make-cover-environment)]) (define o (open-output-string)) (parameterize ([current-error-port o]) - (apply test-files! files)) + (check-false (apply test-files! files))) (define s (get-output-string o)) (define c (get-test-coverage)) (define covered (hash-keys (coverage-wrapper-map c))) @@ -18,5 +18,4 @@ files))) (define files (map path->string (list error main))) (do-test files) - (do-test (reverse files)) - (clear-coverage!))) + (do-test (reverse files)))) diff --git a/tests/main.rkt b/tests/main.rkt index 7f02a3c..d69b7fa 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 cover test-files! clear-coverage! get-test-coverage irrelevant-submodules) +(require (only-in cover test-files! get-test-coverage irrelevant-submodules + current-cover-environment make-cover-environment) (only-in "../cover.rkt" coverage-wrapper-map) "../private/file-utils.rkt" racket/runtime-path rackunit) @@ -20,26 +21,25 @@ (path->string (path-replace-suffix f ".rktl"))))) (define (do-test files) - (apply test-files! files) + (parameterize ([current-cover-environment (make-cover-environment)]) + (apply test-files! files) - (define coverage (get-test-coverage)) - (for ([(program cover) covered]) - (define-values (expected-coverage expected-uncoverage) - (with-input-from-file cover (lambda () (values (ranges->numbers (read)) - (ranges->numbers (read)))))) - (define covered? (curry 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 - (test-range expected-coverage 'covered) - (test-range expected-uncoverage 'uncovered))) - - (clear-coverage!)) + (define coverage (get-test-coverage)) + (for ([(program cover) covered]) + (define-values (expected-coverage expected-uncoverage) + (with-input-from-file cover (lambda () (values (ranges->numbers (read)) + (ranges->numbers (read)))))) + (define covered? (curry 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 + (test-range expected-coverage 'covered) + (test-range expected-uncoverage 'uncovered))))) ;; ensure the results are the same regardless of file order (do-test files) @@ -63,10 +63,9 @@ (module+ test (define-runtime-path prog.rkt "prog.rkt") (test-begin - (after + (parameterize ([current-cover-environment (make-cover-environment)]) (test-files! (->absolute prog.rkt)) (define abs (coverage-wrapper-map (get-test-coverage))) (test-files! (build-path (->relative prog.rkt))) (define rel (coverage-wrapper-map (get-test-coverage))) - (check-equal? abs rel) - (clear-coverage!)))) + (check-equal? abs rel)))) diff --git a/tests/nested.rkt b/tests/nested.rkt new file mode 100644 index 0000000..ad8ee45 --- /dev/null +++ b/tests/nested.rkt @@ -0,0 +1,34 @@ +#lang racket +(require rackunit cover racket/runtime-path + "../private/file-utils.rkt") + +(define-runtime-path prog "basic/prog.rkt") +(define-runtime-path cov "../cover.rkt") +(define-runtime-path other "simple-multi/2.rkt") + +(define (do-test . files) + (define key (->absolute (first files))) + (void + (parameterize ([current-cover-environment (make-cover-environment)]) + (check-true (apply test-files! files)) + (parameterize ([current-cover-environment (make-cover-environment)]) + (parameterize ([current-cover-environment (make-cover-environment)]) + (check-true (apply test-files! files)) + ((get-test-coverage) key 1)) + (check-true (apply test-files! files)) + ((get-test-coverage) key 1)) + ((get-test-coverage) key 1)))) + + +;; these tests are logically "check-not-exn"s but that obsures inner test failures +(test-case + "Prog nested coverage" + (do-test prog)) + +(test-case + "Cover nested coverage" + (do-test cov)) + +(test-case + "Cover nested coverage with many files" + (do-test cov other)) diff --git a/tests/provide.rkt b/tests/provide.rkt new file mode 100644 index 0000000..771261a --- /dev/null +++ b/tests/provide.rkt @@ -0,0 +1,5 @@ +#lang racket/base +(provide test + (struct-out tt)) +(define test 5) +(struct tt (a b c) #:transparent) diff --git a/tests/use-provide.rkt b/tests/use-provide.rkt new file mode 100644 index 0000000..53f0ef0 --- /dev/null +++ b/tests/use-provide.rkt @@ -0,0 +1,3 @@ +#lang racket +(require (for-syntax "provide.rkt")) +(begin-for-syntax (tt 1 2 3))