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

cleaning things up for repo split

Browse Source
This commit is contained in:
Spencer Florence 2015-08-02 12:57:33 -05:00
parent 86f9b71b1e
commit 43351bd5eb
9 changed files with 91 additions and 277 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cover/Makefile
View File

@ -1,5 +1,5 @@
all:
raco setup --check-pkg-deps cover && raco test . && raco cover -b .
raco setup --check-pkg-deps --pkgs cover && raco test . && raco cover -b .
debug:
raco setup cover && raco test . && raco cover -vb .

2
cover/cover.rkt
View File

@ -66,8 +66,6 @@ information is converted to a usable form by `get-test-coverage`.
(define cover-load/use-compiled (make-cover-load/use-compiled abs-names))
(define tests-failed
(parameterize* ([current-load/use-compiled cover-load/use-compiled]
[current-output-port
(if (verbose) (current-output-port) (open-output-nowhere))]
[current-namespace (get-namespace)])
(for ([f (in-list abs-names)])
(compile-file f))

4
cover/format.rkt
View File

@ -1,3 +1,3 @@
#lang racket/base
(require "private/html/html.rkt" "private/coveralls.rkt" "private/raw.rkt")
(provide generate-html-coverage generate-coveralls-coverage generate-raw-coverage)
(require "private/html/html.rkt" "private/raw.rkt")
(provide generate-html-coverage generate-raw-coverage)

1
cover/info.rkt
View File

@ -1,7 +1,6 @@
#lang setup/infotab
(define cover-formats '(("html" cover generate-html-coverage)
("coveralls" cover generate-coveralls-coverage)
("raw" cover generate-raw-coverage)))
(define test-omit-paths (list "tests/error-file.rkt" "scribblings"))

1
cover/main.rkt
View File

@ -32,6 +32,5 @@
[irrelevant-submodules (parameter/c (or/c #f (listof symbol?)))]
[generate-coveralls-coverage coverage-gen/c]
[generate-html-coverage coverage-gen/c]
[generate-raw-coverage coverage-gen/c]))

232
cover/private/coveralls.rkt
View File

@ -1,232 +0,0 @@
#lang racket/base
(provide generate-coveralls-coverage)
(require json
racket/file
racket/function
racket/list
racket/path
racket/port
racket/pretty
racket/runtime-path
racket/string
racket/system
"file-utils.rkt"
"shared.rkt")
(module+ test
(require rackunit "../cover.rkt" racket/runtime-path)
(require (for-syntax racket/base))
(define-runtime-path tests/prog.rkt "../tests/prog.rkt")
(define-runtime-path root "..")
(define-syntax (with-env stx)
(syntax-case stx ()
[(test-with-env (env ...) test ...)
#'(parameterize ([current-environment-variables
(make-environment-variables
(string->bytes/utf-8 env) ...)])
test ...)])))
;; Coveralls
;; 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"))
;; Coverage [path-string] -> Void
(define-runtime-path post "curl.sh")
(define (generate-coveralls-coverage coverage files [dir "coverage"])
(send-coveralls-info (generate-and-save-data coverage files dir)))
(define (generate-and-save-data coverage files dir)
(make-directory* dir)
(define coverage-path dir)
(define coverage-file (build-path coverage-path "coverage.json"))
(define data (generate-coveralls-report coverage files))
(vprintf "writing json to file ~s\n" coverage-file)
(with-output-to-file coverage-file
(thunk (write-json data))
#:exists 'replace)
(vprintf "data written was:\n")
(vprintf #:printer pretty-print data)
coverage-file)
(module+ test
(test-begin
(with-env ("COVERALLS_REPO_TOKEN" "abc")
(define temp-dir (make-temporary-file "covertmp~a" 'directory))
(test-files! tests/prog.rkt)
(define coverage (get-test-coverage))
(define data-file (generate-and-save-data coverage (list (->absolute tests/prog.rkt)) temp-dir))
(define rfile (build-path temp-dir "coverage.json"))
(check-equal? data-file rfile)
(check-true (file-exists? rfile)))))
(define (send-coveralls-info coverage-file)
(vprintf "invoking coveralls API")
(parameterize ([current-output-port
(if (verbose)
(current-output-port)
(open-output-nowhere))])
(define result
(system* (path->string post)
coverage-file
(if (verbose) "-v" "")))
(unless result
(error 'coveralls "request to coveralls failed"))))
(define (generate-coveralls-report coverage files)
(define json (generate-source-files coverage files))
(define build-type (determine-build-type))
(define git-info (get-git-info))
(hash-merge json (hash-merge build-type git-info)))
(module+ test
(test-begin
(parameterize ([current-directory root]
[current-cover-environment (make-cover-environment)])
(define file (path->string (simplify-path tests/prog.rkt)))
(test-files! (path->string (simplify-path tests/prog.rkt)))
(define coverage (get-test-coverage))
(define report
(with-env ("COVERALLS_REPO_TOKEN" "abc")
(generate-coveralls-report coverage (list (->absolute file)))))
(check-equal?
(hash-ref report 'source_files)
(list (hasheq 'source (file->string tests/prog.rkt)
'coverage (line-coverage coverage file)
'name "tests/prog.rkt")))
(check-equal? (hash-ref report 'repo_token) "abc"))))
;; -> [Hasheq String String
;; Determine the type of build (e.g. repo token, travis, etc) and return the appropriate metadata
(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))
'repo_token repo-token)]
[repo-token (hasheq 'service_name "cover" 'repo_token repo-token)]
[else (error "No repo token or ci service detected")]))
(module+ test
(with-env ()
(check-exn void determine-build-type))
(with-env ("COVERALLS_REPO_TOKEN" "abc")
(check-equal? (determine-build-type)
(hasheq 'service_name "cover"
'repo_token "abc")))
(with-env ("TRAVIS_JOB_ID" "abc")
(check-equal? (determine-build-type)
(hasheq 'service_name "travis-ci"
'service_job_id "abc"
'repo_token #f))))
;; Coverage (Listof PathString) -> JSexpr
;; Generates a string that represents a valid coveralls json_file object
(define (generate-source-files coverage files)
(define src-files
(for/list ([file (in-list files)]
#:when (absolute-path? file))
(define local-file (path->string (->relative file)))
(define src (file->string file))
(define c (line-coverage coverage file))
(hasheq 'source src 'coverage c 'name local-file)))
(hasheq 'source_files src-files))
(module+ test
(test-begin
(parameterize ([current-directory root]
[current-cover-environment (make-cover-environment)])
(define file (path->string (simplify-path tests/prog.rkt)))
(test-files! (path->string (simplify-path tests/prog.rkt)))
(define coverage (get-test-coverage))
(check-equal?
(generate-source-files coverage (list file))
(hasheq 'source_files
(list (hasheq 'source (file->string tests/prog.rkt)
'coverage (line-coverage coverage file)
'name "tests/prog.rkt")))))))
;; CoverallsCoverage = Nat | json-null
;; Coverage PathString Covered? -> [Listof CoverallsCoverage]
;; Get the line coverage for the file to generate a coverage report
(define (line-coverage coverage file)
(define covered? (curry coverage file))
(define split-src (string-split (file->string file) "\n"))
(define (process-coverage value rst-of-line)
(case (covered? value)
['covered (if (equal? 'uncovered rst-of-line) rst-of-line 'covered)]
['uncovered 'uncovered]
[else rst-of-line]))
(define (process-coverage-value value)
(case value
['covered 1]
['uncovered 0]
[else (json-null)]))
(define-values (line-cover _)
(for/fold ([coverage '()] [count 1]) ([line (in-list split-src)])
(cond [(zero? (string-length line)) (values (cons (json-null) coverage) (add1 count))]
[else (define nw-count (+ count (string-length line) 1))
(define all-covered (foldr process-coverage 'irrelevant (range count nw-count)))
(values (cons (process-coverage-value all-covered) coverage) nw-count)])))
(reverse line-cover))
(module+ test
(define-runtime-path path "../tests/basic/not-run.rkt")
(let ()
(parameterize ([current-cover-environment (make-cover-environment)])
(define file (path->string (simplify-path path)))
(test-files! file)
(check-equal? (line-coverage (get-test-coverage) file) '(1 0)))))
(define (hash-merge h1 h2) (for/fold ([res h1]) ([(k v) h2]) (hash-set res k v)))
(module+ test
(let ()
(check-equal? (hash-merge (hash 'foo 3 'bar 5) (hash 'baz 6))
(hash 'foo 3 'bar 5 'baz 6))))
;; Git Magic
(define (get-git-info)
(hasheq 'git
(hasheq 'head (get-git-commit)
'branch (get-git-branch)
'remotes (get-git-remotes))))
(define (get-git-branch)
(string-trim
(or (getenv "TRAVIS_BRANCH")
(with-output-to-string (thunk (system "git rev-parse --abbrev-ref HEAD"))))))
(define (get-git-remotes)
(parse-git-remote (with-output-to-string (thunk (system "git remote -v")))))
(define (parse-git-remote raw)
(define lines (string-split raw "\n"))
(define fetch-only (filter (λ (line) (regexp-match #rx"\\(fetch\\)" line)) lines))
(for/list ([line (in-list fetch-only)])
(define split (string-split line))
(hasheq 'name (list-ref split 0)
'url (list-ref split 1))))
(module+ test
(test-begin
(define raw
"origin git@github.com:florence/cover.git (fetch)\norigin git@github.com:florence/cover.git (push)")
(check-equal? (parse-git-remote raw)
(list (hasheq 'name "origin"
'url "git@github.com:florence/cover.git")))))
(define (get-git-commit)
(define format (string-join '("%H" "%aN" "%ae" "%cN" "%ce" "%s") "%n"))
(define command (string-append "git --no-pager log -1 --pretty=format:" format))
(define log (with-output-to-string (thunk (system command))))
(define lines (string-split log "\n"))
(for/hasheq ([field (in-list '(id author_name author_email committer_name committer_email message))]
[line (in-list lines)])
(values field line)))

61
cover/private/shared.rkt
View File

@ -1,15 +1,60 @@
#lang racket/base
(provide verbose vprintf
(provide vprintf
logger-init-message
logger-covered-message)
(define verbose (make-parameter #f))
logger-covered-message
with-logging-to-port
with-intercepted-logging)
(define logger-init-message "init")
(define logger-covered-message "covered")
;; like printf but only in verbose mode
(define o (current-output-port))
(define (vprintf #:printer [printer printf] . a)
(when (verbose)
(parameterize ([current-output-port o])
(apply printer a))))
(define (vprintf #:formatter [format format] . a)
(log-message (current-logger)
'debug
'cover
(apply format a)
#f))
;; copied from racket/logging for backwards combatability reasons
(define (with-logging-to-port port proc . log-spec)
(apply with-intercepted-logging
(lambda (l) (displayln (vector-ref l 1) ; actual message
port))
proc
log-spec))
(define (with-intercepted-logging interceptor proc . log-spec)
(let* ([orig-logger (current-logger)]
;; We use a local logger to avoid getting messages that didn't
;; originate from proc. Since it's a child of the original logger,
;; the rest of the program still sees the log entries.
[logger (make-logger #f orig-logger)]
[receiver (apply make-log-receiver logger log-spec)]
[stop-chan (make-channel)]
[t (receiver-thread receiver stop-chan interceptor)])
(begin0
(parameterize ([current-logger logger])
(proc))
(channel-put stop-chan 'stop) ; stop the receiver thread
(thread-wait t))))
(define (receiver-thread receiver stop-chan intercept)
(thread
(lambda ()
(define (clear-events)
(let ([l (sync/timeout 0 receiver)])
(when l ; still something to read
(intercept l) ; interceptor gets the whole vector
(clear-events))))
(let loop ()
(let ([l (sync receiver stop-chan)])
(cond [(eq? l 'stop)
;; we received all the events we were supposed
;; to get, read them all (w/o waiting), then
;; stop
(clear-events)]
[else ; keep going
(intercept l)
(loop)]))))))

52
cover/raco.rkt
View File

@ -11,6 +11,7 @@
(only-in (submod compiler/commands/test paths) collection-paths)
racket/path
pkg/lib
racket/port
(for-syntax racket/base syntax/parse))
@ -26,6 +27,7 @@
(define submod 'test)
(define expansion-type 'dir)
(define irrel-submods #f)
(define verbose #f)
(define args
(command-line
@ -39,7 +41,7 @@
(set! output-format format)]
[("-v" "--verbose")
"Verbose mode"
(verbose #t)]
(set! verbose #t)]
[("-b" "--exclude-pkg-basics")
"exclude info.rkt, the tests directory, and the scribblings directory from the coverage report"
(set! exclude-paths (append '("info.rkt" "tests" "scribblings") exclude-paths))]
@ -76,27 +78,32 @@
(set! expansion-type 'lib)]
#:args (file . files)
(cons file files)))
(define path-expand
(case expansion-type
[(dir) expand-directories]
[(file) filter-exts]
[(lib) expand-lib]
[(collection) (lambda (a b) (expand-directories (flatten (map collection-paths a)) b))]
[(package) (lambda (a b)
(expand-directories (map pkg-directory a) b))]))
(define files (path-expand args include-exts))
(define generate-coverage
(hash-ref (get-formats) output-format
(lambda _ (error 'cover "given unknown coverage output format: ~s" output-format))))
(printf "generating test coverage for ~s\n" files)
(define passed (apply test-files! #:submod submod files))
(define coverage (get-test-coverage))
(define cleaned-files (remove-excluded-paths files exclude-paths))
(printf "dumping coverage info into ~s\n" coverage-dir)
(parameterize ([irrelevant-submodules irrel-submods])
(generate-coverage coverage cleaned-files coverage-dir))
(unless passed
(printf "some tests failed\n")))
(with-logging-to-port
(if verbose (current-error-port) (open-output-nowhere))
(lambda ()
(define path-expand
(case expansion-type
[(dir) expand-directories]
[(file) filter-exts]
[(lib) expand-lib]
[(collection) (lambda (a b) (expand-directories (flatten (map collection-paths a)) b))]
[(package) (lambda (a b)
(expand-directories (map pkg-directory a) b))]))
(define files (path-expand args include-exts))
(define generate-coverage
(hash-ref (get-formats) output-format
(lambda _ (error 'cover "given unknown coverage output format: ~s" output-format))))
(printf "generating test coverage for ~s\n" files)
(define passed (apply test-files! #:submod submod files))
(define coverage (get-test-coverage))
(define cleaned-files (remove-excluded-paths files exclude-paths))
(printf "dumping coverage info into ~s\n" coverage-dir)
(parameterize ([irrelevant-submodules irrel-submods])
(generate-coverage coverage cleaned-files coverage-dir))
(unless passed
(printf "some tests failed\n")))
'debug
'cover))
(define extensions '(#rx"\\.rkt$" #rx"\\.ss$" #rx"\\.scrbl"))
@ -162,7 +169,6 @@
(define-runtime-path main.rkt "main.rkt")
(define out
(set "main.rkt"
"private/coveralls.rkt"
"private/contracts.rkt"
"private/html/html.rkt"
"private/format-utils.rkt"

13
cover/tests/do-reader.rkt
View File

@ -1,10 +1,9 @@
#lang racket
(require racket/runtime-path "../main.rkt" rackunit "../private/shared.rkt")
(define-runtime-path reader.rkt "reader.rkt")
(parameterize ([verbose #t])
(check-not-exn
(thunk
(define r (path->string reader.rkt))
(test-files! r)
(define c (curry (get-test-coverage) r))
(c 10))))
(check-not-exn
(thunk
(define r (path->string reader.rkt))
(test-files! r)
(define c (curry (get-test-coverage) r))
(c 10)))