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

removing deps on racket/base, and checking cross-phase persistent modules

Browse Source
This commit is contained in:
Spencer Florence 2015-04-02 13:04:48 -04:00
parent c4bd7f80c9
commit 44fa08155f
4 changed files with 114 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
cover.rkt
View File

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

3
coverage.rkt
View File

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

2
scribblings/basics.scrbl
View File

@ -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}.

158
strace.rkt
View File

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