diff --git a/main.rkt b/main.rkt index 8e41e71..667e168 100644 --- a/main.rkt +++ b/main.rkt @@ -1,39 +1,55 @@ #lang racket/base -(provide test-files clear-coverage!) +(provide test-files! clear-coverage! get-test-coverage) +(require (for-syntax racket/base)) (require racket/dict racket/function syntax/modread syntax/parse "coverage.rkt" - "strace.rkt") + "strace.rkt" + racket/runtime-path) -(define ns (make-base-empty-namespace)) -(namespace-attach-module (current-namespace) "coverage.rkt" ns) -(define (test-files . paths) +(define ns (make-base-namespace)) +(define-runtime-path cov "coverage.rkt") +(namespace-attach-module (current-namespace) cov ns) + +(define-syntax (with-ns stx) + (syntax-case stx () + [(_ b ...) + #'(parameterize ([current-namespace ns]) + b ...)])) + +;; PathString * -> Void +;; Test files and build coverage map +(define (test-files! . paths) (for ([p paths]) (define stx (with-module-reading-parameterization (thunk (read-syntax p (open-input-file p))))) (define-values (name anned) - (syntax-parse (expand stx) + (syntax-parse (with-ns (expand stx)) #:datum-literals (module) [(~and s (module name:id lang forms ...)) (values (syntax-e #'name) (annotate-top #'s (namespace-base-phase ns)))])) (eval-syntax anned ns) ;; TODO run test/given submodule - (parameterize ([current-namespace ns]) - (namespace-require `',name))) - coverage) + (with-ns (namespace-require `',name)))) +;; -> Void +;; clear coverage map (define (clear-coverage!) (dict-clear! coverage) - (set! ns (make-base-empty-namespace)) - (namespace-attach-module (current-namespace) "coverage.rkt" ns)) + (set! ns (make-base-namespace)) + (namespace-attach-module (current-namespace) cov ns)) -(define (test-coverage-annotations) +;; -> [Hashof PathString (List Boolean srcloc)] +;; returns a hash of file to a list, where the first of the list is if +;; that srcloc was covered or not +;; based on /drracket/drracket/private/debug.rkt +(define (get-test-coverage) ;; can-annotate : (listof (list boolean srcloc)) ;; boolean is #t => code was run ;; #f => code was not run @@ -47,29 +63,30 @@ [span (syntax-span stx)]) (and pos span - #; - (hash-ref! port-name-cache src - (λ () (send (get-defs) port-name-matches? src))) (list covered? (make-srcloc src #f #f pos span)))))))) + ;; actions-ht : (list src number number) -> (list boolean syntax) + (define actions-ht (make-hash)) + + (for-each + (λ (pr) + (let* ([on? (car pr)] + [key (cadr pr)] + [old (hash-ref actions-ht key 'nothing)]) + (cond + [(eq? old 'nothing) (hash-set! actions-ht key on?)] + [old ;; recorded as executed + (void)] + [(not old) ;; recorded as unexected + (when on? + (hash-set! actions-ht key #t))]))) + can-annotate) + ;; filtered : (listof (list boolean srcloc)) ;; remove redundant expressions - (define filtered - ;; actions-ht : (list src number number) -> (list boolean syntax) - (let ([actions-ht (make-hash)]) - (for-each - (λ (pr) - (let* ([on? (list-ref pr 0)] - [key (list-ref pr 1)] - [old (hash-ref actions-ht key 'nothing)]) - (cond - [(eq? old 'nothing) (hash-set! actions-ht key on?)] - [old ;; recorded as executed - (void)] - [(not old) ;; recorded as unexected - (when on? - (hash-set! actions-ht key #t))]))) - can-annotate) - (hash-map actions-ht (λ (k v) (list v k))))) - filtered) + (define filtered (hash-map actions-ht (λ (k v) (list v k)))) + + (for/hash ([v filtered]) + (values (srcloc-source (cadr v)) + v))) diff --git a/tests/basic/coverage.rktl b/tests/basic/coverage.rktl new file mode 100644 index 0000000..2f2aace --- /dev/null +++ b/tests/basic/coverage.rktl @@ -0,0 +1 @@ +((1 21)) diff --git a/tests/main.rkt b/tests/main.rkt new file mode 100644 index 0000000..bf51b95 --- /dev/null +++ b/tests/main.rkt @@ -0,0 +1,43 @@ +#lang racket +(require better-test racket/runtime-path rackunit) + +(define (test-dir d) + (define program (string-append d "/prog.rkt")) + (define covered (string-append d "/coverage.rktl")) + + (test-files! program) + + (define actual-coverage (hash-ref (get-test-coverage) program)) + (define expected-coverage (ranges->numbers (with-input-from-file covered read))) + + (test-begin + (for ([i expected-coverage]) + (check-true (covered? i actual-coverage) + (format "expected char ~a to be covered, but it was not, in: ~s" + i d)))) + + (clear-coverage!)) + +(define (ranges->numbers range) + (match range + [(list) null] + [(cons (list a b) r) + (if (equal? a b) + (ranges->numbers r) + (cons a (ranges->numbers (cons (list (add1 a) b) r))))])) + +(define (covered? i map) + (for*/and ([l map] + [b (in-value (first map))] + [srcloc (in-value (second map))] + #:when (within? i srcloc)) + b)) + +(define (within? i src) + (match src + [(srcloc _ _ _ start range) + (>= start i (+ start range))])) + +(module+ test + (define-runtime-path-list test-dirs '("basic")) + (for-each (compose test-dir path->string) test-dirs))