added manual expression and module evaluating
This commit is contained in:
Spencer Florence
parent
f4b9c71af3
commit
35f9058d6e
172
cover.rkt
172
cover.rkt
|
|
@ -1,5 +1,8 @@
|
|||
#lang racket/base
|
||||
(provide test-files! clear-coverage! get-test-coverage)
|
||||
(provide test-files! eval-expression! eval-module!
|
||||
initialize-cover-environment! clear-coverage!
|
||||
get-test-coverage
|
||||
current-cover-environment environment?)
|
||||
|
||||
#|
|
||||
|
||||
|
|
@ -17,6 +20,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
syntax/modread
|
||||
syntax/parse
|
||||
unstable/syntax
|
||||
racket/bool
|
||||
racket/runtime-path
|
||||
racket/match
|
||||
rackunit
|
||||
|
|
@ -26,13 +30,13 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
"private/shared.rkt"
|
||||
"private/file-utils.rkt")
|
||||
|
||||
;; namespace used for coverage
|
||||
(define ns #f)
|
||||
(struct environment (namespace compile ann-top raw-cover cch))
|
||||
|
||||
;;; ---------------------- Running Files ---------------------------------
|
||||
|
||||
;; Test files and build coverage map
|
||||
;; returns true if no tests reported as failed, and no files errored.
|
||||
(define (test-files! #:submod [submod-name 'test] . files)
|
||||
(unless ns (unloaded-error))
|
||||
(define (test-files! #:submod [submod-name 'test] . files)
|
||||
(define abs
|
||||
(for/list ([p (in-list files)])
|
||||
(if (list? p)
|
||||
|
|
@ -45,9 +49,6 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
[(? input-port? p)
|
||||
(object-name p)]
|
||||
[_ p])))
|
||||
(parameterize ([current-load/use-compiled (make-cover-load/use-compiled abs-names)]
|
||||
[current-output-port
|
||||
(if (verbose) (current-output-port) (open-output-nowhere))])
|
||||
(define tests-failed #f)
|
||||
(for ([p (in-list abs)])
|
||||
(vprintf "attempting to run ~s\n" p)
|
||||
|
|
@ -63,9 +64,12 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
[else
|
||||
(set! tests-failed #t)
|
||||
(error-display x)]))])
|
||||
(parameterize* ([current-command-line-arguments argv]
|
||||
(parameterize* ([current-load/use-compiled (make-cover-load/use-compiled abs-names)]
|
||||
[current-output-port
|
||||
(if (verbose) (current-output-port) (open-output-nowhere))]
|
||||
[current-command-line-arguments argv]
|
||||
[exit-handler (lambda (x) (raise (an-exit x)))]
|
||||
[current-namespace ns]
|
||||
[current-namespace (get-namespace)]
|
||||
[(get-check-handler-parameter)
|
||||
(lambda x
|
||||
(set! tests-failed #t)
|
||||
|
|
@ -74,12 +78,22 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
(run-file the-file submod-name))))
|
||||
(vprintf "ran ~s\n" files)
|
||||
(remove-unneeded-results! abs-names)
|
||||
(not tests-failed)))
|
||||
(not tests-failed))
|
||||
|
||||
;; (U InputPort PathString) -> (U InputPort PathString)
|
||||
;; like ->absolute but handles ports
|
||||
(define (->absolute/port p)
|
||||
(if (port? p) p (->absolute p)))
|
||||
;; ModulePath -> Void
|
||||
;; visit and instantiate the given module path in the cover environment
|
||||
(define (eval-module! to-run)
|
||||
(eval-expression! (make-dyn-req-expr to-run)))
|
||||
|
||||
;; Any -> Any
|
||||
;; Evaluate the expression in the testing namespace with the cover's compiler
|
||||
(define (eval-expression! e)
|
||||
(parameterize ([current-load/use-compiled (make-cover-load/use-compiled #f)]
|
||||
[current-compile (get-compile)]
|
||||
[current-namespace (get-namespace)])
|
||||
(eval e)))
|
||||
|
||||
;;; ---------------------- Running Aux ---------------------------------
|
||||
|
||||
(define (run-file the-file submod-name)
|
||||
(cond [(input-port? the-file)
|
||||
|
|
@ -89,20 +103,36 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
(define submod `(submod ,sfile ,submod-name))
|
||||
(run-mod (if (module-declared? submod #t) submod sfile))]))
|
||||
|
||||
;; ModulePath -> Void
|
||||
;; evaluate the current module in the current namespace
|
||||
(define (run-mod to-run)
|
||||
(vprintf "running ~s\n" to-run)
|
||||
(eval `(dynamic-require ',to-run 0))
|
||||
(eval (make-dyn-req-expr to-run))
|
||||
(vprintf "finished running ~s\n" to-run))
|
||||
|
||||
;; [Listof Path] -> Loader Compiler
|
||||
;; (U InputPort PathString) -> (U InputPort PathString)
|
||||
;; like ->absolute but handles ports
|
||||
(define (->absolute/port p)
|
||||
(if (port? p) p (->absolute p)))
|
||||
|
||||
(define (make-dyn-req-expr to-run)
|
||||
`(dynamic-require ',to-run 0))
|
||||
|
||||
;; [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))]
|
||||
#:when (not (member (srcloc-source 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`
|
||||
;; 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 (make-cover-compile))
|
||||
(define cover-compile (get-compile))
|
||||
(define cover-use-compiled-file-paths
|
||||
(cons (build-path "compiled" "cover")
|
||||
(use-compiled-file-paths)))
|
||||
|
|
@ -111,7 +141,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
(define lst (explode-path abs))
|
||||
(define dir-list (take lst (sub1 (length lst))))
|
||||
(parameterize ([current-load-relative-directory (apply build-path dir-list)])
|
||||
(if (member abs paths)
|
||||
(if (implies paths (member abs paths))
|
||||
(parameterize ([current-compile cover-compile]
|
||||
[use-compiled-file-paths
|
||||
cover-use-compiled-file-paths])
|
||||
|
|
@ -120,12 +150,12 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
|
||||
;; -> Compiler
|
||||
;; makes a value sutable for current-compile, such that compile
|
||||
;; annotates the source code. should only be used by `make-cover-load/uze-compiled`
|
||||
(define (make-cover-compile)
|
||||
;; annotates the source code with annotate-top. meant to be called
|
||||
;; only by initialize-cover-environment
|
||||
(define (make-cover-compile ns annotate-top)
|
||||
(define compile (current-compile))
|
||||
(define reg (namespace-module-registry ns))
|
||||
(define phase (namespace-base-phase ns))
|
||||
(define annotate-top (get-annotate-top))
|
||||
;; define so its named in stack traces
|
||||
(define cover-compile
|
||||
(lambda (e immediate-eval?)
|
||||
|
|
@ -146,55 +176,57 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
(compile to-compile immediate-eval?)))
|
||||
cover-compile)
|
||||
|
||||
;; [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))]
|
||||
#:when (not (member (srcloc-source s) names)))
|
||||
(hash-remove! c s)))
|
||||
;;; ---------------------- Environments ---------------------------------
|
||||
|
||||
;; -> Void
|
||||
;; clear coverage map. Effectively recreates and rebuilds `ns`
|
||||
(define (clear-coverage!)
|
||||
(set! ns (make-base-namespace))
|
||||
(current-cover-environment (initialize-cover-environment! (make-base-namespace))))
|
||||
|
||||
(define (initialize-cover-environment! ns)
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require 'cover/coverage)
|
||||
(namespace-require 'cover/strace)
|
||||
(namespace-require 'rackunit))
|
||||
(load-names!))
|
||||
(namespace-require 'rackunit)
|
||||
(define ann (load-annotate-top))
|
||||
(environment
|
||||
ns
|
||||
(make-cover-compile ns ann)
|
||||
ann
|
||||
(load-raw-coverage)
|
||||
(load-current-check-handler))))
|
||||
|
||||
;; -> Void
|
||||
;; loads any needed names from `ns` before it can get polluted.
|
||||
(define (load-names!)
|
||||
(load-annotate-top!)
|
||||
(load-raw-coverage!)
|
||||
(load-current-check-handler!))
|
||||
(define (load-names)
|
||||
(load-annotate-top)
|
||||
(load-raw-coverage)
|
||||
(load-current-check-handler))
|
||||
|
||||
(define ann-top #f)
|
||||
(define (get-annotate-top)
|
||||
(or ann-top (unloaded-error)))
|
||||
(define (load-annotate-top!)
|
||||
(set! ann-top (get-ns-var 'annotate-top)))
|
||||
(get-val environment-ann-top))
|
||||
(define (load-annotate-top)
|
||||
(get-namespace-var 'annotate-top))
|
||||
|
||||
(define raw-cover #f)
|
||||
(define (get-raw-coverage)
|
||||
(or raw-cover (unloaded-error)))
|
||||
(define (load-raw-coverage!)
|
||||
(set! raw-cover (get-ns-var 'coverage)))
|
||||
(get-val environment-raw-cover))
|
||||
(define (load-raw-coverage)
|
||||
(get-namespace-var 'coverage))
|
||||
|
||||
(define cch #f)
|
||||
(define (load-current-check-handler!)
|
||||
(set! cch (get-ns-var 'current-check-handler)))
|
||||
(define (get-check-handler-parameter)
|
||||
(or cch (unloaded-error)))
|
||||
(get-val environment-cch))
|
||||
(define (load-current-check-handler)
|
||||
(get-namespace-var 'current-check-handler))
|
||||
|
||||
(define (unloaded-error)
|
||||
(error 'cover "Test coverage not loaded."))
|
||||
(define (get-namespace)
|
||||
(get-val environment-namespace))
|
||||
|
||||
(define (get-ns-var sym)
|
||||
(namespace-variable-value sym #t #f ns))
|
||||
(define (get-compile)
|
||||
(get-val environment-compile))
|
||||
|
||||
(define (get-val access)
|
||||
(access (current-cover-environment)))
|
||||
|
||||
(define (get-namespace-var sym)
|
||||
(namespace-variable-value sym #t #f (current-namespace)))
|
||||
|
||||
;; -> [Hashof PathString (Listof (List Boolean srcloc))]
|
||||
;; returns a hash of file to a list, where the first of the list is if
|
||||
|
|
@ -217,9 +249,8 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
null))
|
||||
out)
|
||||
|
||||
;; A little hack to setup coverage namespace for the first time
|
||||
(clear-coverage!)
|
||||
|
||||
(define current-cover-environment
|
||||
(make-parameter (initialize-cover-environment! (make-base-namespace))))
|
||||
|
||||
;; here live tests for actually saving compiled files
|
||||
(module+ test
|
||||
|
|
@ -230,15 +261,14 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
|
|||
"tests/compiled/prog_rkt.zo"
|
||||
"tests/compiled/prog_rkt.dep"))
|
||||
(test-begin
|
||||
(after
|
||||
(for-each (lambda (f) (when (file-exists? f) (delete-file f)))
|
||||
compiled)
|
||||
(check-false (ormap file-exists? compiled))
|
||||
(check-not-exn
|
||||
(lambda ()
|
||||
(parameterize ([current-load/use-compiled
|
||||
(make-cover-load/use-compiled (list (->absolute prog.rkt)))]
|
||||
[current-namespace ns])
|
||||
(managed-compile-zo prog.rkt))))
|
||||
(check-true (andmap file-exists? compiled))
|
||||
(clear-coverage!))))
|
||||
(parameterize ([current-cover-environment (initialize-cover-environment! (make-base-namespace))])
|
||||
(for-each (lambda (f) (when (file-exists? f) (delete-file f)))
|
||||
compiled)
|
||||
(check-false (ormap file-exists? compiled))
|
||||
(check-not-exn
|
||||
(lambda ()
|
||||
(parameterize ([current-load/use-compiled
|
||||
(make-cover-load/use-compiled (list (->absolute prog.rkt)))]
|
||||
[current-namespace (get-namespace)])
|
||||
(managed-compile-zo prog.rkt))))
|
||||
(check-true (andmap file-exists? compiled)))))
|
||||
|
|
|
|||
9
main.rkt
9
main.rkt
|
|
@ -5,6 +5,7 @@
|
|||
(provide
|
||||
(contract-out
|
||||
[coverage/c contract?]
|
||||
|
||||
[file-coverage/c contract?]
|
||||
[test-files! (->* () (#:submod symbol?)
|
||||
#:rest
|
||||
|
|
@ -13,8 +14,16 @@
|
|||
(and/c (lambda (v) (not (impersonator? v)))
|
||||
(vectorof string? #:immutable #t)))))
|
||||
any)]
|
||||
[eval-expression! (-> any/c any)]
|
||||
[eval-module! (-> module-path? any)]
|
||||
|
||||
[environment? (-> any/c any/c)]
|
||||
[clear-coverage! (-> any)]
|
||||
[initialize-cover-environment! (-> namespace? environment?)]
|
||||
[current-cover-environment (parameter/c environment?)]
|
||||
|
||||
[get-test-coverage (-> coverage/c)]
|
||||
|
||||
[irrelevant-submodules (parameter/c (or/c #f (listof symbol?)))]
|
||||
[make-covered?
|
||||
(-> file-coverage/c path-string?
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user