made verbose-mode shiney

cover.rkt

@@ -6,8 +6,10 @@
          racket/function
          syntax/modread
          syntax/parse
+         unstable/syntax
          racket/runtime-path
-         rackunit)
+         rackunit
+         "private/shared.rkt")
 
 
 
@@ -27,6 +29,7 @@
       (define-values (loc type) (get-module-path (build-path p)))
       (case type
         [(zo so)
+         (vprintf "deleting compiled file: ~s\n" loc)
          (delete-file loc)
          (loop)]
         [else (void)])))
@@ -36,11 +39,13 @@
                  [current-compile (make-better-test-compile)])
     (define tests-failed #f)
     (for ([p paths])
+      (vprintf "running file: ~s\n" p)
       (define old-check (current-check-handler))
       (parameterize* ([current-namespace ns]
                       [current-check-handler
                        (lambda x
                          (set! tests-failed #t)
+                         (vprintf "file ~s had failed tests\n" p)
                          (apply old-check x))])
         (eval `(dynamic-require '(file ,p) #f))
         (namespace-require `(file ,p))
@@ -56,11 +61,17 @@
   (define annotate-top (get-annotate-top))
   (lambda (e immediate-eval?)
     (define to-compile
-      (if (eq? reg (namespace-module-registry (current-namespace)))
-          (annotate-top
-           (if (syntax? e) (expand e) (datum->syntax #f e))
-           phase)
-          e))
+      (cond [(eq? reg (namespace-module-registry (current-namespace)))
+             (vprintf "compiling ~s with coverage annotations\n"
+                      (if (not (syntax? e))
+                          e
+                          (or (syntax-source-file-name e)
+                              (syntax-source e)
+                              e)))
+             (annotate-top
+              (if (syntax? e) (expand e) (datum->syntax #f e))
+              phase)]
+            [else e]))
     (compile to-compile immediate-eval?)))
 
 (define-runtime-path cov "coverage.rkt")
@@ -82,6 +93,7 @@
 ;; that srcloc was covered or not
 ;; based on <pkgs>/drracket/drracket/private/debug.rkt
 (define (get-test-coverage)
+  (vprintf "generating test coverage\n")
   ;; can-annotate : (listof (list boolean srcloc))
   ;; boolean is #t => code was run
   ;;            #f => code was not run

private/coveralls.rkt

@@ -17,15 +17,16 @@
   (define meta-data (determine-build-type))
   (define meta-with-git-info (hash-merge meta-data (get-git-info)))
   (define data (hash-merge json meta-with-git-info))
+  (vprintf "writing json to file ~s\n" coverage-file)
   (with-output-to-file coverage-file
     (thunk (write-json data))
     #:exists 'replace)
-  (when (verbose)
-    (printf "\n\n\nwriting json to file ~s\n" coverage-file)
-    (write-json data (current-output-port))
-    (printf "\n\n\n")
-    (printf "calling ~a\n\n\n" (list (path->string post) coverage-file)))
-  (system* (path->string post) coverage-file))
+  (vprintf "invoking coveralls API")
+  (parameterize ([current-output-port
+                  (if (verbose)
+                      (current-output-port)
+                      (open-output-nowhere))])
+    (void (system* (path->string post) coverage-file))))
 
 ;; Maps service name to the environment variable that indicates that the service is to be used.
 (define BUILD-TYPES (hash "travis-ci" "TRAVIS_JOB_ID"))
@@ -35,6 +36,8 @@
 (define (determine-build-type)
   (define service-name (for/first ([(name var) BUILD-TYPES] #:when (getenv var)) name))
   (define repo-token (getenv "COVERALLS_REPO_TOKEN"))
+  (vprintf "using repo token: ~s\n" repo-token)
+  (vprintf "using service name: ~s\n" service-name)
   (cond [service-name
          (hasheq 'service_name service-name
                  'service_job_id (getenv (hash-ref BUILD-TYPES service-name))

private/format-utils.rkt

@@ -1,6 +1,7 @@
 #lang racket
 (provide get-percentages/top get-percentages/file make-covered?)
-(require syntax/modread syntax/parse unstable/sequence syntax-color/racket-lexer)
+(require syntax/modread syntax/parse unstable/sequence syntax-color/racket-lexer
+         "shared.rkt")
 (module+ test (require rackunit "../cover.rkt" racket/runtime-path))
 
 ;;;;; a Coverage is the output of (get-test-coverage)
@@ -97,6 +98,7 @@
 
 ;; Path FileCoverage OffsetFunc -> [Hashof Natural Cover]
 (define (coverage-cache-file f c raw-offset)
+  (vprintf "caching coverage info for ~s\n" f)
   (with-input-from-file f
     (thunk
      (define lexer

private/html.rkt

@@ -1,6 +1,10 @@
 #lang racket
 (provide generate-html-coverage)
-(require (only-in xml write-xexpr) "format-utils.rkt" racket/runtime-path)
+(require racket/runtime-path
+         (only-in xml write-xexpr)
+         "format-utils.rkt"
+         "shared.rkt")
+
 
 (module+ test
   (require rackunit "../cover.rkt" racket/runtime-path))
@@ -29,13 +33,17 @@
                         (list "main.css")))))
       (make-directory* output-dir)
       (with-output-to-file output-file
-        (λ () (write-xexpr (make-html-file (hash-ref coverage k) k path-to-css)))
+        (λ ()
+          (define expr (make-html-file (hash-ref coverage k) k path-to-css))
+          (vprintf "writing html coverage for ~s to ~s\n" k output-file)
+          (write-xexpr expr))
         #:exists 'replace)
       output-file))
   (build-index! coverage file-list dir)
   (move-support-files! dir))
 
 (define (build-index! coverage file-list dir)
+  (vprintf "building index.html\n")
   (define %ages (get-percentages/top coverage))
   (define xexpr
     `(html

private/shared.rkt

@@ -1,3 +1,10 @@
 #lang racket/base
-(provide verbose)
+(provide verbose vprintf)
+(require (for-syntax racket/base))
 (define verbose (make-parameter #f))
+
+;; like printf but only in verbose mode
+(define o (current-output-port))
+(define (vprintf . a)
+  (when (verbose)
+    (apply fprintf o a)))