From 7243029786903cad559009fd72a2e30321f24f5b Mon Sep 17 00:00:00 2001
From: Casey Klein <clklein@racket-lang.org>
Date: Fri, 10 Dec 2010 09:50:34 -0600
Subject: [PATCH] Fixes a bug in the Redex term generator

---
 collects/redex/private/rg.rkt    | 31 ++++++++++++++++++++++++-------
 collects/redex/tests/rg-test.rkt | 21 +++++++++++++--------
 2 files changed, 37 insertions(+), 15 deletions(-)

diff --git a/collects/redex/private/rg.rkt b/collects/redex/private/rg.rkt
index 94d1812096..eb084351b9 100644
--- a/collects/redex/private/rg.rkt
+++ b/collects/redex/private/rg.rkt
@@ -354,12 +354,12 @@
                          (let ([cross? (not (symbol? pat))])
                            (λ (r s a e f)
                              (values (gen-nt (if any? sexpc langc) p cross? r s a f) e)))]
-                        [(struct binder ((or (app (symbol-match named-nt-rx) (? symbol? p)) p)))
-                         (let ([g (recur p)])
+                        [(? binder?)
+                         (let ([g (recur (binder-pattern pat))])
                            (λ (r s a e f)
                              (generate/prior pat e (λ () (g r s a e f)))))]
-                        [(struct mismatch (_ (app (symbol-match mismatch-nt-rx) p)))
-                         (let ([g (recur p)])
+                        [(? mismatch?)
+                         (let ([g (recur (mismatch-pattern pat))])
                            (set! mismatches? #t)
                            (λ (r s a e f)
                              (let-values ([(ts e) (g r s a e f)])
@@ -451,13 +451,18 @@
     (let ([nts '()])
       (let loop ([pat pat])
         (match pat
-          [(? symbol? pat)
-           (when ((is-nt? lang) (symbol->nt pat))
-             (set! nts (cons (cons #f (symbol->nt pat)) nts)))]
+          [(? binder?)
+           (set! nts (cons (cons #f (binder-pattern pat)) nts))]
+          [(? mismatch?)
+           (set! nts (cons (cons #f (mismatch-pattern pat)) nts))]
+          [(? symbol?)
+           (when ((is-nt? lang) pat)
+             (set! nts (cons (cons #f pat) nts)))]
           [`(cross ,(? symbol? x-nt))
            (set! nts (cons (cons #t x-nt) nts))]
           [`(variable-except ,s ...) (void)]
           [`(variable-prefix ,p) (void)]
+          [`(name ,_ ,p) (loop p)]
           [`() (void)]
           [(struct ellipsis (_ p _ _))
            (loop p)]
@@ -535,8 +540,20 @@
          (and match (cadr match) (string->symbol (cadr match))))))
 
 (define-struct class (id) #:inspector (make-inspector))
+
 (define-struct mismatch (id group) #:inspector (make-inspector))
+(define mismatch-pattern
+  (match-lambda
+    [(struct mismatch (_ name))
+     ((symbol-match mismatch-nt-rx) name)]))
+
 (define-struct binder (name) #:inspector (make-inspector))
+(define binder-pattern
+  (match-lambda
+    [(struct binder (name))
+     (match ((symbol-match named-nt-rx) name)
+       [#f name]
+       [p p])]))
 
 ;; name: (or/c symbol? mismatch?)
 ;;   The generator records `name' in the environment when generating an ellipsis,
diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt
index 246c9fd0f4..f1f503c59f 100644
--- a/collects/redex/tests/rg-test.rkt
+++ b/collects/redex/tests/rg-test.rkt
@@ -42,11 +42,14 @@
                 (begin (output (λ () expr)) 'no-violation))
                expected))]))
 
+(define find-base-cases/unparsed
+  (compose find-base-cases parse-language))
+
 (let ()
   (define-language lc
     (e x (e e) (λ (x) e))
     (x variable))
-  (let ([bc (find-base-cases lc)])
+  (let ([bc (find-base-cases/unparsed lc)])
     (test (to-table (base-cases-non-cross bc))
           '((e . (1 2 2)) (x . (0))))
     (test (to-table (base-cases-cross bc))
@@ -55,7 +58,7 @@
 (let ()
   (define-language lang
     (e (e e)))
-  (let ([bc (find-base-cases lang)])
+  (let ([bc (find-base-cases/unparsed lang)])
     (test (to-table (base-cases-non-cross bc)) '((e . (inf))))
     (test (to-table (base-cases-cross bc)) '((e-e . (0 inf inf))))))
 
@@ -63,7 +66,7 @@
   (define-language lang
     (a 1 2 3)
     (b a (a_1 b_!_1)))
-  (let ([bc (find-base-cases lang)])
+  (let ([bc (find-base-cases/unparsed lang)])
     (test (to-table (base-cases-non-cross bc))
           '((a . (0 0 0)) (b . (1 2))))
     (test (to-table (base-cases-cross bc))
@@ -78,7 +81,7 @@
     (v (λ (x) e)
        number)
     (x variable))
-  (let ([bc (find-base-cases lc)])
+  (let ([bc (find-base-cases/unparsed lc)])
     (test (to-table (base-cases-non-cross bc)) 
           '((e . (2 2 1 1)) (v . (2 0)) (x . (0))))
     (test (to-table (base-cases-cross bc))
@@ -88,10 +91,12 @@
 (let ()
   (define-language L
     (x (variable-prefix x)
-       (variable-except y))
+       (variable-except y)
+       (name x 1)
+       (name y 1))
     (y y))
-  (test (hash-ref (base-cases-non-cross (find-base-cases L)) 'x)
-        '(0 0)))
+  (test (hash-ref (base-cases-non-cross (find-base-cases/unparsed L)) 'x)
+        '(0 0 0 0)))
 
 (define (make-random . nums)
   (let ([nums (box nums)])
@@ -542,7 +547,7 @@
                                  (decisions #:nt (patterns first)))
         47)
   
-  (test (hash-ref (base-cases-non-cross (find-base-cases name-collision)) 'e-e)
+  (test (hash-ref (base-cases-non-cross (find-base-cases/unparsed name-collision)) 'e-e)
         '(0)))
 
 (let ()