no longer deleting compiled files
This commit is contained in:
parent
c12f4ae317
commit
d09935ab60
42
cover.rkt
42
cover.rkt
|
@ -10,6 +10,7 @@
|
||||||
racket/runtime-path
|
racket/runtime-path
|
||||||
rackunit
|
rackunit
|
||||||
unstable/error
|
unstable/error
|
||||||
|
racket/list
|
||||||
racket/port
|
racket/port
|
||||||
"private/shared.rkt")
|
"private/shared.rkt")
|
||||||
|
|
||||||
|
@ -22,20 +23,9 @@
|
||||||
;; returns true if all tests passed
|
;; returns true if all tests passed
|
||||||
(define (test-files! #:submod [submod-name 'test] . paths)
|
(define (test-files! #:submod [submod-name 'test] . paths)
|
||||||
(unless ns (unloaded-error))
|
(unless ns (unloaded-error))
|
||||||
(for ([path paths])
|
(define abs (map ->absolute paths))
|
||||||
(define p
|
(parameterize ([current-load/use-compiled (make-cover-load/use-compiled paths)]
|
||||||
(if (absolute-path? path)
|
[use-compiled-file-paths
|
||||||
path
|
|
||||||
(path->string (simplify-path (build-path (current-directory) path)))))
|
|
||||||
(let loop ()
|
|
||||||
(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)])))
|
|
||||||
(parameterize ([use-compiled-file-paths
|
|
||||||
(cons (build-path "compiled" "cover")
|
(cons (build-path "compiled" "cover")
|
||||||
(use-compiled-file-paths))]
|
(use-compiled-file-paths))]
|
||||||
[current-compile (make-cover-compile)]
|
[current-compile (make-cover-compile)]
|
||||||
|
@ -60,6 +50,30 @@
|
||||||
(namespace-require submod)))))
|
(namespace-require submod)))))
|
||||||
(not tests-failed)))
|
(not tests-failed)))
|
||||||
|
|
||||||
|
(define o (current-output-port))
|
||||||
|
(define (make-cover-load/use-compiled paths)
|
||||||
|
(define load/use-compiled (current-load/use-compiled))
|
||||||
|
(define load (current-load))
|
||||||
|
(lambda (path sym)
|
||||||
|
(define abs (->absolute path))
|
||||||
|
(define lst (explode-path abs))
|
||||||
|
(define dir-list (take lst (sub1 (length lst))))
|
||||||
|
(parameterize ([current-load-relative-directory (apply build-path dir-list)])
|
||||||
|
(if (member abs paths)
|
||||||
|
(load path sym)
|
||||||
|
(load/use-compiled path sym)))))
|
||||||
|
|
||||||
|
(define (->absolute path)
|
||||||
|
(if (absolute-path? path)
|
||||||
|
(if (string? path) path (path->string path))
|
||||||
|
(path->string (simplify-path (build-path (current-directory) path)))))
|
||||||
|
(module+ test
|
||||||
|
(parameterize ([current-directory (build-path "/")])
|
||||||
|
(check-equal? (->absolute "a") "/a")
|
||||||
|
(check-equal? (->absolute "/a") "/a")
|
||||||
|
(check-equal? (->absolute (build-path "a")) "/a")
|
||||||
|
(check-equal? (->absolute (build-path "/a")) "/a")))
|
||||||
|
|
||||||
(define (make-cover-compile)
|
(define (make-cover-compile)
|
||||||
(define compile (current-compile))
|
(define compile (current-compile))
|
||||||
(define reg (namespace-module-registry ns))
|
(define reg (namespace-module-registry ns))
|
||||||
|
|
|
@ -1,2 +1,4 @@
|
||||||
#lang racket
|
#lang racket
|
||||||
|
(require rackunit)
|
||||||
|
(check-true #f)
|
||||||
(error "this is supposed to happend")
|
(error "this is supposed to happend")
|
||||||
|
|
Loading…
Reference in New Issue
Block a user