diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 1189b965f9..a721bc93cc 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -416,7 +416,7 @@ The _utils.ss_ module provides utilities helpful in implementing to the submitted definitions and interactions windows. > (make-evaluator language teachpack-paths program-port) - returns a - function of one argument for evaluating expressions in the + function of one required argument for evaluating expressions in the designated language, and loading teachpacks that are specified in `teachpack-paths'. The `program-port' is an input port that produces the content of the definitions window; use @@ -443,9 +443,14 @@ The _utils.ss_ module provides utilities helpful in implementing security guard that reading files only from PLT collections, and no other operations. + Additional arguments to the evaluator function are special messages + that retrieve additional information. Currently, only + 'execute-counts is used (see below). + > (make-evaluator/submission language teachpack-paths bytes) - like `make-evaluator', but the definitions content is supplied as a - submission byte string. + submission byte string. The byte string is opened for reading, with + line-counting enabled. > (call-with-evaluator language teachpack-paths program-port proc) - calls `proc' with an evaluator for the given language, teachpack @@ -456,8 +461,9 @@ The _utils.ss_ module provides utilities helpful in implementing them in a form suitable as a submission error. > (call-with-evaluator/submission language teachpack-paths bytes proc) - - like `call-with-evaluator', but the definitions content is supplied - as a submission string. + like `call-with-evaluator', but the definitions content is supplied + as a submission string. The byte string is opened for reading, + with line-counting enabled. > (evaluate-all source input-port eval) - like `load' on an input @@ -467,6 +473,17 @@ The _utils.ss_ module provides utilities helpful in implementing submission byte string. +> 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. + + > (check-proc eval expect-v compare-proc proc-name arg ...) - calls the function named `proc-name' using the evaluator `eval', giving it the (unquoted) arguments `arg'... Let `result-v' be the result of diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss index 15ddeb8582..73bcd916ac 100644 --- a/collects/handin-server/utils.ss +++ b/collects/handin-server/utils.ss @@ -24,6 +24,8 @@ current-run-status current-value-printer + coverage-enabled + check-proc check-defined look-for-tests @@ -162,8 +164,12 @@ ;; Execution ---------------------------------------- + (define coverage-enabled (make-parameter #f)) + (define (make-evaluator language teachpacks program-port) - (let ([ns (make-namespace-with-mred)] + (let ([coverage-enabled (coverage-enabled)] + [execute-counts #f] + [ns (make-namespace-with-mred)] [orig-ns (current-namespace)] [posn-module ((current-module-name-resolver) '(lib "posn.ss" "lang") #f #f)]) (parameterize ([current-namespace ns] @@ -221,7 +227,16 @@ [else (error 'make-evaluator "Bad language specification: ~e" language)])]) + (when coverage-enabled + (for-each safe-eval + '((require (lib "errortrace.ss" "errortrace")) + (execute-counts-enabled #t)))) (safe-eval body) + (when coverage-enabled + (set! execute-counts + (filter (lambda (x) + (eq? 'program (syntax-source (car x)))) + (safe-eval '(get-execute-counts))))) (when (and (pair? body) (eq? 'module (car body)) (pair? (cdr body)) (symbol? (cadr body))) (let ([mod (cadr body)]) @@ -242,18 +257,28 @@ (let ([r (channel-get result-ch)]) (if (eq? r 'ok) ;; Initial program executed ok, so return an evaluator: - (lambda (expr) - (channel-put ch expr) - (let ([r (channel-get result-ch)]) - (if (eq? (car r) 'exn) - (raise (cdr r)) - (cdr r)))) + (lambda (expr . more) + (if (pair? more) + (case (car more) + [(execute-counts) execute-counts] + [else (error 'make-evaluator + "Bad arguments: ~e" + (cons expr more))]) + (begin (channel-put ch expr) + (let ([r (channel-get result-ch)]) + (if (eq? (car r) 'exn) + (raise (cdr r)) + (cdr r)))))) ;; Program didn't execute: (raise (cdr r))))))))) - + + (define (open-input-text-editor/lines str) + (let ([inp (open-input-text-editor str)]) + (port-count-lines! inp) inp)) + (define (make-evaluator/submission language teachpacks str) (let-values ([(defs interacts) (unpack-submission str)]) - (make-evaluator language teachpacks (open-input-text-editor defs)))) + (make-evaluator language teachpacks (open-input-text-editor/lines defs)))) (define (evaluate-all source port eval) (let loop () @@ -266,7 +291,7 @@ (define (evaluate-submission str eval) (let-values ([(defs interacts) (unpack-submission str)]) - (evaluate-all 'handin (open-input-text-editor defs) eval))) + (evaluate-all 'handin (open-input-text-editor/lines defs) eval))) (define (reraise-exn-as-submission-problem thunk) (with-handlers ([void (lambda (exn) @@ -336,7 +361,7 @@ (apply check-proc e func 'anything eq? args)) (define (look-for-tests t name count) - (let ([p (open-input-text-editor t)]) + (let ([p (open-input-text-editor/lines t)]) (let loop ([found 0]) (let ([e (read p)]) (if (eof-object? e) @@ -385,6 +410,6 @@ (define (call-with-evaluator/submission lang teachpacks str go) (let-values ([(defs interacts) (unpack-submission str)]) - (call-with-evaluator lang teachpacks (open-input-text-editor defs) go))) + (call-with-evaluator lang teachpacks (open-input-text-editor/lines defs) go))) )