suzanne.soy/cover
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixes #79 #77 and #59

Browse Source 
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.
This commit is contained in:
Spencer Florence 2015-06-27 18:04:16 -05:00
parent 41336ac264
commit 2ae091805e
16 changed files with 295 additions and 235 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

170
cover.rkt
View File

@ -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 <pkgs>/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))

4
coverage.rkt
View File

@ -1,4 +0,0 @@
(module coverage '#%kernel
(#%provide coverage cover-name)
(define-values (cover-name) (quote-syntax coverage))
(define-values (coverage) (make-hash)))

4
info.rkt
View File

@ -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")

60
private/coveralls.rkt
View File

@ -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)))

94
private/html/html.rkt
View File

@ -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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

7
private/shared.rkt
View File

@ -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)

80
strace.rkt
View File

@ -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)))))

4
tests/do-eval.rkt
View File

@ -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)))

4
tests/do-exit.rkt
View File

@ -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))

6
tests/do-syntax.rkt
View File

@ -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)))))

3
tests/error-file.rkt
View File

@ -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"))

7
tests/error.rkt
View File

@ -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))))

45
tests/main.rkt
View File

@ -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))))

34
tests/nested.rkt Normal file
View File

@ -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))

5
tests/provide.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(provide test
(struct-out tt))
(define test 5)
(struct tt (a b c) #:transparent)

3
tests/use-provide.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang racket
(require (for-syntax "provide.rkt"))
(begin-for-syntax (tt 1 2 3))