From 08fec4f10e564474e69476ee279b1e9527c8d8b3 Mon Sep 17 00:00:00 2001
From: John Clements <clements@racket-lang.org>
Date: Tue, 14 Apr 2009 03:09:41 +0000
Subject: [PATCH] ...

svn: r14505
---
 collects/tests/stepper/test-abbrev.ss   | 84 +++++++++++++++++++++++++
 collects/tests/stepper/test-engine.ss   |  8 ++-
 collects/tests/stepper/through-tests.ss |  7 +--
 3 files changed, 94 insertions(+), 5 deletions(-)
 create mode 100644 collects/tests/stepper/test-abbrev.ss

diff --git a/collects/tests/stepper/test-abbrev.ss b/collects/tests/stepper/test-abbrev.ss
new file mode 100644
index 0000000000..f2623bfe31
--- /dev/null
+++ b/collects/tests/stepper/test-abbrev.ss
@@ -0,0 +1,84 @@
+#lang scheme
+
+(require (for-syntax scheme/mpair))
+
+(provide tt)
+
+;; tt : eli's convenient short-cut syntactic form for defining tests.
+
+;; here's an example of how you might use it:
+#;(let* ([defs1 `((define (a x) (+ x 5)) (define b a))]
+       [defs2 (append defs1 `((define c a)))])
+  (tt 'top-ref4 m:intermediate
+     ,@defs1 (define c b) (c 3)
+     :: ,@defs1 (define c {b})
+     -> ,@defs1 (define c {a})
+     :: ,@defs2 ({c} 3)
+     -> ,@defs2 ({a} 3)
+     :: ,@defs2 {(a 3)}
+     -> ,@defs2 {(+ 3 5)}
+     -> ,@defs2 {8}))
+
+
+
+(define-syntax (tt stx)
+  (define (maybe-mlist->list r)
+    (if (mpair? r) 
+        (mlist->list r)
+        r))
+  (define (split l)
+    (let loop ([l l] [r '()])
+      (cond [(null? l) (reverse (map maybe-mlist->list r))]
+            [(symbol? (car l)) (loop (cdr l) (cons (car l) r))]
+            [(or (null? r) (not (mpair? (car r))))
+             (loop (cdr l) (cons (mlist (car l)) r))]
+            [else (mappend! (car r) (mlist (car l))) 
+                  (loop (cdr l) r)])))
+  (define (process-hilites s)
+    (syntax-case s ()
+      [(x) (eq? #\{ (syntax-property s 'paren-shape))
+           (with-syntax ([x (process-hilites #'x)]) #'(hilite x))]
+      [(x . y) (let* ([x0 #'x]
+                      [y0 #'y]
+                      [x1 (process-hilites #'x)]
+                      [y1 (process-hilites #'y)])
+                 (if (and (eq? x0 x1) (eq? y0 y1))
+                     s
+                     (with-syntax ([x x1] [y y1]) #'(x . y))))]
+      [_else s]))
+  (define (process stx)
+    (split (map (lambda (s)
+                  (if (and (identifier? s)
+                           (memq (syntax-e s) '(:: -> error:)))
+                      (syntax-e s)
+                      (process-hilites s)))
+                (syntax->list stx))))
+  (define (parse l)
+    (syntax-case l (::)
+      [(fst :: rest ...)
+       (cons #'fst
+             (let loop ([rest #'(rest ...)])
+               (syntax-case rest (:: -> error:)
+                 [(error: (err)) (list #'(error err))]
+                 [() (list #'(finished-stepping))]
+                 [(x -> y) (list #'(before-after x y) #'(finished-stepping))]
+                 [(x -> error: (err)) (list #'(before-error x err))]
+                 [(x -> y :: . rest)
+                  (cons #'(before-after x y) (loop #'rest))]
+                 [(x -> y -> . rest)
+                  (cons #'(before-after x y) (loop #'(y -> . rest)))])))]))
+  (syntax-case stx (::)
+    [(_ name ll-models . rest)
+     (with-syntax ([(exprs arg ...) (parse (process #'rest))])
+       (quasisyntax/loc stx
+         (list name
+               ll-models
+               ;printf "exprs = ~s\n args = ~s\n"
+               (exprs->string `exprs) `(arg ...))))]))
+
+
+;; (-> (listof sexp) string?)
+(define (exprs->string exprs)
+  (apply string-append
+         (cdr (apply append (map (lambda (x) (list " " (format "~s" x)))
+                                 exprs)))))
\ No newline at end of file
diff --git a/collects/tests/stepper/test-engine.ss b/collects/tests/stepper/test-engine.ss
index e15f99e676..da148acdcc 100644
--- a/collects/tests/stepper/test-engine.ss
+++ b/collects/tests/stepper/test-engine.ss
@@ -90,7 +90,13 @@
 ;; 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.
 
-;; run the named test, return #t if a failure occurred during the test
+;; run the named test, return #t if a failure occurred during the test.
+
+;; WARNING: evaluating code expanded using run-teaching-program causes mutation of the
+;; current namespace.  Unfortunately, wrapping a parameterize around each test (i.e., in this
+;; file) causes unacceptable slowdown and severe weirdness.  I tried saving and restoring 
+;; the namespace through mutation, and got severe weirdness again.
+
 (define (run-one-test name models exp-str expected-steps)
   (unless (display-only-errors)
     (printf "running test: ~v\n" name))
diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss
index ea3b01b9df..cfd1653a1f 100755
--- a/collects/tests/stepper/through-tests.ss
+++ b/collects/tests/stepper/through-tests.ss
@@ -13,6 +13,7 @@
 
          )
 
+
 (define list-of-tests null)
 
 (define (add-test test)
@@ -1425,12 +1426,10 @@
   ;; run whatever tests are enabled (intended for interactive use):
   (define (ggg)
     (parameterize (#;[disable-stepper-error-handling #t]
-                   #;[display-only-errors #f]
+                   #;[display-only-errors #t]
                    #;[store-steps #f]
                    #;[show-all-steps #t])
-      #;(run-tests '(check-expect check-within check-within-bad check-error) #;'(#;check-expect #;check-expect-2 check-within check-within-bad check-error))
+      #;(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-all-tests)))
   
-
-