suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Converting utils.ss and checker.ss to scheme/base.

Browse Source 
svn: r11633
This commit is contained in:
Stevie Strickland 2008-09-10 17:59:24 +00:00
parent a115dc3d8b
commit 12bcac14d3
2 changed files with 174 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/handin-server/checker.ss
View File

@ -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) (define-syntax (module-begin~ stx)
(let ([e (if (syntax? stx) (syntax-e stx) stx)]) (let ([e (if (syntax? stx) (syntax-e stx) stx)])
(if (pair? e) (if (pair? e)
(with-syntax ([user-pre (datum->syntax-object stx 'user-pre stx)] (with-syntax ([user-pre (datum->syntax stx 'user-pre stx)]
[user-post (datum->syntax-object stx 'user-post stx)]) [user-post (datum->syntax stx 'user-post stx)])
(datum->syntax-object (datum->syntax
(quote-syntax here) (quote-syntax here)
(list* (quote-syntax #%plain-module-begin) (list* (quote-syntax #%plain-module-begin)
#'(define user-pre #f) #'(define user-pre #f)
@ -104,7 +105,7 @@
(format "~a" (or (send x get-text 0 (send x get-count) #t) x))] (format "~a" (or (send x get-text 0 (send x get-count) #t) x))]
[(special-comment? x) [(special-comment? x)
(format "#| ~a |#" (special-comment-value x))] (format "#| ~a |#" (special-comment-value x))]
[(syntax? x) (syntax-object->datum x)] [(syntax? x) (syntax->datum x)]
[else x])) [else x]))
(let-values ([(filter) (if (pair? filter) (car filter) item->text)] (let-values ([(filter) (if (pair? filter) (car filter) item->text)]
[(in out) (make-pipe 4096)]) [(in out) (make-pipe 4096)])
@ -317,7 +318,7 @@
(define submission-eval (make-parameter #f)) (define submission-eval (make-parameter #f))
;; without this the primitive eval is not available ;; 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 ;; for adding lines in the checker
(define added-lines (make-thread-cell #f)) (define added-lines (make-thread-cell #f))
@ -344,7 +345,7 @@
(provide check:) (provide check:)
(define-syntax (check: stx) (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 ...)])] (let loop ([stx (syntax-case stx () [(_ x ...) #'(x ...)])]
[keyvals '()] [keyvals '()]
[got null]) [got null])
@ -473,7 +474,7 @@
(prefix-line (subst str generic-substs))) (prefix-line (subst str generic-substs)))
(define (write-text) (define (write-text)
(set-run-status "creating text file") (set-run-status "creating text file")
(with-output-to-file text-file (with-output-to-file text-file #:exists 'truncate
(lambda () (lambda ()
(for-each (lambda (user) (for-each (lambda (user)
(prefix-line (prefix-line
@ -482,8 +483,7 @@
(for-each prefix-line/substs extra-lines) (for-each prefix-line/substs extra-lines)
(for-each prefix-line/substs (for-each prefix-line/substs
(or (thread-cell-ref added-lines) '())) (or (thread-cell-ref added-lines) '()))
(display submission-text)) (display submission-text))))
'truncate))
(define submission-text (define submission-text
(and create-text? (and create-text?
(begin (set-run-status "reading submission") (begin (set-run-status "reading submission")
@ -557,7 +557,7 @@
[(_ get (var ...) body ...) [(_ get (var ...) body ...)
(with-syntax ([(>var ...) (with-syntax ([(>var ...)
(map (lambda (v) (map (lambda (v)
(datum->syntax-object (datum->syntax
v v
(string->symbol (string->symbol
(string-append (string-append
@ -572,7 +572,7 @@
(let ([make-pre/post: (let ([make-pre/post:
(lambda (what) (lambda (what)
(lambda (stx) (lambda (stx)
(define (id s) (datum->syntax-object stx s stx)) (define (id s) (datum->syntax stx s stx))
(syntax-case stx () (syntax-case stx ()
[(_ body ...) [(_ body ...)
(with-syntax ([users (id 'users)] (with-syntax ([users (id 'users)]

319
collects/handin-server/utils.ss
View File

@ -1,187 +1,186 @@
(module utils mzscheme #lang scheme/base
(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")
(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 (provide (all-from-out "sandbox.ss")
log-line
get-conf
log-line
unpack-submission
make-evaluator/submission
evaluate-all
evaluate-submission
call-with-evaluator
call-with-evaluator/submission
reraise-exn-as-submission-problem
set-run-status
message
current-value-printer
check-proc
check-defined
look-for-tests
user-construct
test-history-enabled
timeout-control)
unpack-submission (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)))
make-evaluator/submission ;; Execution ----------------------------------------
evaluate-all
evaluate-submission
call-with-evaluator (define (open-input-text-editor/lines str)
call-with-evaluator/submission (let ([inp (open-input-text-editor str)])
reraise-exn-as-submission-problem (port-count-lines! inp) inp))
set-run-status
message
current-value-printer
check-proc (define (make-evaluator/submission language teachpacks str)
check-defined (let-values ([(defs interacts) (unpack-submission str)])
look-for-tests (make-evaluator language teachpacks (open-input-text-editor defs))))
user-construct
test-history-enabled
timeout-control) (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 (unpack-submission str) (define (evaluate-submission str eval)
(let* ([base (make-object editor-stream-in-bytes-base% str)] (let-values ([(defs interacts) (unpack-submission str)])
[stream (make-object editor-stream-in% base)] (evaluate-all 'handin (open-input-text-editor/lines defs) eval)))
[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)))
;; Execution ---------------------------------------- (define (reraise-exn-as-submission-problem thunk)
(with-handlers ([void (lambda (exn)
(define (open-input-text-editor/lines str) (error (if (exn? exn)
(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))))
(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 (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) (exn-message exn)
(format "exception: ~e" exn))))]) (format "exception: ~e" exn))))])
(thunk))) (thunk)))
;; ---------------------------------------- ;; ----------------------------------------
;; Auto-test utils ;; Auto-test utils
(define (check-defined e id) (define (check-defined e id)
(with-handlers ([exn:fail:syntax? void] (with-handlers ([exn:fail:syntax? void]
[exn:fail:contract:variable? [exn:fail:contract:variable?
(lambda (x) (lambda (x)
(error (error
(format (format
"\"~a\" is not defined, but it must be defined for handin" "\"~a\" is not defined, but it must be defined for handin"
(exn:fail:contract:variable-id x))))]) (exn:fail:contract:variable-id x))))])
(e #`(#,namespace-variable-value '#,id #t)))) (e #`(#,namespace-variable-value '#,id #t))))
(define test-history-enabled (make-parameter #f)) (define test-history-enabled (make-parameter #f))
(define test-history (make-parameter null)) (define test-history (make-parameter null))
(define (format-history one-test) (define (format-history one-test)
(if (test-history-enabled) (if (test-history-enabled)
(format "(begin~a)" (format "(begin~a)"
(apply string-append (map (lambda (s) (format " ~a" s)) (apply string-append (map (lambda (s) (format " ~a" s))
(reverse (test-history))))) (reverse (test-history)))))
one-test)) one-test))
(define (check-proc e result equal? f . args) (define (check-proc e result equal? f . args)
(let ([test (format "(~a~a)" f (let ([test (format "(~a~a)" f
(apply string-append (apply string-append
(map (lambda (a) (format " ~e" a)) args)))]) (map (lambda (a) (format " ~e" a)) args)))])
(when (test-history-enabled) (when (test-history-enabled)
(test-history (cons test (test-history)))) (test-history (cons test (test-history))))
(set-run-status (format "running instructor-supplied test ~a" (set-run-status (format "running instructor-supplied test ~a"
(format-history test))) (format-history test)))
(let-values ([(ok? val) (let-values ([(ok? val)
(with-handlers ([void (with-handlers ([void
(lambda (x) (lambda (x)
(error (error
(format "instructor-supplied test ~a failed with an error: ~e" (format "instructor-supplied test ~a failed with an error: ~e"
(format-history test) (format-history test)
(exn-message x))))]) (exn-message x))))])
(let ([val (e `(,f ,@(map value-converter args)))]) (let ([val (e `(,f ,@(map value-converter args)))])
(values (or (eq? 'anything result) (values (or (eq? 'anything result)
(equal? val result)) (equal? val result))
val)))]) val)))])
(unless ok? (unless ok?
(error (error
(format "instructor-supplied test ~a should have produced ~e, instead produced ~e" (format "instructor-supplied test ~a should have produced ~e, instead produced ~e"
(format-history test) (format-history test)
result result
val))) val)))
val))) val)))
(define (user-construct e func . args) (define (user-construct e func . args)
(apply check-proc e func 'anything eq? args)) (apply check-proc e func 'anything eq? args))
(define (look-for-tests t name count) (define (look-for-tests t name count)
(let ([p (open-input-text-editor/lines t)]) (let ([p (open-input-text-editor/lines t)])
(let loop ([found 0]) (let loop ([found 0])
(let ([e (read p)]) (let ([e (read p)])
(if (eof-object? e) (if (eof-object? e)
(when (found . < . count) (when (found . < . count)
(error (format "found ~a test~a for ~a, need at least ~a test~a" (error (format "found ~a test~a for ~a, need at least ~a test~a"
found found
(if (= found 1) "" "s") (if (= found 1) "" "s")
name name
count count
(if (= count 1) "" "s")))) (if (= count 1) "" "s"))))
(loop (+ found (loop (+ found
(if (and (pair? e) (if (and (pair? e)
(eq? (car e) name)) (eq? (car e) name))
1 1
0)))))))) 0))))))))
(define list-abbreviation-enabled (make-parameter #f)) (define list-abbreviation-enabled (make-parameter #f))
(define (value-converter v) (define (value-converter v)
(parameterize ([pc:booleans-as-true/false #t] (parameterize ([pc:booleans-as-true/false #t]
[pc:abbreviate-cons-as-list (list-abbreviation-enabled)] [pc:abbreviate-cons-as-list (list-abbreviation-enabled)]
[pc:constructor-style-printing #t]) [pc:constructor-style-printing #t])
(pc:print-convert v))) (pc:print-convert v)))
(define (default-value-printer v) (define (default-value-printer v)
(parameterize ([pretty-print-show-inexactness #t] (parameterize ([pretty-print-show-inexactness #t]
[pretty-print-.-symbol-without-bars #t] [pretty-print-.-symbol-without-bars #t]
[pretty-print-exact-as-decimal #t] [pretty-print-exact-as-decimal #t]
[pretty-print-columns +inf.0] [pretty-print-columns +inf.0]
[read-case-sensitive #t]) [read-case-sensitive #t])
(let ([p (open-output-string)]) (let ([p (open-output-string)])
(pretty-print (value-converter v) p) (pretty-print (value-converter v) p)
(regexp-replace #rx"\n$" (get-output-string p) "")))) (regexp-replace #rx"\n$" (get-output-string p) ""))))
(define current-value-printer (make-parameter default-value-printer)) (define current-value-printer (make-parameter default-value-printer))
(define (call-with-evaluator lang teachpacks program-port go) (define (call-with-evaluator lang teachpacks program-port go)
(parameterize ([error-value->string-handler (lambda (v s) (parameterize ([error-value->string-handler (lambda (v s)
((current-value-printer) v))] ((current-value-printer) v))]
[list-abbreviation-enabled (not (or (eq? lang 'beginner) [list-abbreviation-enabled (not (or (eq? lang 'beginner)
(eq? lang 'beginner-abbr)))]) (eq? lang 'beginner-abbr)))])
(reraise-exn-as-submission-problem (reraise-exn-as-submission-problem
(lambda () (lambda ()
(let ([e (make-evaluator lang teachpacks program-port)]) (let ([e (make-evaluator lang teachpacks program-port)])
(set-run-status "executing your code") (set-run-status "executing your code")
(go e)))))) (go e))))))
(define (call-with-evaluator/submission lang teachpacks str go) (define (call-with-evaluator/submission lang teachpacks str go)
(let-values ([(defs interacts) (unpack-submission str)]) (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 defs) go)))
)