221 lines
7.3 KiB
Racket
221 lines
7.3 KiB
Racket
#lang racket
|
|
(provide get-percentages/top get-percentages/file make-covered?)
|
|
(require syntax/modread syntax/parse unstable/sequence syntax-color/racket-lexer)
|
|
(module+ test (require rackunit "../cover.rkt" racket/runtime-path))
|
|
|
|
;;;;; a Coverage is the output of (get-test-coverage)
|
|
;;;;; a FileCoverage is the values of the hashmap from (get-test-coverage)
|
|
|
|
;;;;; percentage
|
|
;; A Percentage is a [HashMap Type Real∈[0,1]]
|
|
;; a Type is one of: (update this as needed)
|
|
;; 'expr
|
|
|
|
;; TODO this needs not count submodules and test directories
|
|
|
|
;; Coverage -> Percentage
|
|
(define (get-percentages/top coverage)
|
|
(hash
|
|
'expr (file-percentages->top expr-percentage coverage)))
|
|
|
|
(define (file-percentages->top get-% coverage)
|
|
(define per-file
|
|
(for/list ([(f v) coverage])
|
|
(define covered? (make-covered? v f))
|
|
(call-with-values (thunk (get-% f covered?)) list)))
|
|
(define total (for/sum ([v per-file]) (second v)))
|
|
(for/sum ([v per-file])
|
|
(* (first v) (/ (second v) total))))
|
|
|
|
;; PathString Covered? -> Percentage
|
|
(define (get-percentages/file path covered?)
|
|
(hash
|
|
'expr (first (call-with-values (thunk (expr-percentage path covered?)) list))))
|
|
|
|
;;; percentage generators. each one has the type:
|
|
;; FilePath Covered? -> Real∈[0,1] Natural
|
|
;; there the Real is the percentage covered
|
|
;; and the Natural is the number of things of that type in the file
|
|
(define (expr-percentage path covered?)
|
|
(define (is-covered? e)
|
|
;; we don't need to look at the span because the coverage is expression based
|
|
(define p (syntax-position e))
|
|
(covered? p #:byte? #t))
|
|
|
|
(define e
|
|
(with-module-reading-parameterization
|
|
(thunk (with-input-from-file path read-syntax))))
|
|
(define (ret e)
|
|
(values (e->n e) (a->n e)))
|
|
(define (a->n e)
|
|
(case (is-covered? e)
|
|
[(yes no) 1]
|
|
[else 0]))
|
|
(define (e->n e)
|
|
(if (eq? (is-covered? e) 'yes) 1 0))
|
|
(define-values (covered count)
|
|
(let recur ([e e])
|
|
(syntax-parse e
|
|
[(v ...)
|
|
(for/fold ([covered (e->n e)] [count (a->n e)])
|
|
([e (in-syntax e)])
|
|
(define-values (cov cnt) (recur e))
|
|
(values (+ covered cov)
|
|
(+ count cnt)))]
|
|
[e:expr (ret #'e)]
|
|
[_ (values 0 0)])))
|
|
(values (/ covered count) count))
|
|
|
|
(module+ test
|
|
(define-runtime-path path "../tests/basic/prog.rkt")
|
|
(test-begin
|
|
(define f (path->string (simplify-path path)))
|
|
(test-files! f)
|
|
(define covered? (make-covered? (hash-ref (get-test-coverage) f) f))
|
|
(define-values (result _) (expr-percentage f covered?))
|
|
(check-equal? result 1)
|
|
(clear-coverage!)))
|
|
|
|
;;;;; utils
|
|
|
|
;;; a Cover is (U 'yes 'no 'missing)
|
|
|
|
;; [Hashof PathString [Hashof Natural Cover]]
|
|
|
|
;; Natural FileCoverage PathString -> Cover
|
|
(define (make-covered? c path)
|
|
(define vec
|
|
(list->vector (string->list (file->string path))))
|
|
(define file/str->byte-offset (make-str->byte-offset vec))
|
|
(define file/byte->str-offset (make-byte->str-offset vec))
|
|
(define file-location-coverage-cache
|
|
(coverage-cache-file path c file/str->byte-offset))
|
|
(lambda (loc #:byte? [byte? #f])
|
|
(hash-ref file-location-coverage-cache (if (not byte?) loc (- loc (file/byte->str-offset loc)))
|
|
(lambda () (error 'covered? "char ~s was not cache for file ~s" loc path)))))
|
|
|
|
|
|
;; Path FileCoverage OffsetFunc -> [Hashof Natural Cover]
|
|
(define (coverage-cache-file f c raw-offset)
|
|
(with-input-from-file f
|
|
(thunk
|
|
(define lexer
|
|
((read-language) 'color-lexer racket-lexer))
|
|
(define irrelevant? (make-irrelevant? lexer f))
|
|
(define file-length (string-length (file->string f)))
|
|
(define cache
|
|
(for/hash ([i (range 1 (add1 file-length))])
|
|
(values i
|
|
(cond [(irrelevant? i) 'missing]
|
|
[else (raw-covered? i c raw-offset)]))))
|
|
cache)))
|
|
|
|
;; TODO should we only ignore test (and main) submodules?
|
|
(define (make-irrelevant? lexer f)
|
|
(define s (mutable-set))
|
|
(define-values (for-lex for-str) (dup-input-port (current-input-port)))
|
|
(define str (apply vector (string->list (port->string for-str))))
|
|
(define init-offset (- (string-length (file->string f))
|
|
(vector-length str)))
|
|
|
|
(define offset (make-str->byte-offset str))
|
|
|
|
(let loop ()
|
|
(define-values (v type _m start end) (lexer for-lex))
|
|
(case type
|
|
[(eof) (void)]
|
|
[(comment sexp-comment no-color white-space)
|
|
(for ([i (in-range (- start (offset start)) (- end (offset end)))])
|
|
(set-add! s (+ init-offset i)))
|
|
(loop)]
|
|
[else (loop)]))
|
|
(define stx
|
|
(with-input-from-file f
|
|
(thunk (with-module-reading-parameterization read-syntax))))
|
|
|
|
(define offset/mod (make-byte->str-offset str))
|
|
(let loop ([stx stx] [first? #t])
|
|
(define (loop* stx) (loop stx #f))
|
|
(syntax-parse stx
|
|
#:datum-literals (module module* module+)
|
|
[((~or module module* module+) e ...)
|
|
#:when (not first?)
|
|
(define start (syntax-position stx))
|
|
(when start
|
|
(define end (+ start (syntax-span stx)))
|
|
(for ([i (in-range (- start (offset/mod start))
|
|
(- end (offset/mod end)))])
|
|
(set-add! s i)))]
|
|
[(e ...) (for-each loop* (syntax->list #'(e ...)))]
|
|
[_else (void)]))
|
|
(lambda (i) (set-member? s i)))
|
|
|
|
(define (dup-input-port p)
|
|
(define-values (i1 o1) (make-pipe))
|
|
(define-values (i2 o2) (make-pipe))
|
|
(copy-port p o1 o2)
|
|
(close-output-port o1)
|
|
(close-output-port o2)
|
|
(values i1 i2))
|
|
|
|
(define (in-syntax-object? i stx)
|
|
(define p (syntax-position stx))
|
|
(define r (syntax-span stx))
|
|
(<= p i (+ p r)))
|
|
|
|
(define (raw-covered? i c raw-offset)
|
|
(define loc (+ (raw-offset i) i))
|
|
(define-values (mode _)
|
|
(for/fold ([mode 'none] [last-start 0])
|
|
([pair (in-list c)])
|
|
(match pair
|
|
[(list m (srcloc _ _ _ start range))
|
|
(if (and (<= start loc (+ start range -1))
|
|
(or (eq? mode 'none)
|
|
(> start last-start)))
|
|
(values m start)
|
|
(values mode last-start))])))
|
|
(case mode
|
|
[(#t) 'yes]
|
|
[(#f) 'no]
|
|
[else 'missing]))
|
|
|
|
;; use for determining character/byte offsets for a given
|
|
;; 1 indexed character location
|
|
(define ((make-str->byte-offset str) offset)
|
|
(let loop ([s 0] [b 0])
|
|
(cond [(or (= (sub1 offset) b)
|
|
(>= s (vector-length str)))
|
|
(- b s)]
|
|
[else
|
|
(define l (char-utf-8-length (vector-ref str s)))
|
|
(loop (add1 s) (+ b l))])))
|
|
|
|
;; used for determining character/byte offsets for a given
|
|
;; 1 indexed byte locaiton
|
|
(define ((make-byte->str-offset str) offset)
|
|
(let loop ([s 0] [b 0])
|
|
(cond [(or (= (sub1 offset) s)
|
|
(>= s (vector-length str)))
|
|
(- b s)]
|
|
[else
|
|
(define l (char-utf-8-length (vector-ref str s)))
|
|
(loop (add1 s) (+ b l))])))
|
|
|
|
(module+ test
|
|
(define-runtime-path path2 "../tests/prog.rkt")
|
|
(test-begin
|
|
(define f (path->string (simplify-path path2)))
|
|
(test-files! f)
|
|
(define coverage (hash-ref (get-test-coverage) f))
|
|
(define covered? (make-covered? coverage f))
|
|
(check-equal? (covered? 14) 'missing)
|
|
(check-equal? (covered? 17) 'missing)
|
|
(check-equal? (covered? 28) 'missing)
|
|
(check-equal? (covered? 35) 'yes)
|
|
(check-equal? (covered? 50) 'no)
|
|
(check-equal? (covered? 52) 'missing)
|
|
(check-equal? (covered? 53) 'missing)
|
|
(check-equal? (covered? 54) 'missing)
|
|
(clear-coverage!)))
|