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

bug fixing in xexpr generation

Browse Source
This commit is contained in:
Spencer Florence 2014-12-28 11:08:45 -06:00
parent 417a9330bf
commit 4cfef79533
1 changed files with 40 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
format.rkt
View File

@ -34,10 +34,10 @@
(for/sum ([v per-file]) (for/sum ([v per-file])
(* (first v) (/ (second v) total)))) (* (first v) (/ (second v) total))))
;; PathString (list (list bool srcloc)) -> Coverage ;; PathString FileCoverage -> Percentage
(define (get-percentages/file path coverage) (define (get-percentages/file path coverage)
(hash (hash
'expr (expr-percentage path coverage))) 'expr (first (call-with-values (thunk (expr-percentage path coverage)) list))))
;;; percentage generators. each one has the type: ;;; percentage generators. each one has the type:
;; FileCoverage -> Real∈[0,1] Natural ;; FileCoverage -> Real∈[0,1] Natural
@ -82,27 +82,39 @@
(clear-coverage!))) (clear-coverage!)))
;;;;; html ;;;;; html
;; FileCoverage PathString -> Xexpr
(define (make-html-file coverage path) (define (make-html-file coverage path)
(string-append (define %age (get-percentages/file path coverage))
`(html () `(html ()
(body () (body ()
,(file->html coverage path))))) ,@(for/list ([(type %) %age])
(define (file->html coverage paths) `(p () ,(~a type ': " " (~r (* 100 %) #:precision 2) "%") (br ())))
(for/list ([path paths]) ,(file->html coverage path))))
(define file (file->string path)) (module+ test
(define cover (hash-ref coverage path)) (test-begin
(let loop ([loc 1] [start 1] [left (string-length file)] [mode (covered? 1 cover)]) (define f
(define (get-xml) (path->string (build-path (current-directory) "tests/basic/prog.rkt")))
(mode-xml mode (encode-string (substring file (sub1 start) (sub1 loc))))) (test-files! f)
(case left (check-equal? (make-html-file (hash-ref (get-test-coverage) f) f)
[(0) (get-xml)] `(html ()
[else (body ()
(define m (covered? loc cover)) (p () "expr: 100%" (br ()))
(define (loop* start) (loop (add1 loc) start (sub1 left) m)) ,(file->html (hash-ref (get-test-coverage) f) f))))
(if (eq? m mode) (clear-coverage!)))
(loop* start) (define (file->html cover path)
(cons (get-xml) (define file (file->string path))
(loop* (add1 loc))))])))) (let loop ([loc 1] [start 1] [left (string-length file)] [mode (covered? 1 cover)])
(define (get-xml)
(mode-xml mode (encode-string (substring file (sub1 start) (sub1 loc)))))
(case left
[(0) (get-xml)]
[else
(define m (covered? loc cover))
(define (loop* start) (loop (add1 loc) start (sub1 left) m))
(if (eq? m mode)
(loop* start)
(cons (get-xml)
(loop* (add1 loc))))])))
(define (get-mode loc c) (define (get-mode loc c)
(define-values (mode _) (define-values (mode _)
@ -125,11 +137,12 @@
[#f `(span ((style "color:red")) ,body)])) [#f `(span ((style "color:red")) ,body)]))
(module+ test (module+ test
(define (test file out) (define (test f out)
(define file (path->string (build-path (current-directory) f)))
(test-files! file) (test-files! file)
(check-equal? (file->html (get-test-coverage) (check-equal? (file->html (hash-ref (get-test-coverage) file)
(list (path->string (build-path (current-directory) file)))) file)
(list out)) out)
(clear-coverage!)) (clear-coverage!))
(test "tests/basic/prog.rkt" (test "tests/basic/prog.rkt"
`(span ((style "color:green")) `(span ((style "color:green"))
@ -138,7 +151,7 @@
;;;; utils ;;;; utils
;; FileCoverage -> Boolean ;; Natural FileCoverage -> Boolean
(define (covered? loc c) (define (covered? loc c)
(define-values (mode _) (define-values (mode _)
(for/fold ([mode 'none] [last-start 0]) (for/fold ([mode 'none] [last-start 0])