updating...

svn: r15427

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)])

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)

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.

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)])
+  (let ([error-has-occurred-box (box #f)])
-    (test-sequence/many models exp-str expected-steps)
+    (test-sequence/many models exp-str expected-steps error-has-occurred-box)
-    (if (unbox (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)
+(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))
+  (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?)])
+              ;; thunk this so that syntax errors happen within the error handlers:
-         (test-sequence/core render-settings show-lambdas-as-lambdas? expanded expected-steps)))]))
+              [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))
+                  (if (compare-steps result (car all-steps) error-box)
-                      (when (and (show-all-steps) (not (display-only-errors)))
+                      (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)
+(define (warn error-box who fmt . args)
-  (set-box! (error-has-occurred-box) #t)
+  (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]
+    [`(ignore) (warn error-box 
-    [else (begin (warn 'compare-steps
+                     '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)))])

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)
 
@@ -1422,6 +1423,16 @@
       "(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):
   (define (ggg)
@@ -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" 
+              `())