From ed33f496f306d31d04791b088fc0bb28c632d987 Mon Sep 17 00:00:00 2001
From: Ryan Plessner <plessner.ryan@gmail.com>
Date: Sun, 28 Dec 2014 18:59:10 -0500
Subject: [PATCH] added coveralls json type. currently, only dumps to coverage
 directory

---
 format.rkt | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++--
 raco.rkt   |  4 +++-
 2 files changed, 59 insertions(+), 3 deletions(-)

diff --git a/format.rkt b/format.rkt
index 1905af7..428f67a 100644
--- a/format.rkt
+++ b/format.rkt
@@ -1,8 +1,9 @@
 #lang racket
-(provide generate-html-coverage)
+(provide generate-html-coverage generate-coveralls-coverage)
 (require syntax/modread 
          syntax/parse
-         unstable/sequence 
+         unstable/sequence
+         json
          (only-in xml write-xexpr))
 (module+ test (require rackunit "main.rkt"))
 
@@ -168,6 +169,59 @@
           ,@(encode-string (file->string "tests/basic/prog.rkt"))))))
 
 
+;; Coveralls
+
+;; Coverage [Hasheq String String] [path-string] -> Void
+(define (generate-coveralls-coverage coverage meta [dir "coverage"])
+  (make-directory* dir)
+  (define coverage-path (path->string (build-path (current-directory) dir)))
+  (with-output-to-file (string-append coverage-path "/coverage.json")
+    (λ () (write-json (generate-coveralls-json coverage meta)))
+    #:exists 'replace))
+
+;; Coverage [Hasheq String String] -> JSexpr
+;; Generates a string that represents a valid coveralls json_file object
+(define (generate-coveralls-json coverage meta)
+  (define src-files 
+    (for/list ([file (hash-keys coverage)])
+      (define src (file->string file))
+      (define c (line-coverage coverage file))
+      (hasheq 'src src 'coverage c)))
+  (hash-set meta 'source_files src-files))
+
+;; CoverallsCoverage = Nat | json-null
+
+;; Coverage PathString -> [Listof CoverallsCoverage]
+;; Get the line coverage for the file to generate a coverage report
+(define (line-coverage coverage file)
+  (define split-src (string-split (file->string file) "\n"))
+  (define file-coverage (hash-ref coverage file))
+  (define (process-coverage value rst-of-line)
+    (case (covered? value file-coverage file)
+      ['yes (if (equal? 'no rst-of-line) rst-of-line 'yes)]
+      ['no 'no]
+      [else rst-of-line]))
+  (define (process-coverage-value value)
+    (case value
+      ['yes 1]
+      ['no 0]
+      [else (json-null)]))
+  
+  (define-values (line-cover _)
+    (for/fold ([coverage '()] [count 0]) ([line split-src])
+      (cond [(zero? (string-length line)) (values (cons (json-null) coverage) (add1 count))]
+            [else (define nw-count (+ count (string-length line)))
+                  (define all-covered (foldr process-coverage 'missing (range count nw-count)))
+                  (values (cons (process-coverage-value all-covered) coverage) nw-count)])))
+  (reverse line-cover))
+
+(module+ test
+  (let ()
+    (define file (path->string (build-path (current-directory) "tests/basic/not-run.rkt")))
+    (test-files! file)
+    (check-equal? (line-coverage (get-test-coverage) file) '(1 0))
+    (clear-coverage!)))
+    
 ;;;; utils
 
 ;; Natural FileCoverage PathString -> (U 'yes 'no 'missing)
diff --git a/raco.rkt b/raco.rkt
index 212782e..c087fe8 100644
--- a/raco.rkt
+++ b/raco.rkt
@@ -23,8 +23,10 @@
   (define passed (apply test-files! files))
   (when coverage?
     (printf "COVERAGE!")
+    (define coverage (get-test-coverage))
     (case output-format
-      [("html") (generate-html-coverage (get-test-coverage) coverage-dir)]))
+      [("html") (generate-html-coverage coverage coverage-dir)]
+      [("coveralls") (generate-coveralls-coverage coverage (hasheq) coverage-dir)]))
   (exit
    (case passed
      [(#t) 0]