added a test--> that only does a single step of the reduction relation

svn: r14014

collects/redex/main.ss

@@ -5,4 +5,3 @@
 (provide (all-from-out "reduction-semantics.ss"
                        "gui.ss" 
                        "pict.ss"))
-(provide render-language)

collects/redex/private/reduction-semantics.ss

@@ -1875,12 +1875,20 @@
 (define-syntax (test-->> stx)
   (syntax-case stx ()
     [(_ red #:cycles-ok e1 e2 ...)
-     #`(test-->>/procs red e1 (list e2 ...) #t #,(get-srcloc stx))]
+     #`(test-->>/procs red e1 (list e2 ...) apply-reduction-relation*/cycle? #t #,(get-srcloc stx))]
     [(_ red e1 e2 ...)
-     #`(test-->>/procs red e1 (list e2 ...) #f #,(get-srcloc stx))]))
+     #`(test-->>/procs red e1 (list e2 ...) apply-reduction-relation*/cycle? #f #,(get-srcloc stx))]))
 
-(define (test-->>/procs red arg expected cycles-ok? srcinfo)
+(define-syntax (test--> stx)
-  (let-values ([(got got-cycle?) (apply-reduction-relation*/cycle? red arg)])
+  (syntax-case stx ()
+    [(_ red e1 e2 ...)
+     #`(test-->>/procs red e1 (list e2 ...) apply-reduction-relation/dummy-second-value #t #,(get-srcloc stx))]))
+
+(define (apply-reduction-relation/dummy-second-value red arg)
+  (values (apply-reduction-relation red arg) #f))
+
+(define (test-->>/procs red arg expected apply-red cycles-ok? srcinfo)
+  (let-values ([(got got-cycle?) (apply-red red arg)])
     (inc-tests)
     
     (cond
@@ -1992,6 +2000,7 @@
          
          test-equal
          test-->>
+         test-->
          test-predicate
          test-results)
 

collects/redex/private/tl-test.ss

@@ -1446,4 +1446,29 @@
     (test (capture-output (test-->> red-cycle (term a)) (test-results))
           #rx"FAILED tl-test.ss:[0-9.]+\nfound a cycle in the reduction graph\n1 test failed \\(out of 1 total\\).\n"))
   
+  (let ()
+    (define-metafunction empty-language [(f any) ((any))])
+    (test (capture-output (test-equal (term (f 1)) (term ((1))))
+                          (test-results))
+          "One test passed.\n"))
+  
+  (let ()
+    (test (capture-output (test-predicate odd? 1)
+                          (test-results))
+          "One test passed.\n"))
+  
+  (let ()
+    (define red (reduction-relation empty-language (--> any (any))))
+    (test (capture-output (test--> red (term (1 2 3)) (term ((1 2 3)))) (test-results))
+          "One test passed.\n"))
+  
+  (let ()
+    (define red (reduction-relation empty-language 
+                                    (--> any (any))
+                                    (--> (any) any)))
+    (test (capture-output (test--> red (term (x)) (term ((x))) (term x)) (test-results))
+          "One test passed.\n")
+    (test (capture-output (test--> red (term (x)) (term x) (term ((x)))) (test-results))
+          "One test passed.\n"))
+
   (print-tests-passed 'tl-test.ss))

collects/redex/redex.scrbl

@@ -1005,6 +1005,13 @@ reduces to the @scheme[e2]s under @scheme[reduction-relation]
 (using @scheme[apply-reduction-relation*], so it may not terminate).
 }
 
+@defform[(test--> reduction-relation e1 e2 ...)]{
+
+Tests to see if the value of @scheme[e1] (which should be a term),
+reduces to the @scheme[e2]s in a single step, under @scheme[reduction-relation]
+(using @scheme[apply-reduction-relation]).
+}
+
 @defform[(test-predicate p? e)]{
 Tests to see if the value of @scheme[e] matches the predicate @scheme[p?].
 }

collects/redex/reduction-semantics.ss

@@ -38,6 +38,7 @@
          
          test-equal
          test-->>
+         test-->
          test-predicate
          test-results)
 

doc/release-notes/redex/HISTORY.txt

@@ -2,10 +2,13 @@ v4.1.5
 
   * renamed test--> to test-->>
 
-  * added #:cycles-ok flag to (what is now called) test-->>.
+  * added a new test--> that only tests for a single step in the
+    reduction sequence
+
+  * added #:cycles-ok flag to (what is now called) test-->>
 
   * define-metafunction and reduction-relation now work better with
-    Check Syntax, as
+    Check Syntax
     
   * added the #:arrow keyword to reduction-relation, which lets you use
     a different main arrow (mostly useful for the typesetting)