diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 20105abbfd..ca07d44a34 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -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 diff --git a/collects/handin-server/extra-utils.ss b/collects/handin-server/extra-utils.ss index 0a3edfab9f..dd75af629b 100644 --- a/collects/handin-server/extra-utils.ss +++ b/collects/handin-server/extra-utils.ss @@ -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 @@ -522,40 +518,41 @@ (when coverage? (coverage-enabled #t)) (current-run-status "checking submission") (cond - [(not eval?) (let () body ...)] - [language - (let ([eval - (with-handlers - ([void - (lambda (e) - (let ([m (if (exn? e) - (exn-message e) - (format "~a" e))]) - (cond - [(procedure? user-error-message) - (user-error-message m)] - [(not (string? user-error-message)) - (error* - "badly configured user-error-message")] - [(regexp-match #rx"~[aesvAESV]" - user-error-message) - (error* user-error-message m)] - [else - (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 - (syntax-rules () - [(_ bindings body*1 body* (... ...)) - (with-bindings eval bindings - body*1 body* (... ...))])]) - (let () body ...)) - (when (thread-cell-ref added-lines) (write-text))))] - [else (error* "no language configured for submissions")]) + [(not eval?) (let () body ...)] + [language + (let ([eval + (with-handlers + ([void + (lambda (e) + (let ([m (if (exn? e) + (exn-message e) + (format "~a" e))]) + (cond + [(procedure? user-error-message) + (user-error-message m)] + [(not (string? user-error-message)) + (error* + "badly configured user-error-message")] + [(regexp-match #rx"~[aesvAESV]" + user-error-message) + (error* user-error-message m)] + [else + (error* "~a" user-error-message)])))]) + (call-with-evaluator/submission + language teachpacks submission values))]) + (current-run-status "running tests") + (parameterize ([submission-eval eval]) + (let-syntax ([with-submission-bindings + (syntax-rules () + [(_ bindings body*1 body* (... ...)) + (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) ;; ======================================== ;; indirection for user-post (may be set after `check:') @@ -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" - (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!"))) + (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 ""]))))] + [(null? uncovered) #f] + [else (error* + "bad checker: no coverage information for !all-covered")]))) ) diff --git a/collects/handin-server/private/coverage.ss b/collects/handin-server/private/coverage.ss new file mode 100644 index 0000000000..32792bf0ef --- /dev/null +++ b/collects/handin-server/private/coverage.ss @@ -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)) diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss index d16fc7aa24..15c633491b 100644 --- a/collects/handin-server/utils.ss +++ b/collects/handin-server/utils.ss @@ -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))])