From 12bcac14d38158d3e96191f04d0b05429dbe41d3 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 10 Sep 2008 17:59:24 +0000 Subject: [PATCH] Converting utils.ss and checker.ss to scheme/base. svn: r11633 --- collects/handin-server/checker.ss | 30 +-- collects/handin-server/utils.ss | 319 +++++++++++++++--------------- 2 files changed, 174 insertions(+), 175 deletions(-) diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index 53810df2c5..ced5594804 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -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)] diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss index 451b643e01..f3042d99fd 100644 --- a/collects/handin-server/utils.ss +++ b/collects/handin-server/utils.ss @@ -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") + + 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 - evaluate-all - evaluate-submission +;; Execution ---------------------------------------- - call-with-evaluator - call-with-evaluator/submission - reraise-exn-as-submission-problem - set-run-status - message - current-value-printer +(define (open-input-text-editor/lines str) + (let ([inp (open-input-text-editor str)]) + (port-count-lines! inp) inp)) - check-proc - check-defined - look-for-tests - user-construct - test-history-enabled +(define (make-evaluator/submission language teachpacks str) + (let-values ([(defs interacts) (unpack-submission str)]) + (make-evaluator language teachpacks (open-input-text-editor defs)))) - 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) - (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 (evaluate-submission str eval) + (let-values ([(defs interacts) (unpack-submission str)]) + (evaluate-all 'handin (open-input-text-editor/lines defs) eval))) - ;; Execution ---------------------------------------- - - (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)))) - - (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) +(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)))