diff --git a/cover.rkt b/cover.rkt index 2f0f678..c73a20e 100644 --- a/cover.rkt +++ b/cover.rkt @@ -35,6 +35,8 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b "strace.rkt") (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 --------------------------------- @@ -52,61 +54,68 @@ in "coverage.rkt". This raw coverage information is converted to a usable form b (match p [(cons p _) p] [_ p]))) - (define tests-failed #f) - (define old-check (current-check-handler)) - (struct an-exit (code)) - (parameterize* ([current-load/use-compiled (make-cover-load/use-compiled abs-names)] - [current-output-port - (if (verbose) (current-output-port) (open-output-nowhere))] - [exit-handler (lambda (x) (raise (an-exit x)))] - [current-namespace (get-namespace)]) - (for ([the-file (in-list abs-names)]) - #| - (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))))) + (define tests-failed + (parameterize* ([current-load/use-compiled (make-cover-load/use-compiled abs-names)] + [current-output-port + (if (verbose) (current-output-port) (open-output-nowhere))] + [current-namespace (get-namespace)]) + (for ([f (in-list abs-names)]) + (compile-file f)) + (for/fold ([tests-failed #f]) ([f (in-list abs)]) + (define failed? (handle-file f submod-name)) + (and failed? tests-failed)))) (vprintf "ran ~s\n" files) (remove-unneeded-results! abs-names) (not tests-failed))) ;;; ---------------------- 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)) (run-mod (if (module-declared? submod #t) submod sfile))) +;; ModulePath -> Any (define (run-mod 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)) -(define (do-dyn-req-expr to-run) - (dynamic-require to-run 0)) +;; PathString -> ModulePath +(define (build-file-require the-file) + `(file ,(if (path? the-file) (path->string the-file) the-file))) ;; [Listof Any] -> Void ;; remove any files not in paths from the raw coverage diff --git a/strace.rkt b/strace.rkt index e35eb7a..8df837f 100644 --- a/strace.rkt +++ b/strace.rkt @@ -11,21 +11,14 @@ "private/file-utils.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 set-box-name #'set-box!) (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 srcloc (stx->srcloc stx)) (when srcloc @@ -41,32 +34,8 @@ #`(#%plain-app set-box! (do-lift (#%plain-app hash-ref c loc)) #t))) - (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 o (current-output-port)) - (define (in:annotate-top annotate-top) + ;; -------- Cover's Specific Annotators -------------- + (define (make-cover-annotate-top annotate-top) (lambda (stx phase) (define e (add-cover-require stx)) (if e (expand-syntax (annotate-clean (annotate-top (expand-syntax e) phase))) stx))) @@ -76,61 +45,103 @@ (#%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] - [(m name lang mb) - (or (eq? 'module (syntax-e #'m)) - (eq? 'module* (syntax-e #'m))) - (with-syntax ([cover cover-name] - [set-box set-box-name] - [hash-rf hash-ref-name] - [do-lift lift-name]) - (define lexical? (eq? #f (syntax-e #'lang))) - (syntax-case (syntax-disarm #'mb inspector) () - [(#%module-begin b ...) - (let () - (define/with-syntax (body ...) - (map (lambda (e) (loop e #f)) - (syntax->list #'(b ...)))) - (define/with-syntax (add ...) - #'((#%require (rename cover/coverage cover coverage) - (rename '#%kernel set-box set-box!) - (rename '#%kernel haah-rf hash-ref)) - (#%require (for-syntax '#%kernel)) - (define-syntaxes (do-lift) - (lambda (stx) - (syntax-local-lift-expression - (cadr (syntax-e stx))))))) - (define stx - #'(m name lang - (#%module-begin add ... body ...))) - (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)) - + (kernel-syntax-case + disarmed #f + [(module name lang (#%module-begin e ...)) + (member '(#%declare #:cross-phase-persistent) (syntax->datum #'(e ...))) + #f] + [(m name lang mb) + (or (eq? 'module (syntax-e #'m)) + (eq? 'module* (syntax-e #'m))) + (with-syntax ([cover cover-name] + [set-box set-box-name] + [hash-rf hash-ref-name] + [do-lift lift-name]) + (define lexical? (eq? #f (syntax-e #'lang))) + (syntax-case (syntax-disarm #'mb inspector) () + [(#%module-begin b ...) + (let () + (define/with-syntax (body ...) + (map (lambda (e) (loop e #f)) + (syntax->list #'(b ...)))) + (define/with-syntax (add ...) + #'((#%require (rename cover/coverage cover coverage) + (rename '#%kernel set-box set-box!) + (rename '#%kernel haah-rf hash-ref)) + (#%require (for-syntax '#%kernel)) + (define-syntaxes (do-lift) + (lambda (stx) + (syntax-local-lift-expression + (cadr (syntax-e stx))))))) + (define stx + #'(m name lang + (#%module-begin add ... body ...))) + (rebuild-syntax stx 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) - (begin - (syntax-case #'e (#%plain-app set-box! do-lift make-srcloc hash-ref) - [(#%plain-app set-box! (lift (#%plain-app hash-ref _ (quote v))) _) - (let ([location (syntax->datum #'v)]) - (set-box! (hash-ref c location) #t))]) - #'mod)] - [_ e])) + (kernel-syntax-case + e #f + [(begin e mod) + (begin + (syntax-case #'e (#%plain-app set-box! do-lift make-srcloc hash-ref) + [(#%plain-app set-box! (lift (#%plain-app hash-ref _ (quote v))) _) + (let ([location (syntax->datum #'v)]) + (set-box! (hash-ref c location) #t))]) + #'mod)] + [_ e])) + + ;; ---- IN ---- (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)) diff --git a/tests/do-dont-run.rkt b/tests/do-dont-run.rkt index 713abb8..c98d0a3 100644 --- a/tests/do-dont-run.rkt +++ b/tests/do-dont-run.rkt @@ -1,5 +1,6 @@ #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") (check-not-exn - (lambda () (test-files! (path->string dont-run.rkt)))) + (lambda () + (check-true (test-files! (path->string dont-run.rkt)))))