diff --git a/cover.rkt b/cover.rkt index 68c684e..509eaee 100644 --- a/cover.rkt +++ b/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))))) diff --git a/main.rkt b/main.rkt index 616bde5..a148909 100644 --- a/main.rkt +++ b/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?