diff --git a/collects/redex/main.ss b/collects/redex/main.ss index c097d94864..9bfc2679f5 100644 --- a/collects/redex/main.ss +++ b/collects/redex/main.ss @@ -5,4 +5,3 @@ (provide (all-from-out "reduction-semantics.ss" "gui.ss" "pict.ss")) -(provide render-language) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 2c75bb15a0..c2519babc3 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/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) - (let-values ([(got got-cycle?) (apply-reduction-relation*/cycle? red arg)]) +(define-syntax (test--> stx) + (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) diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index d2fa533423..a35495e14a 100644 --- a/collects/redex/private/tl-test.ss +++ b/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)) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index e8282f578c..31a094e0c6 100644 --- a/collects/redex/redex.scrbl +++ b/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?]. } diff --git a/collects/redex/reduction-semantics.ss b/collects/redex/reduction-semantics.ss index 988e7deea2..1cad442633 100644 --- a/collects/redex/reduction-semantics.ss +++ b/collects/redex/reduction-semantics.ss @@ -38,6 +38,7 @@ test-equal test-->> + test--> test-predicate test-results) diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index 41ca61834e..3449b25978 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/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)