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

recoved from calls to

Browse Source
This commit is contained in:
Spencer Florence 2015-01-13 10:51:20 -05:00
parent 939502ed40
commit cba00ee2ad
6 changed files with 80 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
cover.rkt
View File

@ -22,32 +22,47 @@
;; returns true if all tests passed
(define (test-files! #:submod [submod-name 'test] . paths)
(unless ns (unloaded-error))
(define abs (map ->absolute paths))
(define abs
(for/list ([p paths])
(if (list? p)
(cons (->absolute (car p)) (cdr p))
(->absolute p))))
(parameterize ([current-load/use-compiled (make-cover-load/use-compiled paths)]
[use-compiled-file-paths
(cons (build-path "compiled" "cover")
(use-compiled-file-paths))]
[current-compile (make-cover-compile)]
[current-output-port (open-output-nowhere)])
[current-output-port
(if (verbose) (current-output-port) (open-output-nowhere))])
(define tests-failed #f)
(for ([p paths])
(vprintf "running file: ~s\n" p)
(vprintf "attempting to run ~s\n" p)
(define old-check (current-check-handler))
(define path (if (list? p) (car p) p))
(define argv (if (list? p) (cadr p) #()))
(vprintf "running file: ~s with args: ~s\n" path argv)
(struct an-exit ())
(define exited (an-exit))
(with-handlers ([(lambda (x) (or (not (exn? x)) (exn:fail? x)))
(lambda (x)
(set! tests-failed #t)
(error-display x))])
(parameterize* ([current-namespace ns]
(unless (eq? exited x)
(set! tests-failed #t)
(error-display x)))])
(parameterize* ([current-command-line-arguments argv]
[exit-handler (lambda (x) (raise exited))]
[current-namespace ns]
[(get-check-handler-parameter)
(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))
(define submod `(submod (file ,p) ,submod-name))
(when (module-declared? submod)
(namespace-require submod)))))
(define file `(file ,path))
(define submod `(submod ,file ,submod-name))
(define to-run (if (module-declared? submod) submod file))
(vprintf "running ~s\n" to-run)
(namespace-require to-run)
(vprintf "finished running ~s" to-run))))
(vprintf "ran ~s\n" paths)
(not tests-failed)))
(define o (current-output-port))
@ -89,9 +104,12 @@
;; clear coverage map
(define (clear-coverage!)
;(dict-clear! coverage)
(set! ns (make-base-namespace))
;(namespace-attach-module (current-namespace) cov ns)
(set! ns (make-empty-namespace))
(namespace-attach-module (current-namespace) ''#%builtin ns)
(namespace-attach-module (current-namespace) ''#%kernel ns)
(namespace-attach-module (current-namespace) 'racket/base ns)
(parameterize ([current-namespace ns])
(namespace-require 'racket/base)
(namespace-require `(file ,(path->string cov)))
(namespace-require `(file ,(path->string strace)))
(namespace-require 'rackunit))

2
info.rkt
View File

@ -17,4 +17,6 @@
("coveralls" cover generate-coveralls-coverage)
("raw" cover generate-raw-coverage)))
(define test-command-line-arguments '(("tests/arg.rkt" ("a"))))
(define version "1.1.0")

5
main.rkt
View File

@ -5,7 +5,10 @@
(contract-out
[coverage/c contract?]
[file-coverage/c contract?]
[test-files! (->* () (#:submod symbol?) #:rest (listof path-string?) any)]
[test-files! (->* () (#:submod symbol?)
#:rest (listof (or/c path-string?
(list/c path-string? (vectorof string?))))
any)]
[clear-coverage! (-> any)]
[get-test-coverage (-> coverage/c)]
[make-covered?

1
private/raw.rkt
View File

@ -3,4 +3,5 @@
(provide generate-raw-coverage)
(define (generate-raw-coverage coverage [dir "coverage"])
(with-output-to-file (build-path dir "coverage.rktl")
#:exists 'replace
(lambda () (pretty-write coverage))))

56
raco.rkt
View File

@ -79,18 +79,27 @@
(define extensions '(#rx"\\.rkt$" #rx"\\.ss$"))
(define (expand-directories files [exts null])
(define comped (map regexp exts))
(flatten
(for/list ([f files])
(if (not (directory-exists? f))
f
(parameterize ([current-directory
(if (absolute-path? f)
f
(build-path (current-directory) f))])
(expand-directory (append extensions comped)))))))
(define paths+vectors
(flatten
(for/list ([f files])
(if (not (directory-exists? f))
f
(parameterize ([current-directory
(if (absolute-path? f)
f
(build-path (current-directory) f))])
(expand-directory (append extensions comped)))))))
(let loop ([paths paths+vectors])
(match paths
[(list) null]
[(list x) (list x)]
[(list* a (? vector? b) r)
(cons (list a b) (loop r))]
[(list* a r)
(cons a (loop r))])))
(module+ test
(define-runtime-path root".")
(define-runtime-path root ".")
(define-runtime-path private "private")
(define-runtime-path main.rkt "main.rkt")
(parameterize ([current-directory root])
@ -107,8 +116,8 @@
"private/shared.rkt"
"private/raw.rkt"))))
;; -> (HorribyNestedListsOf PathString)
(define (expand-directory exts [omit-paths null])
;; -> (HorribyNestedListsOf (or PathString (list path-string vector))
(define (expand-directory exts [omit-paths null] [args null])
(define new-omits (get-info-var (current-directory) 'test-omit-paths))
(define expanded-omits
(case new-omits
@ -116,15 +125,24 @@
[(all) (->absolute (current-directory))]
[else (map ->absolute new-omits)]))
(define full-omits (append expanded-omits omit-paths))
(define new-argv (get-info-var (current-directory) 'test-command-line-arguments))
(define expanded-argv
(if (not new-argv)
null
(map (lambda (x)
(list (->absolute (car x))
(list->vector (cadr x))))
new-argv)))
(define full-argv (append expanded-argv args))
(if (should-omit? (current-directory) full-omits)
null
(for/list ([p (directory-list)])
(cond [(directory-exists? p)
(parameterize ([current-directory (build-path (current-directory) p)])
(expand-directory exts full-omits))]
(expand-directory exts full-omits full-argv))]
[(ormap (lambda (r) (regexp-match r (path->string p))) exts)
(define path (path->string (build-path (current-directory) p)))
(if (should-omit? path full-omits) null path)]
(if (should-omit? path full-omits) null (path-add-argv path full-argv))]
[else null]))))
(module+ test
(define-runtime-path cur ".")
@ -135,15 +153,19 @@
"not-run.rkt")))
(parameterize ([current-directory cur])
(define omit (map ->absolute (get-info-var cur 'test-omit-paths)))
(define dirs (map ->absolute (flatten (expand-directory extensions))))
(define dirs (map ->absolute (filter list? (flatten (expand-directory extensions)))))
(for ([o omit])
(check-false (member o dirs)
(format "~s ~s" o dirs)))))
(define (path-add-argv path argvs)
(define x (assoc path argvs))
(or x path))
;; path symbol -> any
(define (get-info-var path sym)
(define f (get-info/full path))
(and f (f sym)))
(define f (get-info/full/skip path))
(and f (f sym (const #f))))
;; path (listof absolute-paths) -> boolean
(define (should-omit? path omits)

3
tests/arg.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang racket
(require rackunit)
(check-equal? (command-line #:args (a) a) "a")