diff --git a/collects/tests/stepper/automatic-tests.ss b/collects/tests/stepper/automatic-tests.ss index 3ba2ce909c..c2c6709cd6 100644 --- a/collects/tests/stepper/automatic-tests.ss +++ b/collects/tests/stepper/automatic-tests.ss @@ -1,5 +1,6 @@ (module automatic-tests mzscheme - (require "through-tests.ss") + (require "through-tests.ss" + "test-engine.ss") (parameterize ([display-only-errors #t] [current-output-port (open-output-string)]) diff --git a/collects/tests/stepper/jump-to-ui-test.ss b/collects/tests/stepper/jump-to-ui-test.ss new file mode 100644 index 0000000000..492af8de10 --- /dev/null +++ b/collects/tests/stepper/jump-to-ui-test.ss @@ -0,0 +1,12 @@ +;; The first three lines of this file were inserted by DrScheme. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-intermediate-reader.ss" "lang")((modname jump-to-ui-test) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +(+ 3 4) + +(+ 4 5) + +(check-expect (+ 5 6) 11) + +(+ 6 7) + +(+ 7 8) \ No newline at end of file diff --git a/collects/tests/stepper/manual-tests.txt b/collects/tests/stepper/manual-tests.txt index 48a755f1ef..8911739758 100644 --- a/collects/tests/stepper/manual-tests.txt +++ b/collects/tests/stepper/manual-tests.txt @@ -1,3 +1,6 @@ +;; The first three lines of this file were inserted by DrScheme. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-beginner-reader.ss" "lang")((modname manual-tests) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp") (lib "prisoners-tp.ss" "installed-teachpacks"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp") (lib "prisoners-tp.ss" "installed-teachpacks"))))) open stepper, make sure it works for (+ 3 4). make sure that stepper button appears and disappears as necessary when @@ -18,3 +21,5 @@ Try programs which print snips (print-convert-test.ss) try programs that contain test cases; make sure that the popups behave sensibly. + +Try jumping to the end on a program with an error. diff --git a/collects/tests/stepper/test-engine.ss b/collects/tests/stepper/test-engine.ss index 202f21baa0..bd79deb982 100644 --- a/collects/tests/stepper/test-engine.ss +++ b/collects/tests/stepper/test-engine.ss @@ -52,6 +52,7 @@ ;; (so that you can take advantage of DrScheme's error reporting) (define disable-stepper-error-handling (make-parameter #f)) + ;; DATA DEFINITIONS: ;; a step is one of @@ -100,26 +101,27 @@ (define (run-one-test name models exp-str expected-steps) (unless (display-only-errors) (printf "running test: ~v\n" name)) - (parameterize ([error-has-occurred-box (box #f)]) - (test-sequence/many models exp-str expected-steps) - (if (unbox (error-has-occurred-box)) + (let ([error-has-occurred-box (box #f)]) + (test-sequence/many models exp-str expected-steps error-has-occurred-box) + (if (unbox error-has-occurred-box) (begin (fprintf (current-error-port) "...Error has occurred during test: ~v\n" name) #f) - #t))) + #t) + )) ;; 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) - (cond [(list? models)(for-each (lambda (model) (test-sequence model exp-str expected-steps)) +(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)) models)] - [else (test-sequence models exp-str expected-steps)])) + [else (test-sequence models exp-str expected-steps error-box)])) ;; test-sequence : ll-model? string? steps? -> (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) +(define (test-sequence the-ll-model exp-str expected-steps error-box) (match the-ll-model [(struct ll-model (namespace-spec teachpack-specs render-settings show-lambdas-as-lambdas? enable-testing?)) (let ([filename (build-path test-directory "stepper-test")]) @@ -131,35 +133,45 @@ (printf "testing string: ~v\n" exp-str)) (let* ([port (open-input-file filename)] [module-id (gensym "stepper-module-name-")] - [expanded (expand-teaching-program port read-syntax namespace-spec teachpack-specs #f module-id enable-testing?)]) - (test-sequence/core render-settings show-lambdas-as-lambdas? expanded expected-steps)))])) + ;; thunk this so that syntax errors happen within the error handlers: + [expanded-thunk + (lambda () (expand-teaching-program port read-syntax namespace-spec teachpack-specs #f module-id enable-testing?))]) + (test-sequence/core render-settings show-lambdas-as-lambdas? expanded-thunk expected-steps error-box)))])) ;; test-sequence/core : render-settings? boolean? syntax? steps? ;; this is a front end for calling the stepper's "go"; the main ;; responsibility here is to fake the behavior of DrScheme and collect the ;; resulting steps. -(define (test-sequence/core render-settings show-lambdas-as-lambdas? expanded expected-steps) +(define (test-sequence/core render-settings show-lambdas-as-lambdas? expanded-thunk expected-steps error-box) (let* ([current-error-display-handler (error-display-handler)] [all-steps (append expected-steps '((finished-stepping)))] + ;; the values of certain parameters aren't surviving; create + ;; lexical bindings for them: + [current-show-all-steps (show-all-steps)] + [current-display-only-errors (display-only-errors)] [receive-result (lambda (result) (if (null? all-steps) - (warn 'test-sequence + (warn error-box + 'test-sequence "ran out of expected steps. Given result: ~v" result) (begin - (if (compare-steps result (car all-steps)) - (when (and (show-all-steps) (not (display-only-errors))) + (if (compare-steps result (car all-steps) error-box) + (when (and current-show-all-steps (not current-display-only-errors)) (printf "test-sequence: steps match for expected result: ~v\n" (car all-steps))) - (warn 'test-sequence + (warn error-box + 'test-sequence "steps do not match\n given: ~v\nexpected: ~v" - (show-result result) (car all-steps))) + (show-result result error-box) + (car all-steps))) (set! all-steps (cdr all-steps)))))] + [dc1 (display (expanded-thunk))] [iter-caller (lambda (init iter) (init) - (call-iter-on-each expanded iter))]) + (call-iter-on-each (expanded-thunk) iter))]) (let/ec escape (parameterize ([error-escape-handler (lambda () (escape (void)))]) (go iter-caller receive-result render-settings @@ -177,28 +189,29 @@ (define (call-iter-on-each stx-thunk iter) (let* ([next (stx-thunk)] [followup-thunk (if (eof-object? next) void (lambda () (call-iter-on-each stx-thunk iter)))]) - (iter (expand next) followup-thunk))) + (iter next followup-thunk))) -(define error-has-occurred-box (make-parameter #f)) -(define (warn who fmt . args) - (set-box! (error-has-occurred-box) #t) +(define (warn error-box who fmt . args) + (set-box! error-box #t) (fprintf (current-error-port) "~a: ~a\n" who (apply format fmt args))) ;; (-> step-result? sexp? boolean?) -(define (compare-steps actual expected) +(define (compare-steps actual expected error-box) (match expected [`(before-after ,before ,after) (and (before-after-result? actual) (andmap (lambda (fn expected name) (unless (list? (fn actual)) - (warn 'compare-steps "not a list: ~v" + (warn error-box + 'compare-steps "not a list: ~v" (syntax->hilite-datum (fn actual)))) (noisy-equal? (map syntax->hilite-datum (fn actual)) expected - name)) + name + error-box)) (list before-after-result-pre-exps before-after-result-post-exps) (list before after) @@ -211,23 +224,27 @@ (and (noisy-equal? (map syntax->hilite-datum (before-error-result-pre-exps actual)) before - 'before) + 'before + error-box) (equal? err-msg (before-error-result-err-msg actual))))] [`(finished-stepping) (finished-stepping? actual)] - [`(ignore) (warn 'compare-steps "ignoring one step") #t] - [else (begin (warn 'compare-steps + [`(ignore) (warn error-box + 'compare-steps "ignoring one step") #t] + [else (begin (warn error-box + 'compare-steps "unexpected expected step type: ~v" expected) #f)])) ;; used to display results in an error message -(define (show-result r) +(define (show-result r error-box) (if (before-after-result? r) (list 'before-after-result (map (lambda (fn) (unless (list? (fn r)) - (warn 'show-result "not a list: ~v" + (warn error-box + 'show-result "not a list: ~v" (syntax->hilite-datum (fn r)))) (map syntax->hilite-datum (fn r))) @@ -237,11 +254,26 @@ ;; noisy-equal? : (any any . -> . boolean) ;; like equal?, but prints a noisy error message -(define (noisy-equal? actual expected name) +(define (noisy-equal? actual expected name error-box) (if (equal? actual expected) #t - (begin (warn 'not-equal? + (begin (warn error-box 'not-equal? "~e:\nactual: ~e =/= \nexpected: ~e\n here's the diff: ~e" name actual expected (sexp-diff actual expected)) #f))) + + +;; test-sequence : ll-model? string? steps? -> (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) +(match mz + [(struct ll-model (namespace-spec teachpack-specs render-settings show-lambdas-as-lambdas? enable-testing?)) + (let* ([p2 (open-input-string "134")] + [module-id (gensym "stepper-module-name-")] + ;; thunk this so that syntax errors happen within the error handlers: + [expanded-thunk + (lambda () (expand-teaching-program p2 read-syntax namespace-spec teachpack-specs #f module-id enable-testing?))]) + (display (expanded-thunk)) + (test-sequence/core render-settings show-lambdas-as-lambdas? expanded-thunk '() (box #f)))]) \ No newline at end of file diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss index cb598b6a67..ae92690761 100755 --- a/collects/tests/stepper/through-tests.ss +++ b/collects/tests/stepper/through-tests.ss @@ -13,6 +13,7 @@ ) +(provide run-test run-tests run-all-tests run-all-tests-except) (define list-of-tests null) @@ -1421,6 +1422,16 @@ (test-teachpack-sequence "(define (f2c x) x) (convert-gui f2c)" `() ; placeholder )) + + ;; SYNTAX ERRORS : + + (t1 'bad-parens m:upto-int/lam + "(" + `((error "read: expected a `)' to close `('"))) + + #;(t1 'bad-stx-and m:upto-int/lam + "(and)" + `((error "foo"))) ;; run whatever tests are enabled (intended for interactive use): @@ -1431,5 +1442,15 @@ #;[show-all-steps #t]) #;(run-tests '(check-expect forward-ref check-within #;check-within-bad #;check-error) #;'(#;check-expect #;check-expect-2 check-within check-within-bad check-error)) #;(run-tests '(teachpack-universe)) + #;(run-test 'bad-parens) (run-all-tests))) + +(define (hhh) + (run-one-test 'bogus + m:mz "abc" + `())) + +(run-one-test 'bogus + m:mz "abc" + `()) \ No newline at end of file