diff --git a/collects/tests/stepper/test-abbrev.rkt b/collects/tests/stepper/test-abbrev.rkt index 52551dd400..4834732612 100644 --- a/collects/tests/stepper/test-abbrev.rkt +++ b/collects/tests/stepper/test-abbrev.rkt @@ -74,7 +74,8 @@ (list name ll-models ;printf "exprs = ~s\n args = ~s\n" - (exprs->string `exprs) `(arg ...))))])) + (exprs->string `exprs) `(arg ...) + '())))])) ;; (-> (listof sexp) string?) diff --git a/collects/tests/stepper/test-engine.rkt b/collects/tests/stepper/test-engine.rkt index ce19b9b768..5d244927ca 100644 --- a/collects/tests/stepper/test-engine.rkt +++ b/collects/tests/stepper/test-engine.rkt @@ -77,8 +77,8 @@ ;; THE METHOD THAT RUNS A TEST: -(provide/contract [run-one-test (symbol? model-or-models/c string? (listof step?) . -> . boolean?)]) -;; run-one-test : symbol? model-or-models? string? steps? -> boolean? +(provide/contract [run-one-test (symbol? model-or-models/c string? (listof step?) (listof (list/c string? string?)) . -> . boolean?)]) +;; run-one-test : symbol? model-or-models? string? steps? extra-files -> boolean? ;; the ll-model determines the behavior of the stepper w.r.t. "language-level"-y things: ;; how should values be rendered, should steps be displayed (i.e, will the input & output @@ -90,13 +90,15 @@ ;; the steps lists the desired steps. The easiest way to understand these is probably just to ;; read the code for the comparison given in "compare-steps", below. +;; the extra-files contain a list of other files that must occur in the same directory. + ;; run the named test, return #t if a failure occurred during the test. -(define (run-one-test name models exp-str expected-steps) +(define (run-one-test name models exp-str expected-steps extra-files) (unless (display-only-errors) (printf "running test: ~v\n" name)) (let ([error-has-occurred-box (box #f)]) - (test-sequence/many models exp-str expected-steps error-has-occurred-box) + (test-sequence/many models exp-str expected-steps extra-files error-has-occurred-box) (if (unbox error-has-occurred-box) (begin (fprintf (current-error-port) "...Error has occurred during test: ~v\n" name) #f) @@ -109,18 +111,25 @@ ;; test-sequence/many : model-or-models/c string? steps? -> (void) ;; run a given test through a bunch of language models (or just one). -(define (test-sequence/many models exp-str expected-steps error-box) - (cond [(list? models)(for-each (lambda (model) (test-sequence model exp-str expected-steps error-box)) +(define (test-sequence/many models exp-str expected-steps extra-files error-box) + (cond [(list? models)(for-each (lambda (model) (test-sequence model exp-str expected-steps extra-files error-box)) models)] - [else (test-sequence models exp-str expected-steps error-box)])) + [else (test-sequence models exp-str expected-steps extra-files error-box)])) -;; test-sequence : ll-model? string? steps? -> (void) +;; test-sequence : ll-model? string? steps? extra-files? -> (void) ;; given a language model and an expression and a sequence of steps, ;; check to see whether the stepper produces the desired steps -(define (test-sequence the-ll-model exp-str expected-steps error-box) +(define (test-sequence the-ll-model exp-str expected-steps extra-files error-box) (match the-ll-model [(struct ll-model (namespace-spec render-settings enable-testing?)) (let ([filename (build-path test-directory "stepper-test")]) + (for ([f (in-list extra-files)]) + (define filename (first f)) + (define content (second f)) + (when (file-exists? filename) + (fprintf (current-error-port) 'run-one-test "file ~s exists, truncating...\n") + (delete-file filename)) + (display-to-file content filename)) (call-with-output-file filename (lambda (port) (fprintf port "~a" exp-str)) #:exists @@ -132,7 +141,9 @@ ;; thunk this so that syntax errors happen within the error handlers: [expanded-thunk (lambda () (expand-teaching-program port read-syntax namespace-spec '() #f module-id enable-testing?))]) - (test-sequence/core render-settings expanded-thunk expected-steps error-box)))])) + (test-sequence/core render-settings expanded-thunk expected-steps error-box)) + (for ([f (in-list extra-files)]) + (delete-file (first f))))])) ;; test-sequence/core : render-settings? boolean? syntax? steps? ;; this is a front end for calling the stepper's "go"; the main diff --git a/collects/tests/stepper/through-tests.rkt b/collects/tests/stepper/through-tests.rkt index e0b97828b0..2b31738d7e 100755 --- a/collects/tests/stepper/through-tests.rkt +++ b/collects/tests/stepper/through-tests.rkt @@ -20,16 +20,30 @@ (define (add-test test) (match test - [(list name models string expected-steps) + [(list name models string expected-steps extra-files) + (unless (symbol? name) + (error 'add-test "expected name to be a symbol, got: ~e" name)) + (unless (or (m:ll-model? models) + (and (list? models) (andmap m:ll-model? models))) + (error 'add-test "expected models to be a list of models, got: ~e" models)) + (unless (string? string) + (error 'add-test "expected string to be a string, got: ~e" string)) + (unless (list? expected-steps) + (error 'add-test "expected expected-steps to be a list, got: ~e" expected-steps)) + (match extra-files + [(list (list (? string? filename) (? string? content)) ...) #t] + [other (error 'add-test + "expected list of extra file specifications, got: ~e" + other)]) (when (assq name list-of-tests) (error 'add-test "name ~v is already in the list of tests" name)) (set! list-of-tests (append list-of-tests (list (list name - (list models string expected-steps)))))])) + (rest test)))))])) (define (t1 name models string expected-steps) - (add-test (list name models string expected-steps))) + (add-test (list name models string expected-steps '()))) ;; one more layer around (define-syntax (t stx) @@ -2170,11 +2184,20 @@ -> (define (f x) (local ((define-struct a (b c))) x)) {(define-struct a_1 (b c))} {1}) + ;; test of require + (add-test + (list 'require-test m:upto-int/lam + "(require \"foo.rkt\") (+ a 4)" + '((before-after ((require "foo.rkt") (+ (hilite a) 4)) + ((require "foo.rkt") (hilite (+ 3 4)))) + (before-after ((require "foo.rkt") (hilite (+ 3 4))) + ((require "foo.rkt") (hilite 7)))) + '(("foo.rkt" "#lang racket \n(provide a) (define a 3)")))) (provide ggg) ;; run whatever tests are enabled (intended for interactive use): (define (ggg) - (parameterize ([disable-stepper-error-handling #t] + (parameterize (#;[disable-stepper-error-handling #t] #;[display-only-errors #t] #;[store-steps #f] #;[show-all-steps #t]) @@ -2182,5 +2205,5 @@ check-error check-error-bad)) #;(run-tests '(teachpack-universe)) #;(run-all-tests) - (run-tests '(simple-if)) + (run-test 'require-test) ))