From 43351bd5eb96c910a86da5364fb79d99f6659b2d Mon Sep 17 00:00:00 2001 From: Spencer Florence Date: Sun, 2 Aug 2015 12:57:33 -0500 Subject: [PATCH] cleaning things up for repo split --- cover/Makefile | 2 +- cover/cover.rkt | 2 - cover/format.rkt | 4 +- cover/info.rkt | 1 - cover/main.rkt | 1 - cover/private/coveralls.rkt | 232 ------------------------------------ cover/private/shared.rkt | 61 ++++++++-- cover/raco.rkt | 52 ++++---- cover/tests/do-reader.rkt | 13 +- 9 files changed, 91 insertions(+), 277 deletions(-) delete mode 100644 cover/private/coveralls.rkt diff --git a/cover/Makefile b/cover/Makefile index cd2f61a..5bcbd31 100644 --- a/cover/Makefile +++ b/cover/Makefile @@ -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 . diff --git a/cover/cover.rkt b/cover/cover.rkt index 30e8606..93feb56 100644 --- a/cover/cover.rkt +++ b/cover/cover.rkt @@ -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)) diff --git a/cover/format.rkt b/cover/format.rkt index f75819f..b5cbba3 100644 --- a/cover/format.rkt +++ b/cover/format.rkt @@ -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) diff --git a/cover/info.rkt b/cover/info.rkt index 77d4fe3..8f98687 100644 --- a/cover/info.rkt +++ b/cover/info.rkt @@ -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")) diff --git a/cover/main.rkt b/cover/main.rkt index c51cba5..e65244f 100644 --- a/cover/main.rkt +++ b/cover/main.rkt @@ -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])) diff --git a/cover/private/coveralls.rkt b/cover/private/coveralls.rkt deleted file mode 100644 index 983931c..0000000 --- a/cover/private/coveralls.rkt +++ /dev/null @@ -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))) diff --git a/cover/private/shared.rkt b/cover/private/shared.rkt index 131ca16..cf5a1ab 100644 --- a/cover/private/shared.rkt +++ b/cover/private/shared.rkt @@ -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)])))))) diff --git a/cover/raco.rkt b/cover/raco.rkt index 9498e35..ff78b29 100644 --- a/cover/raco.rkt +++ b/cover/raco.rkt @@ -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" diff --git a/cover/tests/do-reader.rkt b/cover/tests/do-reader.rkt index f784110..02fd7cd 100644 --- a/cover/tests/do-reader.rkt +++ b/cover/tests/do-reader.rkt @@ -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)))