From 5790667054568994d61c366b394be7deba28ce9a Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Thu, 28 Feb 2013 00:09:56 -0500
Subject: [PATCH] Remove duplicate non-terminals in `define-extended-language`

Fixes a problem with `define-union-language`
---
 .../redex/private/reduction-semantics.rkt     | 11 ++++-
 collects/redex/tests/tl-test.rkt              | 49 +++++++++++++++++++
 2 files changed, 59 insertions(+), 1 deletion(-)

diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt
index 88a8ff9041..6db2080c51 100644
--- a/collects/redex/private/reduction-semantics.rkt
+++ b/collects/redex/private/reduction-semantics.rkt
@@ -1758,7 +1758,16 @@
        (let ([old-names (language-id-nts #'orig-lang 'define-extended-language)]
              [non-terms (parse-non-terminals #'nt-defs stx)])
          (with-syntax ([((names prods ...) ...) non-terms]
-                       [(all-names ...) (apply append old-names (map car non-terms))]
+                       [(all-names ...)
+                        ;; The names may have duplicates if the extended language
+                        ;; extends non-terminals in the parent language. They need
+                        ;; to be removed for `define-union-language`
+                        (remove-duplicates
+                         (apply append old-names (map car non-terms))
+                         (λ (n1 n2)
+                           (let ([n1 (if (syntax? n1) (syntax-e n1) n1)]
+                                 [n2 (if (syntax? n2) (syntax-e n2) n2)])
+                             (eq? n1 n2))))]
                        [(define-language-name) (generate-temporaries #'(name))])
            #'(begin
                (define define-language-name (extend-language orig-lang (all-names ...) (names prods ...) ...))
diff --git a/collects/redex/tests/tl-test.rkt b/collects/redex/tests/tl-test.rkt
index 95409d4c6f..5ee0fe30c9 100644
--- a/collects/redex/tests/tl-test.rkt
+++ b/collects/redex/tests/tl-test.rkt
@@ -424,6 +424,55 @@
     (test (and (redex-match L -b 100) #t) #t)
     (test (redex-match L -b 3) #f))
 
+  ;; The following two tests make sure that `define-union-language`
+  ;; works with extended languages
+  (let ()
+    (define-language LBase
+      (e (+ e e)
+         number))
+
+    (define-extended-language L1 LBase
+      (e ....
+         (- e e)))
+
+    (define-extended-language L2 LBase
+      (e ....
+         (* e e)))
+
+    (define-union-language LMerge (one. L1) (two. L2))
+
+    #|
+    The error that used to be raised:
+    define-union-language: two sublanguages both contribute the non-terminal: one.e in:
+      (one. L1)
+      (one. L1)
+    |#
+
+    (test (and (redex-match LMerge one.e (term (- 0 0))) #t) #t)
+    (test (and (redex-match LMerge two.e (term (* 0 0))) #t) #t))
+
+  (let ()
+    (define-language UT
+      (e (e e)
+         (λ (x) e)
+         x))
+
+    (define-language WT
+      (e (e e)
+         (λ (x t) e)
+         x)
+      (t (→ t t)
+         num))
+
+    (define-extended-language UT+ UT
+      (e ....
+         (foo e e)))
+
+    (define-union-language B (ut. UT+) (wt. WT))
+
+    (test (and (redex-match B ut.e (term (foo x x))) #t) #t)
+    (test (redex-match B wt.e (term (foo x x))) #f))
+
   (let ()
     (test (redex-match empty-language number 'a) #f)
     (test (redex-match empty-language (in-hole hole number) 'a) #f))