Converting utils.ss and checker.ss to scheme/base.
svn: r11633
This commit is contained in:
Stevie Strickland
parent
a115dc3d8b
commit
12bcac14d3
|
|
@ -1,16 +1,17 @@
|
|||
#lang mzscheme
|
||||
#lang scheme/base
|
||||
|
||||
(require "utils.ss" mzlib/file mzlib/list mzlib/class mred)
|
||||
(require (for-syntax scheme/base) "utils.ss" scheme/file scheme/list scheme/class mred)
|
||||
|
||||
(provide (all-from-except mzscheme #%module-begin) (all-from "utils.ss"))
|
||||
(provide (except-out (all-from-out scheme/base) #%module-begin)
|
||||
(all-from-out "utils.ss"))
|
||||
|
||||
(provide (rename module-begin~ #%module-begin))
|
||||
(provide (rename-out [module-begin~ #%module-begin]))
|
||||
(define-syntax (module-begin~ stx)
|
||||
(let ([e (if (syntax? stx) (syntax-e stx) stx)])
|
||||
(if (pair? e)
|
||||
(with-syntax ([user-pre (datum->syntax-object stx 'user-pre stx)]
|
||||
[user-post (datum->syntax-object stx 'user-post stx)])
|
||||
(datum->syntax-object
|
||||
(with-syntax ([user-pre (datum->syntax stx 'user-pre stx)]
|
||||
[user-post (datum->syntax stx 'user-post stx)])
|
||||
(datum->syntax
|
||||
(quote-syntax here)
|
||||
(list* (quote-syntax #%plain-module-begin)
|
||||
#'(define user-pre #f)
|
||||
|
|
@ -104,7 +105,7 @@
|
|||
(format "~a" (or (send x get-text 0 (send x get-count) #t) x))]
|
||||
[(special-comment? x)
|
||||
(format "#| ~a |#" (special-comment-value x))]
|
||||
[(syntax? x) (syntax-object->datum x)]
|
||||
[(syntax? x) (syntax->datum x)]
|
||||
[else x]))
|
||||
(let-values ([(filter) (if (pair? filter) (car filter) item->text)]
|
||||
[(in out) (make-pipe 4096)])
|
||||
|
|
@ -317,7 +318,7 @@
|
|||
(define submission-eval (make-parameter #f))
|
||||
|
||||
;; without this the primitive eval is not available
|
||||
(provide (rename eval prim-eval))
|
||||
(provide (rename-out [eval prim-eval]))
|
||||
|
||||
;; for adding lines in the checker
|
||||
(define added-lines (make-thread-cell #f))
|
||||
|
|
@ -344,7 +345,7 @@
|
|||
|
||||
(provide check:)
|
||||
(define-syntax (check: stx)
|
||||
(define (id s) (datum->syntax-object stx s stx))
|
||||
(define (id s) (datum->syntax stx s stx))
|
||||
(let loop ([stx (syntax-case stx () [(_ x ...) #'(x ...)])]
|
||||
[keyvals '()]
|
||||
[got null])
|
||||
|
|
@ -473,7 +474,7 @@
|
|||
(prefix-line (subst str generic-substs)))
|
||||
(define (write-text)
|
||||
(set-run-status "creating text file")
|
||||
(with-output-to-file text-file
|
||||
(with-output-to-file text-file #:exists 'truncate
|
||||
(lambda ()
|
||||
(for-each (lambda (user)
|
||||
(prefix-line
|
||||
|
|
@ -482,8 +483,7 @@
|
|||
(for-each prefix-line/substs extra-lines)
|
||||
(for-each prefix-line/substs
|
||||
(or (thread-cell-ref added-lines) '()))
|
||||
(display submission-text))
|
||||
'truncate))
|
||||
(display submission-text))))
|
||||
(define submission-text
|
||||
(and create-text?
|
||||
(begin (set-run-status "reading submission")
|
||||
|
|
@ -557,7 +557,7 @@
|
|||
[(_ get (var ...) body ...)
|
||||
(with-syntax ([(>var ...)
|
||||
(map (lambda (v)
|
||||
(datum->syntax-object
|
||||
(datum->syntax
|
||||
v
|
||||
(string->symbol
|
||||
(string-append
|
||||
|
|
@ -572,7 +572,7 @@
|
|||
(let ([make-pre/post:
|
||||
(lambda (what)
|
||||
(lambda (stx)
|
||||
(define (id s) (datum->syntax-object stx s stx))
|
||||
(define (id s) (datum->syntax stx s stx))
|
||||
(syntax-case stx ()
|
||||
[(_ body ...)
|
||||
(with-syntax ([users (id 'users)]
|
||||
|
|
|
|||
|
|
@ -1,187 +1,186 @@
|
|||
(module utils mzscheme
|
||||
(require mzlib/list
|
||||
mzlib/class
|
||||
mred
|
||||
lang/posn
|
||||
(prefix pc: mzlib/pconvert)
|
||||
mzlib/pretty
|
||||
(only "main.ss" timeout-control)
|
||||
"private/run-status.ss"
|
||||
"private/config.ss"
|
||||
"private/logger.ss"
|
||||
"sandbox.ss")
|
||||
#lang scheme/base
|
||||
|
||||
(provide (all-from "sandbox.ss")
|
||||
(require scheme/list
|
||||
scheme/class
|
||||
mred
|
||||
lang/posn
|
||||
(prefix-in pc: mzlib/pconvert)
|
||||
scheme/pretty
|
||||
(only-in "main.ss" timeout-control)
|
||||
"private/run-status.ss"
|
||||
"private/config.ss"
|
||||
"private/logger.ss"
|
||||
"sandbox.ss")
|
||||
|
||||
get-conf
|
||||
log-line
|
||||
(provide (all-from-out "sandbox.ss")
|
||||
|
||||
unpack-submission
|
||||
get-conf
|
||||
log-line
|
||||
|
||||
make-evaluator/submission
|
||||
evaluate-all
|
||||
evaluate-submission
|
||||
unpack-submission
|
||||
|
||||
call-with-evaluator
|
||||
call-with-evaluator/submission
|
||||
reraise-exn-as-submission-problem
|
||||
set-run-status
|
||||
message
|
||||
current-value-printer
|
||||
make-evaluator/submission
|
||||
evaluate-all
|
||||
evaluate-submission
|
||||
|
||||
check-proc
|
||||
check-defined
|
||||
look-for-tests
|
||||
user-construct
|
||||
test-history-enabled
|
||||
call-with-evaluator
|
||||
call-with-evaluator/submission
|
||||
reraise-exn-as-submission-problem
|
||||
set-run-status
|
||||
message
|
||||
current-value-printer
|
||||
|
||||
timeout-control)
|
||||
check-proc
|
||||
check-defined
|
||||
look-for-tests
|
||||
user-construct
|
||||
test-history-enabled
|
||||
|
||||
(define (unpack-submission str)
|
||||
(let* ([base (make-object editor-stream-in-bytes-base% str)]
|
||||
[stream (make-object editor-stream-in% base)]
|
||||
[definitions-text (make-object text%)]
|
||||
[interactions-text (make-object text%)])
|
||||
(read-editor-version stream base #t)
|
||||
(read-editor-global-header stream)
|
||||
(send definitions-text read-from-file stream)
|
||||
(send interactions-text read-from-file stream)
|
||||
(read-editor-global-footer stream)
|
||||
(values definitions-text interactions-text)))
|
||||
timeout-control)
|
||||
|
||||
;; Execution ----------------------------------------
|
||||
(define (unpack-submission str)
|
||||
(let* ([base (make-object editor-stream-in-bytes-base% str)]
|
||||
[stream (make-object editor-stream-in% base)]
|
||||
[definitions-text (make-object text%)]
|
||||
[interactions-text (make-object text%)])
|
||||
(read-editor-version stream base #t)
|
||||
(read-editor-global-header stream)
|
||||
(send definitions-text read-from-file stream)
|
||||
(send interactions-text read-from-file stream)
|
||||
(read-editor-global-footer stream)
|
||||
(values definitions-text interactions-text)))
|
||||
|
||||
(define (open-input-text-editor/lines str)
|
||||
(let ([inp (open-input-text-editor str)])
|
||||
(port-count-lines! inp) inp))
|
||||
;; Execution ----------------------------------------
|
||||
|
||||
(define (make-evaluator/submission language teachpacks str)
|
||||
(let-values ([(defs interacts) (unpack-submission str)])
|
||||
(make-evaluator language teachpacks (open-input-text-editor defs))))
|
||||
(define (open-input-text-editor/lines str)
|
||||
(let ([inp (open-input-text-editor str)])
|
||||
(port-count-lines! inp) inp))
|
||||
|
||||
(define (evaluate-all source port eval)
|
||||
(let loop ()
|
||||
(let ([expr (parameterize ([read-case-sensitive #t]
|
||||
[read-decimal-as-inexact #f])
|
||||
(read-syntax source port))])
|
||||
(unless (eof-object? expr)
|
||||
(eval expr)
|
||||
(loop)))))
|
||||
(define (make-evaluator/submission language teachpacks str)
|
||||
(let-values ([(defs interacts) (unpack-submission str)])
|
||||
(make-evaluator language teachpacks (open-input-text-editor defs))))
|
||||
|
||||
(define (evaluate-submission str eval)
|
||||
(let-values ([(defs interacts) (unpack-submission str)])
|
||||
(evaluate-all 'handin (open-input-text-editor/lines defs) eval)))
|
||||
(define (evaluate-all source port eval)
|
||||
(let loop ()
|
||||
(let ([expr (parameterize ([read-case-sensitive #t]
|
||||
[read-decimal-as-inexact #f])
|
||||
(read-syntax source port))])
|
||||
(unless (eof-object? expr)
|
||||
(eval expr)
|
||||
(loop)))))
|
||||
|
||||
(define (reraise-exn-as-submission-problem thunk)
|
||||
(with-handlers ([void (lambda (exn)
|
||||
(error (if (exn? exn)
|
||||
(define (evaluate-submission str eval)
|
||||
(let-values ([(defs interacts) (unpack-submission str)])
|
||||
(evaluate-all 'handin (open-input-text-editor/lines defs) eval)))
|
||||
|
||||
(define (reraise-exn-as-submission-problem thunk)
|
||||
(with-handlers ([void (lambda (exn)
|
||||
(error (if (exn? exn)
|
||||
(exn-message exn)
|
||||
(format "exception: ~e" exn))))])
|
||||
(thunk)))
|
||||
(thunk)))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Auto-test utils
|
||||
;; ----------------------------------------
|
||||
;; Auto-test utils
|
||||
|
||||
(define (check-defined e id)
|
||||
(with-handlers ([exn:fail:syntax? void]
|
||||
[exn:fail:contract:variable?
|
||||
(lambda (x)
|
||||
(error
|
||||
(format
|
||||
"\"~a\" is not defined, but it must be defined for handin"
|
||||
(exn:fail:contract:variable-id x))))])
|
||||
(e #`(#,namespace-variable-value '#,id #t))))
|
||||
(define (check-defined e id)
|
||||
(with-handlers ([exn:fail:syntax? void]
|
||||
[exn:fail:contract:variable?
|
||||
(lambda (x)
|
||||
(error
|
||||
(format
|
||||
"\"~a\" is not defined, but it must be defined for handin"
|
||||
(exn:fail:contract:variable-id x))))])
|
||||
(e #`(#,namespace-variable-value '#,id #t))))
|
||||
|
||||
(define test-history-enabled (make-parameter #f))
|
||||
(define test-history (make-parameter null))
|
||||
(define test-history-enabled (make-parameter #f))
|
||||
(define test-history (make-parameter null))
|
||||
|
||||
(define (format-history one-test)
|
||||
(if (test-history-enabled)
|
||||
(define (format-history one-test)
|
||||
(if (test-history-enabled)
|
||||
(format "(begin~a)"
|
||||
(apply string-append (map (lambda (s) (format " ~a" s))
|
||||
(reverse (test-history)))))
|
||||
one-test))
|
||||
|
||||
(define (check-proc e result equal? f . args)
|
||||
(let ([test (format "(~a~a)" f
|
||||
(apply string-append
|
||||
(map (lambda (a) (format " ~e" a)) args)))])
|
||||
(when (test-history-enabled)
|
||||
(test-history (cons test (test-history))))
|
||||
(set-run-status (format "running instructor-supplied test ~a"
|
||||
(format-history test)))
|
||||
(let-values ([(ok? val)
|
||||
(with-handlers ([void
|
||||
(lambda (x)
|
||||
(error
|
||||
(format "instructor-supplied test ~a failed with an error: ~e"
|
||||
(format-history test)
|
||||
(exn-message x))))])
|
||||
(let ([val (e `(,f ,@(map value-converter args)))])
|
||||
(values (or (eq? 'anything result)
|
||||
(equal? val result))
|
||||
val)))])
|
||||
(unless ok?
|
||||
(error
|
||||
(format "instructor-supplied test ~a should have produced ~e, instead produced ~e"
|
||||
(format-history test)
|
||||
result
|
||||
val)))
|
||||
val)))
|
||||
(define (check-proc e result equal? f . args)
|
||||
(let ([test (format "(~a~a)" f
|
||||
(apply string-append
|
||||
(map (lambda (a) (format " ~e" a)) args)))])
|
||||
(when (test-history-enabled)
|
||||
(test-history (cons test (test-history))))
|
||||
(set-run-status (format "running instructor-supplied test ~a"
|
||||
(format-history test)))
|
||||
(let-values ([(ok? val)
|
||||
(with-handlers ([void
|
||||
(lambda (x)
|
||||
(error
|
||||
(format "instructor-supplied test ~a failed with an error: ~e"
|
||||
(format-history test)
|
||||
(exn-message x))))])
|
||||
(let ([val (e `(,f ,@(map value-converter args)))])
|
||||
(values (or (eq? 'anything result)
|
||||
(equal? val result))
|
||||
val)))])
|
||||
(unless ok?
|
||||
(error
|
||||
(format "instructor-supplied test ~a should have produced ~e, instead produced ~e"
|
||||
(format-history test)
|
||||
result
|
||||
val)))
|
||||
val)))
|
||||
|
||||
(define (user-construct e func . args)
|
||||
(apply check-proc e func 'anything eq? args))
|
||||
(define (user-construct e func . args)
|
||||
(apply check-proc e func 'anything eq? args))
|
||||
|
||||
(define (look-for-tests t name count)
|
||||
(let ([p (open-input-text-editor/lines t)])
|
||||
(let loop ([found 0])
|
||||
(let ([e (read p)])
|
||||
(if (eof-object? e)
|
||||
(when (found . < . count)
|
||||
(error (format "found ~a test~a for ~a, need at least ~a test~a"
|
||||
found
|
||||
(if (= found 1) "" "s")
|
||||
name
|
||||
count
|
||||
(if (= count 1) "" "s"))))
|
||||
(loop (+ found
|
||||
(if (and (pair? e)
|
||||
(eq? (car e) name))
|
||||
1
|
||||
0))))))))
|
||||
(define (look-for-tests t name count)
|
||||
(let ([p (open-input-text-editor/lines t)])
|
||||
(let loop ([found 0])
|
||||
(let ([e (read p)])
|
||||
(if (eof-object? e)
|
||||
(when (found . < . count)
|
||||
(error (format "found ~a test~a for ~a, need at least ~a test~a"
|
||||
found
|
||||
(if (= found 1) "" "s")
|
||||
name
|
||||
count
|
||||
(if (= count 1) "" "s"))))
|
||||
(loop (+ found
|
||||
(if (and (pair? e)
|
||||
(eq? (car e) name))
|
||||
1
|
||||
0))))))))
|
||||
|
||||
(define list-abbreviation-enabled (make-parameter #f))
|
||||
(define list-abbreviation-enabled (make-parameter #f))
|
||||
|
||||
(define (value-converter v)
|
||||
(parameterize ([pc:booleans-as-true/false #t]
|
||||
[pc:abbreviate-cons-as-list (list-abbreviation-enabled)]
|
||||
[pc:constructor-style-printing #t])
|
||||
(pc:print-convert v)))
|
||||
(define (value-converter v)
|
||||
(parameterize ([pc:booleans-as-true/false #t]
|
||||
[pc:abbreviate-cons-as-list (list-abbreviation-enabled)]
|
||||
[pc:constructor-style-printing #t])
|
||||
(pc:print-convert v)))
|
||||
|
||||
(define (default-value-printer v)
|
||||
(parameterize ([pretty-print-show-inexactness #t]
|
||||
[pretty-print-.-symbol-without-bars #t]
|
||||
[pretty-print-exact-as-decimal #t]
|
||||
[pretty-print-columns +inf.0]
|
||||
[read-case-sensitive #t])
|
||||
(let ([p (open-output-string)])
|
||||
(pretty-print (value-converter v) p)
|
||||
(regexp-replace #rx"\n$" (get-output-string p) ""))))
|
||||
(define current-value-printer (make-parameter default-value-printer))
|
||||
(define (default-value-printer v)
|
||||
(parameterize ([pretty-print-show-inexactness #t]
|
||||
[pretty-print-.-symbol-without-bars #t]
|
||||
[pretty-print-exact-as-decimal #t]
|
||||
[pretty-print-columns +inf.0]
|
||||
[read-case-sensitive #t])
|
||||
(let ([p (open-output-string)])
|
||||
(pretty-print (value-converter v) p)
|
||||
(regexp-replace #rx"\n$" (get-output-string p) ""))))
|
||||
(define current-value-printer (make-parameter default-value-printer))
|
||||
|
||||
(define (call-with-evaluator lang teachpacks program-port go)
|
||||
(parameterize ([error-value->string-handler (lambda (v s)
|
||||
((current-value-printer) v))]
|
||||
[list-abbreviation-enabled (not (or (eq? lang 'beginner)
|
||||
(eq? lang 'beginner-abbr)))])
|
||||
(reraise-exn-as-submission-problem
|
||||
(lambda ()
|
||||
(let ([e (make-evaluator lang teachpacks program-port)])
|
||||
(set-run-status "executing your code")
|
||||
(go e))))))
|
||||
(define (call-with-evaluator lang teachpacks program-port go)
|
||||
(parameterize ([error-value->string-handler (lambda (v s)
|
||||
((current-value-printer) v))]
|
||||
[list-abbreviation-enabled (not (or (eq? lang 'beginner)
|
||||
(eq? lang 'beginner-abbr)))])
|
||||
(reraise-exn-as-submission-problem
|
||||
(lambda ()
|
||||
(let ([e (make-evaluator lang teachpacks program-port)])
|
||||
(set-run-status "executing your code")
|
||||
(go e))))))
|
||||
|
||||
(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)))
|
||||
|
||||
)
|
||||
(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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user