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

improved coverage information facility

Browse Source 
svn: r4886
This commit is contained in:
Eli Barzilay 2006-11-19 10:31:06 +00:00
parent a0437ed206
commit 42327b10e6
4 changed files with 158 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/handin-server/doc.txt
View File

@ -559,7 +559,7 @@ The _utils.ss_ module provides utilities helpful in implementing
Additional arguments to the evaluator function are special messages Additional arguments to the evaluator function are special messages
that retrieve additional information. Currently, only 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) > (make-evaluator/submission language teachpack-paths bytes)
Like `make-evaluator', but the definitions content is supplied as a 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 > coverage-enabled
Parameter that controls whether coverage testing is enabled. If it Parameter that controls whether coverage testing is enabled. If it
set to true, the errortrace collection will be used to collect set to true, the handin-server/private/coverage collection will be
coverage information during evaluation of the submission, this used to detect uncovered expressions. This information is collected
information is collected before additional checker-evaluations. To before additional checker-evaluations. To retrieve the collected
retrieve the collected information, apply the evaluation function information, apply the evaluation function with a second argument of
with a second argument of 'execute-counts (the first argument will 'uncovered-expressions (the first argument will be ignored). The
be ignored). The resulting value is the same as the result of resulting value is a list of uncovered expressions, with at most one
errortrace's `get-execute-counts', with all non-submission entries per position+span (so the contents is unreliable, but the position
filtered out. is).
> (check-proc eval expect-v compare-proc proc-name arg ...) > (check-proc eval expect-v compare-proc proc-name arg ...)
Calls the function named `proc-name' using the evaluator `eval', 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 32) 0)
(!test (Fahrenheit->Celsius 212) 100) (!test (Fahrenheit->Celsius 212) 100)
(!test (Fahrenheit->Celsius -4) -20) (!test (Fahrenheit->Celsius -4) -20)
... ...))
(!all-covered)))
> (check: :key val ... body ...) > (check: :key val ... body ...)
Construct a checker procedure. Construct a checker procedure.
@ -820,9 +819,13 @@ Keywords for configuring `check:':
`current-value-printer' (see above). `current-value-printer' (see above).
* :coverage? -- collect coverage information when evaluating the * :coverage? -- collect coverage information when evaluating the
submission (not including additional checker tests). This is needed submission. This will
for the `!all-covered' procedure below. Does not work with cause an error if some input is not covered. This check happens
non-textual submissions. 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 Within the body of `check:', `users' and `submission' will be bound to
the checker arguments -- a (sorted) list of usernames and the 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 procedure checks the collected coverage information and throws an
error with source information if some code is left uncovered. The error with source information if some code is left uncovered. The
collected information includes only execution coverage by submission 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 *** Multiple-file submissions

145
collects/handin-server/extra-utils.ss
View File

@ -1,11 +1,9 @@
(module extra-utils mzscheme (module extra-utils mzscheme
(require (lib "utils.ss" "handin-server") (require "utils.ss" (lib "file.ss") (lib "list.ss") (lib "class.ss")
(lib "file.ss") (lib "list.ss") (lib "class.ss")
(lib "mred.ss" "mred")) (lib "mred.ss" "mred"))
(provide (all-from-except mzscheme #%module-begin) (provide (all-from-except mzscheme #%module-begin) (all-from "utils.ss"))
(all-from (lib "utils.ss" "handin-server")))
(provide (rename module-begin~ #%module-begin)) (provide (rename module-begin~ #%module-begin))
(define-syntax (module-begin~ stx) (define-syntax (module-begin~ stx)
@ -412,7 +410,6 @@
[users (id 'users)] [users (id 'users)]
[submission (id 'submission)] [submission (id 'submission)]
[eval (id 'eval)] [eval (id 'eval)]
[execute-counts (id 'execute-counts)]
[with-submission-bindings (id 'with-submission-bindings)] [with-submission-bindings (id 'with-submission-bindings)]
[user-pre (id 'user-pre)] [user-pre (id 'user-pre)]
[user-post (id 'user-post)] [user-post (id 'user-post)]
@ -447,8 +444,7 @@
[output-file output*] [output-file output*]
[multi-file multi-file*] [multi-file multi-file*]
[names-checker names-checker*] [names-checker names-checker*]
[user-error-message user-error-message*] [user-error-message user-error-message*])
[execute-counts #f])
;; ======================================== ;; ========================================
;; set defaults that depend on file name ;; set defaults that depend on file name
(define suffix (define suffix
@ -522,40 +518,41 @@
(when coverage? (coverage-enabled #t)) (when coverage? (coverage-enabled #t))
(current-run-status "checking submission") (current-run-status "checking submission")
(cond (cond
[(not eval?) (let () body ...)] [(not eval?) (let () body ...)]
[language [language
(let ([eval (let ([eval
(with-handlers (with-handlers
([void ([void
(lambda (e) (lambda (e)
(let ([m (if (exn? e) (let ([m (if (exn? e)
(exn-message e) (exn-message e)
(format "~a" e))]) (format "~a" e))])
(cond (cond
[(procedure? user-error-message) [(procedure? user-error-message)
(user-error-message m)] (user-error-message m)]
[(not (string? user-error-message)) [(not (string? user-error-message))
(error* (error*
"badly configured user-error-message")] "badly configured user-error-message")]
[(regexp-match #rx"~[aesvAESV]" [(regexp-match #rx"~[aesvAESV]"
user-error-message) user-error-message)
(error* user-error-message m)] (error* user-error-message m)]
[else [else
(error* "~a" user-error-message)])))]) (error* "~a" user-error-message)])))])
(call-with-evaluator/submission (call-with-evaluator/submission
language teachpacks submission values))]) language teachpacks submission values))])
(when coverage? (current-run-status "running tests")
(set! execute-counts (eval #f 'execute-counts))) (parameterize ([submission-eval eval])
(current-run-status "running tests") (let-syntax ([with-submission-bindings
(parameterize ([submission-eval eval]) (syntax-rules ()
(let-syntax ([with-submission-bindings [(_ bindings body*1 body* (... ...))
(syntax-rules () (with-bindings eval bindings
[(_ bindings body*1 body* (... ...)) body*1 body* (... ...))])])
(with-bindings eval bindings (let () body ...))
body*1 body* (... ...))])]) ;; test coverage at the end (no harm if already done in
(let () body ...)) ;; the checker since it's cheap)
(when (thread-cell-ref added-lines) (write-text))))] (when coverage? (!all-covered))
[else (error* "no language configured for submissions")]) (when (thread-cell-ref added-lines) (write-text))))]
[else (error* "no language configured for submissions")])
output-file) output-file)
;; ======================================== ;; ========================================
;; indirection for user-post (may be set after `check:') ;; indirection for user-post (may be set after `check:')
@ -571,8 +568,8 @@
"`untabify?' without `maxwidth'"] "`untabify?' without `maxwidth'"]
[(and (not eval?) coverage?) [(and (not eval?) coverage?)
"`coverage?' without `eval?'"] "`coverage?' without `eval?'"]
[(and textualize? coverage?) ;; [(and textualize? coverage?)
"`textualize?' and `coverage?'"] ;; "`textualize?' and `coverage?'"]
[else #f])]) [else #f])])
(when bad (when bad
(error* "bad checker specifications: ~a" bad))) (error* "bad checker specifications: ~a" bad)))
@ -737,51 +734,21 @@
(provide !all-covered) (provide !all-covered)
(define (!all-covered) (define (!all-covered)
(define execute-counts ((submission-eval) #f 'execute-counts)) (let ([uncovered ((submission-eval) #f 'uncovered-expressions)])
(define (coverage-error stx) (cond [(pair? uncovered)
(error* "your code is not completely covered by test cases~a" (let ([stx (car uncovered)])
(cond [(and (syntax-line stx) (syntax-column stx)) (when stx
(format ": uncovered expression at ~a:~a" (error*
(syntax-line stx) (syntax-column stx))] "your code is not completely covered by tests~a"
[(syntax-position stx) (cond [(and (syntax-line stx) (syntax-column stx))
(format ": uncovered expression at position ~a" (format ": uncovered expression at ~a:~a"
(syntax-position stx))] (syntax-line stx) (syntax-column stx))]
[else ""]))) [(syntax-position stx)
(if execute-counts (format ": uncovered expression at position ~a"
#| (syntax-position stx))]
;; Go over all counts that are syntax-original, avoiding code that macros [else ""]))))]
;; insert [(null? uncovered) #f]
(for-each (lambda (x) [else (error*
(when (and (zero? (cdr x)) (syntax-original? (car x))) "bad checker: no coverage information for !all-covered")])))
(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!")))
) )

70
collects/handin-server/private/coverage.ss Normal file
View 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))

21
collects/handin-server/utils.ss
View File

@ -193,7 +193,7 @@
(define (make-evaluator language teachpacks program-port) (define (make-evaluator language teachpacks program-port)
(let ([coverage-enabled (coverage-enabled)] (let ([coverage-enabled (coverage-enabled)]
[execute-counts #f] [uncovered-expressions #f]
[ns (make-evaluation-namespace)] [ns (make-evaluation-namespace)]
[orig-ns (current-namespace)]) [orig-ns (current-namespace)])
(parameterize ([current-namespace ns] (parameterize ([current-namespace ns]
@ -251,9 +251,8 @@
"Bad language specification: ~e" "Bad language specification: ~e"
language)])]) language)])])
(when coverage-enabled (when coverage-enabled
(for-each safe-eval (safe-eval '(require (lib "coverage.ss"
'((require (lib "errortrace.ss" "errortrace")) "handin-server" "private"))))
(execute-counts-enabled #t))))
(safe-eval body) (safe-eval body)
(when (and (pair? body) (eq? 'module (car body)) (when (and (pair? body) (eq? 'module (car body))
(pair? (cdr body)) (symbol? (cadr body))) (pair? (cdr body)) (symbol? (cadr body)))
@ -261,18 +260,18 @@
(safe-eval `(require ,mod)) (safe-eval `(require ,mod))
(current-namespace (module->namespace mod)))) (current-namespace (module->namespace mod))))
(when coverage-enabled (when coverage-enabled
(set! execute-counts (set! uncovered-expressions
(map (lambda (x) (cons (car x) (cdr x))) (filter (lambda (x) (eq? 'program (syntax-source x)))
(filter (lambda (x) (safe-eval '(get-uncovered-expressions)
(eq? 'program (syntax-source (car x)))) ns)))))
(safe-eval '(get-execute-counts) ns))))))
(channel-put result-ch 'ok)) (channel-put result-ch 'ok))
;; Now wait for interaction expressions: ;; Now wait for interaction expressions:
(let loop () (let loop ()
(let ([expr (channel-get ch)]) (let ([expr (channel-get ch)])
(unless (eof-object? expr) (unless (eof-object? expr)
(with-handlers ([void (lambda (exn) (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)))) (channel-put result-ch (cons 'val (safe-eval expr))))
(loop)))) (loop))))
(let loop () (let loop ()
@ -284,7 +283,7 @@
(lambda (expr . more) (lambda (expr . more)
(if (pair? more) (if (pair? more)
(case (car more) (case (car more)
[(execute-counts) execute-counts] [(uncovered-expressions) uncovered-expressions]
[else (error 'make-evaluator [else (error 'make-evaluator
"Bad arguments: ~e" "Bad arguments: ~e"
(cons expr more))]) (cons expr more))])