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

minor changes to naming

Browse Source
This commit is contained in:
Spencer Florence 2015-01-23 23:44:01 -05:00
parent 4398963d38
commit 0499f7e653
2 changed files with 40 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
cover.rkt
View File

@ -107,22 +107,25 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
(define reg (namespace-module-registry ns))
(define phase (namespace-base-phase ns))
(define annotate-top (get-annotate-top))
(lambda (e immediate-eval?)
(define to-compile
(cond [(or (compiled-expression? (if (syntax? e) (syntax-e e) e))
(not (eq? reg (namespace-module-registry (current-namespace))))
(not (equal? phase (namespace-base-phase (current-namespace)))))
e]
[else
(vprintf "compiling ~s with coverage annotations\n"
(if (not (syntax? e))
e
(or (syntax-source-file-name e)
(syntax-source e)
(syntax->datum e))))
;; define so its named in stack traces
(define cover-compile
(lambda (e immediate-eval?)
(define to-compile
(cond [(or (compiled-expression? (if (syntax? e) (syntax-e e) e))
(not (eq? reg (namespace-module-registry (current-namespace))))
(not (equal? phase (namespace-base-phase (current-namespace)))))
e]
[else
(vprintf "compiling ~s with coverage annotations\n"
(if (not (syntax? e))
e
(or (syntax-source-file-name e)
(syntax-source e)
(syntax->datum e))))
(annotate-top (if (syntax? e) (expand-syntax e) (datum->syntax #f e))
phase)]))
(compile to-compile immediate-eval?)))
phase)]))
(compile to-compile immediate-eval?)))
cover-compile)
(define (remove-unneeded-results paths)
(define c (get-raw-coverage))
@ -235,7 +238,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
(for-each (lambda (f) (when (file-exists? f) (delete-file f)))
compiled)
(check-false (ormap file-exists? compiled))
(check-not-exn
(#;check-not-exn
(lambda ()
(parameterize ([current-compile (make-cover-compile)]
[current-namespace ns])

41
strace.rkt
View File

@ -65,28 +65,29 @@
(define e (add-cover-require stx))
(if e (annotate-clean (annotate-top e phase)) stx))
(define (add-cover-require expr [top #t])
(define (add-cover-require expr)
(define inspector (variable-reference->module-declaration-inspector
(#%variable-reference)))
(syntax-parse (syntax-disarm expr inspector)
#:literal-sets (kernel-literals)
[(module name lang mb)
(with-syntax ([cover cover-name]
[srcloc srcloc-name])
(syntax-parse (syntax-disarm #'mb inspector)
[(#%module-begin b ...)
(with-syntax ([(body ...)
(map (lambda (e) (add-cover-require 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)]))
(let loop ([expr expr] [top #t])
(syntax-parse (syntax-disarm expr inspector)
#:literal-sets (kernel-literals)
[(module name lang mb)
(with-syntax ([cover cover-name]
[srcloc srcloc-name])
(syntax-parse (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