99 lines
3.0 KiB
Racket
99 lines
3.0 KiB
Racket
#lang racket/base
|
|
(provide (rename-out [in:annotate-top annotate-top]))
|
|
(require errortrace/stacktrace
|
|
racket/function
|
|
racket/syntax
|
|
racket/unit
|
|
syntax/kerncase
|
|
racket/runtime-path
|
|
"private/file-utils.rkt"
|
|
"private/shared.rkt"
|
|
"coverage.rkt")
|
|
|
|
(define cover-name #'coverage)
|
|
(define srcloc-name #'make-srcloc)
|
|
|
|
(define (with-mark src dest phase) dest)
|
|
(define test-coverage-enabled (make-parameter #t))
|
|
|
|
(define (initialize-test-coverage-point stx)
|
|
(define srcloc (stx->srcloc stx))
|
|
(when srcloc
|
|
(hash-set! coverage srcloc #f)))
|
|
|
|
(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 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-values/invoke-unit/infer stacktrace@)
|
|
|
|
(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
|
|
(make-srcloc-maker make-srcloc))
|
|
|
|
(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 (in:annotate-top stx phase)
|
|
(define e (add-cover-require stx))
|
|
(if e (annotate-clean (annotate-top e phase)) stx))
|
|
|
|
(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]))
|