improved coverage information facility
svn: r4886
This commit is contained in:
Eli Barzilay
parent
a0437ed206
commit
42327b10e6
|
|
@ -559,7 +559,7 @@ The _utils.ss_ module provides utilities helpful in implementing
|
|||
|
||||
Additional arguments to the evaluator function are special messages
|
||||
that retrieve additional information. Currently, only
|
||||
'execute-counts is used (see below).
|
||||
'uncovered-expressions is used (see below).
|
||||
|
||||
> (make-evaluator/submission language teachpack-paths bytes)
|
||||
Like `make-evaluator', but the definitions content is supplied as a
|
||||
|
|
@ -587,14 +587,14 @@ The _utils.ss_ module provides utilities helpful in implementing
|
|||
|
||||
> coverage-enabled
|
||||
Parameter that controls whether coverage testing is enabled. If it
|
||||
set to true, the errortrace collection will be used to collect
|
||||
coverage information during evaluation of the submission, this
|
||||
information is collected before additional checker-evaluations. To
|
||||
retrieve the collected information, apply the evaluation function
|
||||
with a second argument of 'execute-counts (the first argument will
|
||||
be ignored). The resulting value is the same as the result of
|
||||
errortrace's `get-execute-counts', with all non-submission entries
|
||||
filtered out.
|
||||
set to true, the handin-server/private/coverage collection will be
|
||||
used to detect uncovered expressions. This information is collected
|
||||
before additional checker-evaluations. To retrieve the collected
|
||||
information, apply the evaluation function with a second argument of
|
||||
'uncovered-expressions (the first argument will be ignored). The
|
||||
resulting value is a list of uncovered expressions, with at most one
|
||||
per position+span (so the contents is unreliable, but the position
|
||||
is).
|
||||
|
||||
> (check-proc eval expect-v compare-proc proc-name arg ...)
|
||||
Calls the function named `proc-name' using the evaluator `eval',
|
||||
|
|
@ -691,8 +691,7 @@ checker that uses it looks like this:
|
|||
(!test (Fahrenheit->Celsius 32) 0)
|
||||
(!test (Fahrenheit->Celsius 212) 100)
|
||||
(!test (Fahrenheit->Celsius -4) -20)
|
||||
...
|
||||
(!all-covered)))
|
||||
...))
|
||||
|
||||
> (check: :key val ... body ...)
|
||||
Construct a checker procedure.
|
||||
|
|
@ -820,9 +819,13 @@ Keywords for configuring `check:':
|
|||
`current-value-printer' (see above).
|
||||
|
||||
* :coverage? -- collect coverage information when evaluating the
|
||||
submission (not including additional checker tests). This is needed
|
||||
for the `!all-covered' procedure below. Does not work with
|
||||
non-textual submissions.
|
||||
submission. This will
|
||||
cause an error if some input is not covered. This check happens
|
||||
after checker tests are run, but the information is collected and
|
||||
stored before, so checker tests do not change the result. Also, you
|
||||
can use the `!all-covered' procedure in the checker before other
|
||||
tests, if you want that feedback earlier.
|
||||
Does not work with non-textual submissions.
|
||||
|
||||
Within the body of `check:', `users' and `submission' will be bound to
|
||||
the checker arguments -- a (sorted) list of usernames and the
|
||||
|
|
@ -948,7 +951,11 @@ value from the submission code.
|
|||
procedure checks the collected coverage information and throws an
|
||||
error with source information if some code is left uncovered. The
|
||||
collected information includes only execution coverage by submission
|
||||
code, excluding additional checker tests.
|
||||
code, excluding additional checker tests. You do not have to call
|
||||
this explicitly -- it is called at the end of the process
|
||||
automatically when `:coverage?' is enabled. It is made available so
|
||||
you can call it earlier (eg, before testing) to show clients a
|
||||
coverage error first.
|
||||
|
||||
*** Multiple-file submissions
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,9 @@
|
|||
(module extra-utils mzscheme
|
||||
|
||||
(require (lib "utils.ss" "handin-server")
|
||||
(lib "file.ss") (lib "list.ss") (lib "class.ss")
|
||||
(require "utils.ss" (lib "file.ss") (lib "list.ss") (lib "class.ss")
|
||||
(lib "mred.ss" "mred"))
|
||||
|
||||
(provide (all-from-except mzscheme #%module-begin)
|
||||
(all-from (lib "utils.ss" "handin-server")))
|
||||
(provide (all-from-except mzscheme #%module-begin) (all-from "utils.ss"))
|
||||
|
||||
(provide (rename module-begin~ #%module-begin))
|
||||
(define-syntax (module-begin~ stx)
|
||||
|
|
@ -412,7 +410,6 @@
|
|||
[users (id 'users)]
|
||||
[submission (id 'submission)]
|
||||
[eval (id 'eval)]
|
||||
[execute-counts (id 'execute-counts)]
|
||||
[with-submission-bindings (id 'with-submission-bindings)]
|
||||
[user-pre (id 'user-pre)]
|
||||
[user-post (id 'user-post)]
|
||||
|
|
@ -447,8 +444,7 @@
|
|||
[output-file output*]
|
||||
[multi-file multi-file*]
|
||||
[names-checker names-checker*]
|
||||
[user-error-message user-error-message*]
|
||||
[execute-counts #f])
|
||||
[user-error-message user-error-message*])
|
||||
;; ========================================
|
||||
;; set defaults that depend on file name
|
||||
(define suffix
|
||||
|
|
@ -544,8 +540,6 @@
|
|||
(error* "~a" user-error-message)])))])
|
||||
(call-with-evaluator/submission
|
||||
language teachpacks submission values))])
|
||||
(when coverage?
|
||||
(set! execute-counts (eval #f 'execute-counts)))
|
||||
(current-run-status "running tests")
|
||||
(parameterize ([submission-eval eval])
|
||||
(let-syntax ([with-submission-bindings
|
||||
|
|
@ -554,6 +548,9 @@
|
|||
(with-bindings eval bindings
|
||||
body*1 body* (... ...))])])
|
||||
(let () body ...))
|
||||
;; test coverage at the end (no harm if already done in
|
||||
;; the checker since it's cheap)
|
||||
(when coverage? (!all-covered))
|
||||
(when (thread-cell-ref added-lines) (write-text))))]
|
||||
[else (error* "no language configured for submissions")])
|
||||
output-file)
|
||||
|
|
@ -571,8 +568,8 @@
|
|||
"`untabify?' without `maxwidth'"]
|
||||
[(and (not eval?) coverage?)
|
||||
"`coverage?' without `eval?'"]
|
||||
[(and textualize? coverage?)
|
||||
"`textualize?' and `coverage?'"]
|
||||
;; [(and textualize? coverage?)
|
||||
;; "`textualize?' and `coverage?'"]
|
||||
[else #f])])
|
||||
(when bad
|
||||
(error* "bad checker specifications: ~a" bad)))
|
||||
|
|
@ -737,51 +734,21 @@
|
|||
|
||||
(provide !all-covered)
|
||||
(define (!all-covered)
|
||||
(define execute-counts ((submission-eval) #f 'execute-counts))
|
||||
(define (coverage-error stx)
|
||||
(error* "your code is not completely covered by test cases~a"
|
||||
(let ([uncovered ((submission-eval) #f 'uncovered-expressions)])
|
||||
(cond [(pair? uncovered)
|
||||
(let ([stx (car uncovered)])
|
||||
(when stx
|
||||
(error*
|
||||
"your code is not completely covered by tests~a"
|
||||
(cond [(and (syntax-line stx) (syntax-column stx))
|
||||
(format ": uncovered expression at ~a:~a"
|
||||
(syntax-line stx) (syntax-column stx))]
|
||||
[(syntax-position stx)
|
||||
(format ": uncovered expression at position ~a"
|
||||
(syntax-position stx))]
|
||||
[else ""])))
|
||||
(if execute-counts
|
||||
#|
|
||||
;; Go over all counts that are syntax-original, avoiding code that macros
|
||||
;; insert
|
||||
(for-each (lambda (x)
|
||||
(when (and (zero? (cdr x)) (syntax-original? (car x)))
|
||||
(coverage-error (car x))))
|
||||
execute-counts)
|
||||
|#
|
||||
;; Better: try to find if there is some source position that is not
|
||||
;; covered, if so, it means that there is some macro that originates in
|
||||
;; some real source position that is not covered. Also, return the first
|
||||
;; one found of the biggest span (so an error will point at `(+ 1 2)', not
|
||||
;; on the `+').
|
||||
(let ([table (make-hash-table)])
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(let* ([loc (syntax-position (car x))]
|
||||
[h (hash-table-get table loc (lambda () #f))])
|
||||
(when (or (not h) (< (cdr h) (cdr x)))
|
||||
(hash-table-put! table loc x))))
|
||||
execute-counts)
|
||||
(let ([1st #f])
|
||||
(hash-table-for-each table
|
||||
(lambda (key val)
|
||||
(when (and (zero? (cdr val))
|
||||
(or (not 1st)
|
||||
(let ([car-pos (syntax-position (car val))]
|
||||
[1st-pos (syntax-position 1st)])
|
||||
(or (< car-pos 1st-pos)
|
||||
(and (= car-pos 1st-pos)
|
||||
(> (syntax-span (car val))
|
||||
(syntax-span 1st)))))))
|
||||
(set! 1st (car val)))))
|
||||
(when 1st (coverage-error 1st))))
|
||||
(error* "mis-configuration: requires coverage, but no coverage info!")))
|
||||
[else ""]))))]
|
||||
[(null? uncovered) #f]
|
||||
[else (error*
|
||||
"bad checker: no coverage information for !all-covered")])))
|
||||
|
||||
)
|
||||
|
|
|
|||
70
collects/handin-server/private/coverage.ss
Normal file
70
collects/handin-server/private/coverage.ss
Normal file
|
|
@ -0,0 +1,70 @@
|
|||
;; Use the stacktrace interface from errortrace to find uncovered expressions.
|
||||
(module coverage mzscheme
|
||||
(require (lib "stacktrace.ss" "errortrace")
|
||||
(lib "unitsig.ss")
|
||||
(lib "list.ss"))
|
||||
|
||||
;; Test coverage run-time support
|
||||
(define test-coverage-enabled (make-parameter #t))
|
||||
(define test-coverage-info (make-hash-table))
|
||||
(define (initialize-test-coverage-point key expr)
|
||||
(hash-table-put! test-coverage-info key (cons expr #f)))
|
||||
(define (test-covered key)
|
||||
(set-cdr! (hash-table-get test-coverage-info key) #t))
|
||||
|
||||
(define (get-uncovered-expressions)
|
||||
(let* ([xs (hash-table-map test-coverage-info (lambda (k v) v))]
|
||||
[xs (filter (lambda (x) (syntax-position (car x))) xs)]
|
||||
[xs (sort xs (lambda (x1 x2)
|
||||
(let ([p1 (syntax-position (car x1))]
|
||||
[p2 (syntax-position (car x2))])
|
||||
(or (< p1 p2) ; earlier first
|
||||
(and (= p1 p2)
|
||||
(> (syntax-span (car x1)) ; wider first
|
||||
(syntax-span (car x2))))))))]
|
||||
[xs (reverse! xs)])
|
||||
(if (null? xs)
|
||||
xs
|
||||
(let loop ([xs (cdr xs)] [r (list (car xs))])
|
||||
(if (null? xs)
|
||||
(map car (filter (lambda (x) (not (cdr x))) r))
|
||||
(loop (cdr xs)
|
||||
(cond [(not (and (= (syntax-position (caar xs))
|
||||
(syntax-position (caar r)))
|
||||
(= (syntax-span (caar xs))
|
||||
(syntax-span (caar r)))))
|
||||
(cons (car xs) r)]
|
||||
[(cdar r) r]
|
||||
[else (cons (car xs) (cdr r))])))))))
|
||||
|
||||
(provide get-uncovered-expressions)
|
||||
|
||||
;; no profiling
|
||||
(define profile-key #f)
|
||||
(define profiling-enabled (lambda () #f))
|
||||
(define initialize-profile-point void)
|
||||
(define register-profile-start void)
|
||||
(define register-profile-done void)
|
||||
;; no marks
|
||||
(define (with-mark mark expr) expr)
|
||||
|
||||
(define-values/invoke-unit/sig
|
||||
stacktrace^ stacktrace@ #f stacktrace-imports^)
|
||||
|
||||
(define errortrace-compile-handler
|
||||
(let ([orig (current-compile)]
|
||||
[ns (current-namespace)])
|
||||
(lambda (e immediate-eval?)
|
||||
(orig (if (and (eq? ns (current-namespace))
|
||||
(not (compiled-expression?
|
||||
(if (syntax? e) (syntax-e e) e))))
|
||||
(annotate-top
|
||||
(expand-syntax (if (syntax? e)
|
||||
e
|
||||
(namespace-syntax-introduce
|
||||
(datum->syntax-object #f e))))
|
||||
#f)
|
||||
e)
|
||||
immediate-eval?))))
|
||||
|
||||
(current-compile errortrace-compile-handler))
|
||||
|
|
@ -193,7 +193,7 @@
|
|||
|
||||
(define (make-evaluator language teachpacks program-port)
|
||||
(let ([coverage-enabled (coverage-enabled)]
|
||||
[execute-counts #f]
|
||||
[uncovered-expressions #f]
|
||||
[ns (make-evaluation-namespace)]
|
||||
[orig-ns (current-namespace)])
|
||||
(parameterize ([current-namespace ns]
|
||||
|
|
@ -251,9 +251,8 @@
|
|||
"Bad language specification: ~e"
|
||||
language)])])
|
||||
(when coverage-enabled
|
||||
(for-each safe-eval
|
||||
'((require (lib "errortrace.ss" "errortrace"))
|
||||
(execute-counts-enabled #t))))
|
||||
(safe-eval '(require (lib "coverage.ss"
|
||||
"handin-server" "private"))))
|
||||
(safe-eval body)
|
||||
(when (and (pair? body) (eq? 'module (car body))
|
||||
(pair? (cdr body)) (symbol? (cadr body)))
|
||||
|
|
@ -261,18 +260,18 @@
|
|||
(safe-eval `(require ,mod))
|
||||
(current-namespace (module->namespace mod))))
|
||||
(when coverage-enabled
|
||||
(set! execute-counts
|
||||
(map (lambda (x) (cons (car x) (cdr x)))
|
||||
(filter (lambda (x)
|
||||
(eq? 'program (syntax-source (car x))))
|
||||
(safe-eval '(get-execute-counts) ns))))))
|
||||
(set! uncovered-expressions
|
||||
(filter (lambda (x) (eq? 'program (syntax-source x)))
|
||||
(safe-eval '(get-uncovered-expressions)
|
||||
ns)))))
|
||||
(channel-put result-ch 'ok))
|
||||
;; Now wait for interaction expressions:
|
||||
(let loop ()
|
||||
(let ([expr (channel-get ch)])
|
||||
(unless (eof-object? expr)
|
||||
(with-handlers ([void (lambda (exn)
|
||||
(channel-put result-ch (cons 'exn exn)))])
|
||||
(channel-put result-ch
|
||||
(cons 'exn exn)))])
|
||||
(channel-put result-ch (cons 'val (safe-eval expr))))
|
||||
(loop))))
|
||||
(let loop ()
|
||||
|
|
@ -284,7 +283,7 @@
|
|||
(lambda (expr . more)
|
||||
(if (pair? more)
|
||||
(case (car more)
|
||||
[(execute-counts) execute-counts]
|
||||
[(uncovered-expressions) uncovered-expressions]
|
||||
[else (error 'make-evaluator
|
||||
"Bad arguments: ~e"
|
||||
(cons expr more))])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user