* Added functionality for checking coverage information

* Submissions are opened with line counting

svn: r853

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
+  like `call-with-evaluator', but the definitions content is supplied
-   as a submission string.
+  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

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)
+		  (lambda (expr . more)
-		    (channel-put ch expr)
+                    (if (pair? more)
-		    (let ([r (channel-get result-ch)])
+                      (case (car more)
-		      (if (eq? (car r) 'exn)
+                        [(execute-counts) execute-counts]
-			  (raise (cdr r))
+                        [else (error 'make-evaluator
-			  (cdr r))))
+                                     "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)))
 
   )