diff --git a/cover.rkt b/cover.rkt index f858cce..82159db 100644 --- a/cover.rkt +++ b/cover.rkt @@ -30,9 +30,10 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b racket/list racket/port "private/shared.rkt" - "private/file-utils.rkt") + "private/file-utils.rkt" + "strace.rkt") -(struct environment (namespace compile ann-top raw-cover cch)) +(struct environment (namespace compile ann-top raw-cover)) ;;; ---------------------- Running Files --------------------------------- @@ -71,7 +72,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b [current-command-line-arguments argv] [exit-handler (lambda (x) (raise (an-exit x)))] [current-namespace (get-namespace)] - [(get-check-handler-parameter) + [current-check-handler ;(get-check-handler-parameter) (lambda x (set! tests-failed #t) (vprintf "file ~s had failed tests\n" p) @@ -90,18 +91,19 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (define (run-mod to-run) (vprintf "running ~s\n" to-run) - (eval (make-dyn-req-expr to-run)) + (do-dyn-req-expr to-run) (vprintf "finished running ~s\n" to-run)) -(define (make-dyn-req-expr to-run) - `(dynamic-require ',to-run 0)) +(define (do-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))) + ;; first here is like "srcloc-source", but its in list form... + #:when (not (member (first s) names))) (hash-remove! c s))) ;;; ---------------------- Compiling --------------------------------- @@ -161,30 +163,40 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (define (clear-coverage!) (current-cover-environment (make-cover-environment))) -(define (make-cover-environment [ns (make-base-namespace)]) +(define (make-kernel-namespace) + (define ns (make-empty-namespace)) + (define cns (current-namespace)) + (namespace-attach-module cns ''#%builtin ns) + ns) + +(define (make-cover-environment [ns (make-kernel-namespace)]) (parameterize ([current-namespace ns]) (define ann (load-annotate-top)) (environment ns (make-cover-compile ns ann) ann - (load-raw-coverage) - (load-current-check-handler)))) + (load-raw-coverage)))) (define (get-annotate-top) (get-val environment-ann-top)) (define (load-annotate-top) - (dynamic-require 'cover/strace '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)) +(define (load-cover-setter) + (dynamic-require 'cover/coverage '!)) + +#; (define (get-check-handler-parameter) - (get-val environment-cch)) -(define (load-current-check-handler) - (dynamic-require 'rackunit 'current-check-handler)) + (namespace-variable-value (module->namespace 'rackunit) + 'current-check-handler)) (define (get-namespace) (get-val environment-namespace)) @@ -205,7 +217,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b ;; filtered : (listof (list boolean srcloc)) ;; remove redundant expressions - (define filtered (hash-map (get-raw-coverage) (λ (k v) (list v k)))) + (define filtered (hash-map (get-raw-coverage) (λ (k v) (list v (apply make-srcloc k))))) (define out (make-hash)) @@ -215,7 +227,8 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b file (lambda (l) (cons v l)) null)) - out)) + ;; Make the hash map immutable + (for/hash ([(k v) (in-hash out)]) (values k v)))) (define current-cover-environment (make-parameter (make-cover-environment))) @@ -253,6 +266,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (define ns (environment-namespace env)) (parameterize ([current-cover-environment env] [current-namespace ns]) + (namespace-require 'racket/base) (test-begin (define file (path->string simple-multi/2.rkt)) (define modpath file) diff --git a/coverage.rkt b/coverage.rkt index 3256929..8b10caa 100644 --- a/coverage.rkt +++ b/coverage.rkt @@ -1,3 +1,4 @@ (module coverage '#%kernel - (#%provide coverage) + (#%provide coverage cover-name) + (define-values (cover-name) (quote-syntax coverage)) (define-values (coverage) (make-hash))) diff --git a/scribblings/basics.scrbl b/scribblings/basics.scrbl index cff325a..49998ea 100644 --- a/scribblings/basics.scrbl +++ b/scribblings/basics.scrbl @@ -68,3 +68,5 @@ first is to include @racketmodname[scribble/manual] and @racket[planet] in the c exclude them from the output with the @Flag{e} flag. The other is to add the files that cause the cyclic dependencies to @racket[_test-omit-paths] or @racket[_cover-omit-paths] in that collections @filepath{info.rkt}. + +Cover will automatically skip any module declared @tech{cross-phase persistent}. diff --git a/strace.rkt b/strace.rkt index b34e9f6..c8ccff5 100644 --- a/strace.rkt +++ b/strace.rkt @@ -1,5 +1,5 @@ #lang racket/base -(provide (rename-out [in:annotate-top annotate-top])) +(provide make-annotate-top) (require errortrace/stacktrace racket/function racket/syntax @@ -7,92 +7,94 @@ syntax/kerncase racket/runtime-path "private/file-utils.rkt" - "private/shared.rkt" - "coverage.rkt") + "private/shared.rkt") -(define cover-name #'coverage) -(define srcloc-name #'make-srcloc) +(define (make-annotate-top c cover-name) + (define (initialize-test-coverage-point stx) + (define srcloc (stx->srcloc stx)) + (when srcloc + (hash-set! c srcloc #f))) + (define (with-mark src dest phase) dest) + (define test-coverage-enabled (make-parameter #t)) -(define (with-mark src dest phase) dest) -(define test-coverage-enabled (make-parameter #t)) + (define (test-covered stx) + (with-syntax ([c cover-name] + [loc (stx->srcloc/stx stx)]) + #'(#%plain-app hash-set! c loc #t))) -(define (initialize-test-coverage-point stx) - (define srcloc (stx->srcloc stx)) - (when srcloc - (hash-set! coverage srcloc #f))) + (define profile-key (gensym)) -(define (test-covered stx) - (define loc/stx (stx->srcloc/stx stx)) - (with-syntax ([c cover-name] - [loc loc/stx]) - #'(#%plain-app hash-set! c loc #t))) + (define profiling-enabled (make-parameter #f)) + (define initialize-profile-point void) + (define (register-profile-start . a) #f) + (define register-profile-done void) -(define profile-key (gensym)) -(define profiling-enabled (make-parameter #f)) -(define initialize-profile-point void) -(define (register-profile-start . a) #f) -(define register-profile-done void) + (define (make-srcloc-maker f) + (lambda (stx) + (and (syntax? stx) + (let* ([orig-src (syntax-source stx)] + [src (if (path? orig-src) (path->string orig-src) orig-src)] + [pos (syntax-position stx)] + [span (syntax-span stx)]) + (and pos + span + (f src #f #f pos span)))))) -(define-values/invoke-unit/infer stacktrace@) + (define stx->srcloc + (make-srcloc-maker list)) -(define (make-srcloc-maker f) - (lambda (stx) - (and (syntax? stx) - (let* ([orig-src (syntax-source stx)] - [src (if (path? orig-src) (path->string orig-src) orig-src)] - [pos (syntax-position stx)] - [span (syntax-span stx)]) - (and pos - span - (f src #f #f pos span)))))) + (define stx->srcloc/stx + (make-srcloc-maker + (lambda (src a b pos span) + (with-syntax ([src src] + [pos pos] + [a a] + [b b] + [span span]) + #'(quote (src a b pos span)))))) -(define stx->srcloc - (make-srcloc-maker make-srcloc)) + (define (in:annotate-top annotate-top) + (lambda (stx phase) + (define e (add-cover-require stx)) + (if e (annotate-clean (annotate-top e phase)) stx))) -(define stx->srcloc/stx - (make-srcloc-maker - (lambda (src a b pos span) - (with-syntax ([src src] - [pos pos] - [a a] - [b b] - [span span] - [make-srcloc srcloc-name]) - #'(make-srcloc src a b pos span))))) + (define (add-cover-require expr) + (define inspector (variable-reference->module-declaration-inspector + (#%variable-reference))) + (let loop ([expr expr] [top #t]) + (define disarmed (syntax-disarm expr inspector)) + (kernel-syntax-case disarmed #f + [(module name lang (#%module-begin e ...)) + (member '(#%declare #:cross-phase-persistent) (syntax->datum #'(e ...))) + #f] + [(module name lang mb) + (with-syntax ([cover cover-name]) + (syntax-case (syntax-disarm #'mb inspector) () + [(#%module-begin b ...) + (with-syntax ([(body ...) + (map (lambda (e) (loop e #f)) (syntax->list #'(b ...)))]) + (syntax-rearm + (namespace-syntax-introduce + (datum->syntax + expr + (syntax-e + #'(module name lang + (#%module-begin + (#%require (rename cover/coverage cover coverage)) + body ...))) + expr expr)) + expr))]))] + [_ (if top #f expr)]))) -(define (in:annotate-top stx phase) - (define e (add-cover-require stx)) - (if e (annotate-clean (annotate-top e phase)) stx)) + ;; in order to write modules to disk the top level needs to + ;; be a module. so we trust that the module is loaded and trim the expression + (define (annotate-clean e) + (kernel-syntax-case e #f + [(begin e mod) + (eval #'e) + #'mod] + [_ e])) -(define (add-cover-require expr) - (define inspector (variable-reference->module-declaration-inspector - (#%variable-reference))) - (let loop ([expr expr] [top #t]) - (kernel-syntax-case (syntax-disarm expr inspector) #f - [(module name lang mb) - (with-syntax ([cover cover-name] - [srcloc srcloc-name]) - (syntax-case (syntax-disarm #'mb inspector) () - [(#%module-begin b ...) - (with-syntax ([(body ...) - (map (lambda (e) (loop e #f)) (syntax->list #'(b ...)))]) - (syntax-rearm - (namespace-syntax-introduce - (quasisyntax/loc expr - (module name lang - (#%module-begin - (#%require (rename cover/coverage cover coverage)) - (#%require (rename racket/base srcloc make-srcloc)) - body ...)))) - expr))]))] - [_ (if top #f expr)]))) - -;; in order to write modules to disk the top level needs to -;; be a module. so we trust that the module is loaded and trim the expression -(define (annotate-clean e) - (kernel-syntax-case e #f - [(begin e mod) - (eval #'e) - #'mod] - [_ e])) + (define-values/invoke-unit/infer stacktrace@) + (in:annotate-top annotate-top))