From 3824a55ea9553c1694d358137472dbdd6d96e777 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 18 Mar 2007 04:30:45 +0000 Subject: [PATCH] coverage handler svn: r5784 --- collects/handin-server/checker.ss | 349 +++++++++++++++--------------- collects/handin-server/doc.txt | 49 +++-- 2 files changed, 207 insertions(+), 191 deletions(-) diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index 8d1088fac4..6de2b7ac6c 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -14,7 +14,6 @@ (datum->syntax-object (quote-syntax here) (list* (quote-syntax #%plain-module-begin) - (datum->syntax-object stx (quote-syntax (provide checker))) #'(define user-pre #f) #'(define user-post #f) (cdr e)) @@ -396,162 +395,160 @@ (when (car x) (raise-syntax-error #f "unknown keyword" stx (cadr x)))) keyvals) - #'(define checker - (let ([allowed (let ([us users*]) - (if (list? us) - (map (lambda (x) - (if (list? x) - (sort x stringsymbol - (string-downcase - (if multi-file - (format "~a" multi-file) - (and output-file - (regexp-replace - #rx"^.*[.]" output-file "")))))]) - (case sfx - [(java c cc c++) - (unless markup-prefix (set! markup-prefix "//> ")) - (unless prefix-re (set! prefix-re #rx"//>"))] - [else - (unless markup-prefix (set! markup-prefix ";;> ")) - (unless prefix-re (set! prefix-re #rx";>"))]) - sfx)) - ;; ======================================== - ;; verify submitting users - (define (pre users submission) - (set-run-status "checking submission username(s)") - (cond [(list? allowed) - (unless (member users allowed) - (error* - "You are not registered ~a for this submission" - (case (length users) - [(1) "for individual submission"] - [(2) "as a pair"] - [else "as a group"])))] - [(procedure? allowed) (allowed users)] - [(not allowed) ; default is single-user submission - (unless (= 1 (length users)) - (error* - "This homework is for individual submissions"))] - [else (error* "bad user specifications")]) - (when user-pre (user-pre users submission))) - ;; ======================================== - ;; convert to text, evaluate, check - (define (check users submission) - (define text-file (format "grading/text.~a" suffix)) - (define (prefix-line str) - (printf "~a~a\n" markup-prefix str)) - (define generic-substs `(("submission" . ,submission-dir))) - (define (prefix-line/substs str) - (prefix-line (subst str generic-substs))) - (define (write-text) - (set-run-status "creating text file") - (with-output-to-file text-file - (lambda () - (for-each (lambda (user) - (prefix-line - (user-substs user student-line))) - users) - (for-each prefix-line/substs extra-lines) - (for-each prefix-line/substs - (or (thread-cell-ref added-lines) '())) - (display submission-text)) - 'truncate)) - (define submission-text - (and create-text? - (begin (set-run-status "reading submission") - ((if multi-file - (unpack-multifile-submission - names-checker output-file) - submission->bytes) - submission maxwidth textualize? untabify? - markup-prefix prefix-re)))) - (when create-text? (make-directory "grading") (write-text)) - (when value-printer (current-value-printer value-printer)) - (when coverage? (coverage-enabled #t)) - (set-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))]) - (set-run-status "running tests") - (parameterize ([submission-eval (wrap-evaluator 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:') - (define (post users submission) - (when user-post (user-post users submission))) - ;; ======================================== - ;; configuration sanity checks - (let ([bad (cond [(and eval? (not language)) - "`eval?' without `language'"] - [(and (not create-text?) textualize?) - "`textualize?' without `create-text?'"] - [(and maxwidth (not untabify?)) - "`untabify?' without `maxwidth'"] - [(and (not eval?) coverage?) - "`coverage?' without `eval?'"] - ;; [(and textualize? coverage?) - ;; "`textualize?' and `coverage?'"] - [else #f])]) - (when bad - (error* "bad checker specifications: ~a" bad))) - ;; ======================================== - (list pre check post))))]))) + #'(begin + (provide checker) + (define checker + (let ([allowed (let ([us users*]) + (if (list? us) + (map (lambda (x) + (if (list? x) + (sort x stringsymbol + (string-downcase + (if multi-file + (format "~a" multi-file) + (and output-file + (regexp-replace + #rx"^.*[.]" output-file "")))))]) + (case sfx + [(java c cc c++) + (unless markup-prefix (set! markup-prefix "//> ")) + (unless prefix-re (set! prefix-re #rx"//>"))] + [else + (unless markup-prefix (set! markup-prefix ";;> ")) + (unless prefix-re (set! prefix-re #rx";>"))]) + sfx)) + ;; ======================================== + ;; verify submitting users + (define (pre users submission) + (set-run-status "checking submission username(s)") + (cond [(list? allowed) + (unless (member users allowed) + (error* + "You are not registered ~a for this submission" + (case (length users) + [(1) "for individual submission"] + [(2) "as a pair"] + [else "as a group"])))] + [(procedure? allowed) (allowed users)] + [(not allowed) ; default is single-user submission + (unless (= 1 (length users)) + (error* + "This homework is for individual submissions"))] + [else (error* "bad user specifications")]) + (when user-pre (user-pre users submission))) + ;; ======================================== + ;; convert to text, evaluate, check + (define (check users submission) + (define text-file (format "grading/text.~a" suffix)) + (define (prefix-line str) + (printf "~a~a\n" markup-prefix str)) + (define generic-substs `(("submission" . ,submission-dir))) + (define (prefix-line/substs str) + (prefix-line (subst str generic-substs))) + (define (write-text) + (set-run-status "creating text file") + (with-output-to-file text-file + (lambda () + (for-each (lambda (user) + (prefix-line + (user-substs user student-line))) + users) + (for-each prefix-line/substs extra-lines) + (for-each prefix-line/substs + (or (thread-cell-ref added-lines) '())) + (display submission-text)) + 'truncate)) + (define submission-text + (and create-text? + (begin (set-run-status "reading submission") + ((if multi-file + (unpack-multifile-submission + names-checker output-file) + submission->bytes) + submission maxwidth textualize? untabify? + markup-prefix prefix-re)))) + (when create-text? (make-directory "grading") (write-text)) + (when value-printer (current-value-printer value-printer)) + (when coverage? (coverage-enabled #t)) + (set-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? uem) (uem m)] + [(not (string? uem)) + (error* "badly configured ~a" + "user-error-message")] + [(regexp-match? #rx"~[aesvAESV]" uem) + (error* uem m)] + [else (error* "~a" uem)])))]) + (call-with-evaluator/submission + language teachpacks submission values))]) + (set-run-status "running tests") + (parameterize ([submission-eval (wrap-evaluator eval)]) + (let-syntax ([with-submission-bindings + (syntax-rules () + [(_ bindings body*1 body* (... ...)) + (with-bindings eval bindings + body*1 body* (... ...))])]) + (let () body ...)) + ;; will do nothing when called a second time + (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:') + (define (post users submission) + (when user-post (user-post users submission))) + ;; ======================================== + ;; configuration sanity checks + (let ([bad (cond [(and eval? (not language)) + "`eval?' without `language'"] + [(and (not create-text?) textualize?) + "`textualize?' without `create-text?'"] + [(and maxwidth (not untabify?)) + "`untabify?' without `maxwidth'"] + [(and (not eval?) coverage?) + "`coverage?' without `eval?'"] + ;; [(and textualize? coverage?) + ;; "`textualize?' and `coverage?'"] + [else #f])]) + (when bad + (error* "bad checker specifications: ~a" bad))) + ;; ======================================== + (list pre check post)))))]))) (define-syntax (with-bindings stx) (syntax-case stx () @@ -709,22 +706,26 @@ (->disp 'expr) (->disp val) (->disp result))))])) (provide !all-covered) -(define (!all-covered) - (let ([uncovered (get-uncovered-expressions (submission-eval))]) - (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")]))) +(define coverage-checked (make-thread-cell #f)) +(define (!all-covered . proc) + (define uncovered (get-uncovered-expressions (submission-eval))) + (define (handler loc) + (error* "your code is not completely covered by tests: ~a ~a ~s" + "uncovered expression at" loc proc)) + (cond + [(thread-cell-ref coverage-checked) #f] + [(pair? uncovered) + (let* ([stx (car uncovered)] + [loc + (cond [(not stx) #f] + [(and (syntax-line stx) (syntax-column stx)) + (format "~a:~a" (syntax-line stx) (syntax-column stx))] + [(syntax-position stx) => (lambda (p) (format "#~a" p))] + [else "(unknown location)"])]) + (when loc + (thread-cell-set! coverage-checked #t) + ((if (pair? proc) (car proc) handler) loc)))] + [(null? uncovered) #f] + [else (error* "bad checker: no coverage information for !all-covered")])) ) diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 641f9a5623..8ca9fbaed4 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -863,8 +863,8 @@ _utils.ss_ submissions that were saved, but had problems); finally, `styles' can be used as a list of styles for a `message-box' dialog on the client side, and the resulting value is returned as the result of - `message'. You can use that to send warnings to the student and - wait for confirmation. + `message'. You can use that to send warnings to the student or ask + confirmation. > (set-run-status string-or-#f) Registers information about the current actions of the checker, in @@ -925,10 +925,10 @@ checker that uses it looks like this: > (check: :key val ... body ...) Construct a checker procedure. -The `check:' macro will construct an appropriate checker function, -using keywords for features that you want, the body of the checker can -contain arbitrary code, using all utilities from "utils.ss" (see -above), as well as additional ones (see below). +The `check:' macro will construct (and provide) an appropriate checker +function, using keywords for features that you want, the body of the +checker can contain arbitrary code, using all utilities from +"utils.ss" (see above), as well as additional ones (see below). Keywords for configuring `check:': @@ -1011,7 +1011,8 @@ Keywords for configuring `check:': * :extra-lines -- a list of lines to add after the student lines, all with a ";;> " or :markup-prefix too. Defaults to a single line: "Maximum points for this assignment: <+100>". (Can use - "{submission}" for the submission directory.) + "{submission}" for the submission directory.) See also + `add-header-line!' below. * :user-error-message -- a string that is used to report an error that occurred during evaluation of the submitted code (not during @@ -1145,8 +1146,9 @@ value from the submission code. > (add-header-line! line) During the checker operation, this procedure can be used to add - header lines to the text version of the submitted file. It will not - have an effect if `:create-text?' is false. + header lines to the text version of the submitted file (in addition + to the `:extra-lines' setting). It will not have an effect if + `:create-text?' is false. > (procedure/arity? proc arity) Returns `#t' if `proc' is a procedure that accepts `arity' @@ -1176,16 +1178,29 @@ value from the submission code. equality procedure). Note that the `result' and `equal?' forms are *not* evaluated in the submission context. -> (!all-covered) +> (!all-covered [proc]) When coverage information is enabled (see `:coverage?' above), this 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. 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. + error with source information if some code is left uncovered. If + the optional procedure argument is provided, it is applied on a + string argument that describes the location of the uncovered + expression (":", "#", or "(unknown position)") + instead of throwing an error. The collected information includes + only execution coverage by submission 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, or if you + want to avoid an error. For example, you can do this: + + (!all-covered + (lambda (where) + (case (message (string-append + "Incomplete coverage at "where", do you want" + " to save this submission with 10% penalty?")) + [(yes) (add-header-line! "No full coverage <*90%>") + (message "Handin saved with penalty.")] + [else (error "aborting submission")]))) Multiple-File Submissions: