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

refactor and fix regression

Browse Source
This commit is contained in:
Spencer Florence 2015-04-03 17:34:21 -04:00
parent 78c7afd86f
commit b2a69f26b7
3 changed files with 153 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
cover.rkt
View File

@ -35,6 +35,8 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
"strace.rkt") "strace.rkt")
(struct environment (namespace compile ann-top raw-cover)) (struct environment (namespace compile ann-top raw-cover))
;; A special structure used for communicating information about programs that call `exit`
(struct an-exit (code))
;;; ---------------------- Running Files --------------------------------- ;;; ---------------------- Running Files ---------------------------------
@ -52,61 +54,68 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b
(match p (match p
[(cons p _) p] [(cons p _) p]
[_ p]))) [_ p])))
(define tests-failed #f) (define tests-failed
(define old-check (current-check-handler)) (parameterize* ([current-load/use-compiled (make-cover-load/use-compiled abs-names)]
(struct an-exit (code)) [current-output-port
(parameterize* ([current-load/use-compiled (make-cover-load/use-compiled abs-names)] (if (verbose) (current-output-port) (open-output-nowhere))]
[current-output-port [current-namespace (get-namespace)])
(if (verbose) (current-output-port) (open-output-nowhere))] (for ([f (in-list abs-names)])
[exit-handler (lambda (x) (raise (an-exit x)))] (compile-file f))
[current-namespace (get-namespace)]) (for/fold ([tests-failed #f]) ([f (in-list abs)])
(for ([the-file (in-list abs-names)]) (define failed? (handle-file f submod-name))
#| (and failed? tests-failed))))
(define f (path->string (file-name-from-path p)))
(define ext (bytes->string/locale (filename-extension f)))
(define name (string->symbol (substring f 0 (- (string-length f) 1 (string-length ext)))))
((current-load/use-compiled)
p
name)
|#
(dynamic-require `(file ,(if (path? the-file) (path->string the-file) the-file)) (void)))
(for ([p (in-list abs)])
(vprintf "attempting to run ~s\n" p)
(define the-file (if (list? p) (car p) p))
(define argv (if (list? p) (cadr p) #()))
(parameterize ([current-command-line-arguments argv]
[current-check-handler ;(get-check-handler-parameter)
(lambda x
(set! tests-failed #t)
(vprintf "file ~s had failed tests\n" p)
(apply old-check x))])
(with-handlers ([(lambda (x) (or (not (exn? x)) (exn:fail? x)))
(lambda (x)
(cond [(an-exit? x)
(vprintf "file ~s exited code ~s" p (an-exit-code x))]
[else
(set! tests-failed #t)
(error-display x)]))])
(vprintf "running file: ~s with args: ~s\n" the-file argv)
(run-file the-file submod-name)))))
(vprintf "ran ~s\n" files) (vprintf "ran ~s\n" files)
(remove-unneeded-results! abs-names) (remove-unneeded-results! abs-names)
(not tests-failed))) (not tests-failed)))
;;; ---------------------- Running Aux --------------------------------- ;;; ---------------------- Running Aux ---------------------------------
(define (run-file the-file submod-name)
(define sfile `(file ,(if (path? the-file) (path->string the-file) the-file))) ;; PathString -> Void
(define (compile-file the-file)
(dynamic-require (build-file-require the-file) (void)))
;; (or PathString (list PathString Vector)) Symbol -> Boolean
;; returns if any tests failed or errors occured
(define (handle-file maybe-path submod-name)
(define tests-failed #f)
(define old-check (current-check-handler))
(vprintf "attempting to run ~s\n" maybe-path)
(define the-file (if (list? maybe-path) (first maybe-path) maybe-path))
(define argv (if (list? maybe-path) (second maybe-path) #()))
(with-handlers ([(lambda (x) (or (not (exn? x)) (exn:fail? x)))
(lambda (x)
(cond [(an-exit? x)
(vprintf "file ~s exited code ~s" maybe-path (an-exit-code x))]
[else
(set! tests-failed #t)
(error-display x)]))])
(parameterize ([current-command-line-arguments argv]
[exit-handler (lambda (x) (raise (an-exit x)))]
[current-check-handler ;(get-check-handler-parameter)
(lambda x
(set! tests-failed #t)
(vprintf "file ~s had failed tests\n" maybe-path)
(apply old-check x))])
(vprintf "running file: ~s with args: ~s\n" the-file argv)
(exec-file the-file submod-name)))
tests-failed)
;; PathString Symbol -> Void
(define (exec-file the-file submod-name)
(define sfile (build-file-require the-file))
(define submod `(submod ,sfile ,submod-name)) (define submod `(submod ,sfile ,submod-name))
(run-mod (if (module-declared? submod #t) submod sfile))) (run-mod (if (module-declared? submod #t) submod sfile)))
;; ModulePath -> Any
(define (run-mod to-run) (define (run-mod to-run)
(vprintf "running ~s\n" to-run) (vprintf "running ~s\n" to-run)
(do-dyn-req-expr to-run) (dynamic-require to-run 0)
(vprintf "finished running ~s\n" to-run)) (vprintf "finished running ~s\n" to-run))
(define (do-dyn-req-expr to-run) ;; PathString -> ModulePath
(dynamic-require to-run 0)) (define (build-file-require the-file)
`(file ,(if (path? the-file) (path->string the-file) the-file)))
;; [Listof Any] -> Void ;; [Listof Any] -> Void
;; remove any files not in paths from the raw coverage ;; remove any files not in paths from the raw coverage

187
strace.rkt
View File

@ -11,21 +11,14 @@
"private/file-utils.rkt" "private/file-utils.rkt"
"private/shared.rkt") "private/shared.rkt")
(define (make-annotate-top c cover-name)
(define (with-mark src dest phase) dest)
(define test-coverage-enabled (make-parameter #t))
(define (make-annotate-top c cover-name)
(define lift-name #'do-lift) (define lift-name #'do-lift)
(define set-box-name #'set-box!) (define set-box-name #'set-box!)
(define hash-ref-name #'hash-ref) (define hash-ref-name #'hash-ref)
;; -------- Specific `stacktrace^` Imports --------------
(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 (initialize-test-coverage-point stx) (define (initialize-test-coverage-point stx)
(define srcloc (stx->srcloc stx)) (define srcloc (stx->srcloc stx))
(when srcloc (when srcloc
@ -41,32 +34,8 @@
#`(#%plain-app set-box! (do-lift (#%plain-app hash-ref c loc)) #t))) #`(#%plain-app set-box! (do-lift (#%plain-app hash-ref c loc)) #t)))
(define (make-srcloc-maker f) ;; -------- Cover's Specific Annotators --------------
(lambda (stx) (define (make-cover-annotate-top annotate-top)
(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 list))
(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 o (current-output-port))
(define (in:annotate-top annotate-top)
(lambda (stx phase) (lambda (stx phase)
(define e (add-cover-require stx)) (define e (add-cover-require stx))
(if e (expand-syntax (annotate-clean (annotate-top (expand-syntax e) phase))) stx))) (if e (expand-syntax (annotate-clean (annotate-top (expand-syntax e) phase))) stx)))
@ -76,61 +45,103 @@
(#%variable-reference))) (#%variable-reference)))
(let loop ([expr expr] [top #t]) (let loop ([expr expr] [top #t])
(define disarmed (syntax-disarm expr inspector)) (define disarmed (syntax-disarm expr inspector))
(kernel-syntax-case disarmed #f (kernel-syntax-case
[(module name lang (#%module-begin e ...)) disarmed #f
(member '(#%declare #:cross-phase-persistent) (syntax->datum #'(e ...))) [(module name lang (#%module-begin e ...))
#f] (member '(#%declare #:cross-phase-persistent) (syntax->datum #'(e ...)))
[(m name lang mb) #f]
(or (eq? 'module (syntax-e #'m)) [(m name lang mb)
(eq? 'module* (syntax-e #'m))) (or (eq? 'module (syntax-e #'m))
(with-syntax ([cover cover-name] (eq? 'module* (syntax-e #'m)))
[set-box set-box-name] (with-syntax ([cover cover-name]
[hash-rf hash-ref-name] [set-box set-box-name]
[do-lift lift-name]) [hash-rf hash-ref-name]
(define lexical? (eq? #f (syntax-e #'lang))) [do-lift lift-name])
(syntax-case (syntax-disarm #'mb inspector) () (define lexical? (eq? #f (syntax-e #'lang)))
[(#%module-begin b ...) (syntax-case (syntax-disarm #'mb inspector) ()
(let () [(#%module-begin b ...)
(define/with-syntax (body ...) (let ()
(map (lambda (e) (loop e #f)) (define/with-syntax (body ...)
(syntax->list #'(b ...)))) (map (lambda (e) (loop e #f))
(define/with-syntax (add ...) (syntax->list #'(b ...))))
#'((#%require (rename cover/coverage cover coverage) (define/with-syntax (add ...)
(rename '#%kernel set-box set-box!) #'((#%require (rename cover/coverage cover coverage)
(rename '#%kernel haah-rf hash-ref)) (rename '#%kernel set-box set-box!)
(#%require (for-syntax '#%kernel)) (rename '#%kernel haah-rf hash-ref))
(define-syntaxes (do-lift) (#%require (for-syntax '#%kernel))
(lambda (stx) (define-syntaxes (do-lift)
(syntax-local-lift-expression (lambda (stx)
(cadr (syntax-e stx))))))) (syntax-local-lift-expression
(define stx (cadr (syntax-e stx)))))))
#'(m name lang (define stx
(#%module-begin add ... body ...))) #'(m name lang
(rebuild-syntax stx disarmed expr))]))] (#%module-begin add ... body ...)))
[_ (if top #f expr)]))) (rebuild-syntax stx disarmed expr))]))]
[_ (if top #f expr)])))
(define (rebuild-syntax stx disarmed armed)
(syntax-rearm
(namespace-syntax-introduce
(datum->syntax
disarmed
(syntax-e stx)
disarmed
disarmed))
armed))
;; in order to write modules to disk the top level needs to ;; 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 ;; be a module. so we trust that the module is loaded and trim the expression
(define (annotate-clean e) (define (annotate-clean e)
(kernel-syntax-case e #f (kernel-syntax-case
[(begin e mod) e #f
(begin [(begin e mod)
(syntax-case #'e (#%plain-app set-box! do-lift make-srcloc hash-ref) (begin
[(#%plain-app set-box! (lift (#%plain-app hash-ref _ (quote v))) _) (syntax-case #'e (#%plain-app set-box! do-lift make-srcloc hash-ref)
(let ([location (syntax->datum #'v)]) [(#%plain-app set-box! (lift (#%plain-app hash-ref _ (quote v))) _)
(set-box! (hash-ref c location) #t))]) (let ([location (syntax->datum #'v)])
#'mod)] (set-box! (hash-ref c location) #t))])
[_ e])) #'mod)]
[_ e]))
;; ---- IN ----
(define-values/invoke-unit/infer stacktrace@) (define-values/invoke-unit/infer stacktrace@)
(in:annotate-top annotate-top)) (make-cover-annotate-top annotate-top))
;; -------- Generic `stacktrace^` Imports --------------
(define (with-mark src dest phase) dest)
(define test-coverage-enabled (make-parameter #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)
;; -------- Annotation Helpers --------------
(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 list))
(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 (rebuild-syntax stx disarmed armed)
(syntax-rearm
(namespace-syntax-introduce
(datum->syntax
disarmed
(syntax-e stx)
disarmed
disarmed))
armed))

5
tests/do-dont-run.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require rackunit "../main.rkt" racket/runtime-path) (require rackunit "../main.rkt" racket/runtime-path racket/port)
(define-runtime-path dont-run.rkt "dont-run.rkt") (define-runtime-path dont-run.rkt "dont-run.rkt")
(check-not-exn (check-not-exn
(lambda () (test-files! (path->string dont-run.rkt)))) (lambda ()
(check-true (test-files! (path->string dont-run.rkt)))))