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

A first pass

Browse Source
This commit is contained in:
Spencer Florence 2015-02-22 20:09:00 -05:00
parent e8dd8c9c60
commit 10efdac497
3 changed files with 63 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -1,2 +1,5 @@
all:
raco setup --check-pkg-deps cover && raco test . && raco cover -b .
debug:
raco setup cover && raco test . && raco cover -vb .

4
cover.rkt
View File

@ -183,6 +183,7 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
(define (load-annotate-top)
(make-annotate-top (load-raw-coverage) (load-cover-name)))
(define (get-raw-coverage)
(get-val environment-raw-cover))
(define (load-raw-coverage)
@ -217,7 +218,8 @@ 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 (apply make-srcloc k)))))
(define filtered (hash-map (get-raw-coverage)
(λ (k v) (list (unbox v) (apply make-srcloc k)))))
(define out (make-hash))

78
strace.rkt
View File

@ -3,24 +3,22 @@
(require errortrace/stacktrace
racket/function
racket/syntax
syntax/parse
racket/unit
syntax/kerncase
racket/runtime-path
racket/fixnum
"private/file-utils.rkt"
"private/shared.rkt")
(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 (test-covered stx)
(with-syntax ([c cover-name]
[loc (stx->srcloc/stx stx)])
#'(#%plain-app hash-set! c loc #t)))
(define lift-name #'do-lift)
(define set-box-name #'set-box!)
(define hash-ref-name #'hash-ref)
(define profile-key (gensym))
@ -28,6 +26,19 @@
(define initialize-profile-point void)
(define (register-profile-start . a) #f)
(define register-profile-done void)
(define (initialize-test-coverage-point stx)
(define srcloc (stx->srcloc stx))
(when srcloc
(hash-set! c srcloc (box #f))))
(define (test-covered stx)
(define loc/stx (stx->srcloc/stx stx))
(with-syntax ([c cover-name]
[loc loc/stx]
[set-box! set-box-name]
[hash-ref hash-ref-name]
[do-lift lift-name])
#`(set-box! (do-lift (hash-ref c loc)) #t)))
(define (make-srcloc-maker f)
@ -54,10 +65,21 @@
[span span])
#'(quote (src a b pos span))))))
(define o (current-output-port))
(define (in:annotate-top annotate-top)
(lambda (stx phase)
(define e (add-cover-require stx))
(if e (annotate-clean (annotate-top e phase)) stx)))
(let ([tmp (if e (expand-syntax (annotate-clean (annotate-top (expand-syntax e) phase))) stx)])
#;
(when (equal? (string->path "/Users/florence/playground/cover/private/format-utils.rkt") (syntax-source e))
(define ce (dynamic-require 'racket/gui 'current-eventspace))
(define me (dynamic-require 'racket/gui 'make-eventspace))
(parameterize ([ce (me)])
(thread (lambda () ((dynamic-require 'macro-debugger/syntax-browser 'browse-syntax) tmp))))
(let loop () (loop)))
; (write (syntax-source e) o)
; (displayln "")
tmp)))
(define (add-cover-require expr)
(define inspector (variable-reference->module-declaration-inspector
@ -69,7 +91,10 @@
(member '(#%declare #:cross-phase-persistent) (syntax->datum #'(e ...)))
#f]
[(module name lang mb)
(with-syntax ([cover cover-name])
(with-syntax ([cover cover-name]
[set-box set-box-name]
[hash-rf hash-ref-name]
[do-lift lift-name])
(syntax-case (syntax-disarm #'mb inspector) ()
[(#%module-begin b ...)
(with-syntax ([(body ...)
@ -77,24 +102,35 @@
(syntax-rearm
(namespace-syntax-introduce
(datum->syntax
expr
disarmed
(syntax-e
#'(module name lang
(#%module-begin
(#%require (rename cover/coverage cover coverage))
body ...)))
expr expr))
#'(m name lang
(#%module-begin
(#%require (rename cover/coverage cover coverage)
(rename '#%kernel set-box set-box!)
(rename '#%kernel hash-rf hash-ref))
(#%require (for-syntax '#%kernel))
(define-syntaxes (do-lift)
(lambda (stx)
(syntax-local-lift-expression (cadr (syntax-e stx)))))
body ...)))
disarmed
disarmed))
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]))
(kernel-syntax-case e #f
[(begin e mod)
(begin
(syntax-case #'e (set-box! do-lift make-srcloc hash-ref)
[(set-box! (lift (hash-ref _ (make-srcloc v ...))) _)
(let ([location (apply make-srcloc (syntax->datum #'(v ...)))])
(set-box! (hash-ref c location) #t))])
#'mod)]
[_ e]))
(define-values/invoke-unit/infer stacktrace@)
(in:annotate-top annotate-top))