Updates to support closed type families.

13 files changed, 54 insertions, 73 deletions

diff --git a/testsuite/tests/th/ClosedFam1.hs b/testsuite/tests/th/ClosedFam1.hs
new file mode 100644
index 0000000000..262e9a1e48
--- /dev/null
+++ b/testsuite/tests/th/ClosedFam1.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell, TypeFamilies, PolyKinds, DataKinds #-}
+
+module ClosedFam1 where
+
+import Language.Haskell.TH
+
+$(do { decl <- [d| type family Foo a (b :: k) where
+                     Foo Int Bool = Int
+                     Foo a Maybe = Bool
+                     Foo b (x :: Bool) = Char |]
+     ; reportWarning (pprint decl)
+     ; return [] })
+
diff --git a/testsuite/tests/th/ClosedFam1.stderr b/testsuite/tests/th/ClosedFam1.stderr
new file mode 100644
index 0000000000..d9827d8afb
--- /dev/null
+++ b/testsuite/tests/th/ClosedFam1.stderr
@@ -0,0 +1,6 @@
+
+ClosedFam1.hs:7:3: Warning:
+    type family Foo_0 a_1 (b_2 :: k_3) where
+    Foo_0 GHC.Types.Int GHC.Types.Bool = GHC.Types.Int
+    Foo_0 a_4 Data.Maybe.Maybe = GHC.Types.Bool
+    Foo_0 b_5 (x_6 :: GHC.Types.Bool) = GHC.Types.Char
diff --git a/testsuite/tests/th/ClosedFam2.hs b/testsuite/tests/th/ClosedFam2.hs
new file mode 100644
index 0000000000..cd2dc2de60
--- /dev/null
+++ b/testsuite/tests/th/ClosedFam2.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE TemplateHaskell, TypeFamilies, PolyKinds #-}
+
+module ClosedFam2 where
+
+import Language.Haskell.TH
+
+$( return [ ClosedTypeFamilyD (mkName "Equals")
+                              [ KindedTV (mkName "a") (VarT (mkName "k"))
+                              , KindedTV (mkName "b") (VarT (mkName "k")) ]
+                              Nothing
+                              [ TySynEqn [ (VarT (mkName "a"))
+                                         , (VarT (mkName "a")) ]
+                                         (ConT (mkName "Int"))
+                              , TySynEqn [ (VarT (mkName "a"))
+                                         , (VarT (mkName "b")) ]
+                                         (ConT (mkName "Bool")) ] ])
+
+a :: Equals b b
+a = (5 :: Int)
+
+b :: Equals Int Bool
+b = False
diff --git a/testsuite/tests/th/T5886a.hs b/testsuite/tests/th/T5886a.hs
index 74db6fa192..4d2cec6207 100644
--- a/testsuite/tests/th/T5886a.hs
+++ b/testsuite/tests/th/T5886a.hs
@@ -11,4 +11,4 @@ class C α where
 
 bang ∷ DecsQ
 bang = return [InstanceD [] (AppT (ConT ''C) (ConT ''Int))
-                [TySynInstD ''AT [TySynEqn [ConT ''Int] (ConT ''Int)]]]
+                [TySynInstD ''AT (TySynEqn [ConT ''Int] (ConT ''Int))]]
diff --git a/testsuite/tests/th/TH_TyInstWhere1.hs b/testsuite/tests/th/TH_TyInstWhere1.hs
index 8352d4bf01..d8c07d7642 100644
--- a/testsuite/tests/th/TH_TyInstWhere1.hs
+++ b/testsuite/tests/th/TH_TyInstWhere1.hs
@@ -2,9 +2,7 @@
 
 module TH_TyInstWhere1 where
 
-type family F (a :: k) (b :: k) :: Bool
-
-$([d| type instance where
+$([d| type family F (a :: k) (b :: k) :: Bool where
         F a a = True
         F a b = False |])
 
diff --git a/testsuite/tests/th/TH_TyInstWhere1.stderr b/testsuite/tests/th/TH_TyInstWhere1.stderr
index 480e5bf4f7..5a830aa792 100644
--- a/testsuite/tests/th/TH_TyInstWhere1.stderr
+++ b/testsuite/tests/th/TH_TyInstWhere1.stderr
@@ -1,9 +1,9 @@
 TH_TyInstWhere1.hs:1:1: Splicing declarations
-    [d| type instance where
+    [d| type family F (a :: k) (b :: k) :: Bool where
           F a a = True
           F a b = False |]
   ======>
-    TH_TyInstWhere1.hs:(7,3)-(9,24)
-    type instance where
+    TH_TyInstWhere1.hs:(5,3)-(7,24)
+    type family F (a :: k) (b :: k) :: Bool where
       F a a = True
       F a b = False
diff --git a/testsuite/tests/th/TH_TyInstWhere2.hs b/testsuite/tests/th/TH_TyInstWhere2.hs
index ec27ced780..47fedad8da 100644
--- a/testsuite/tests/th/TH_TyInstWhere2.hs
+++ b/testsuite/tests/th/TH_TyInstWhere2.hs
@@ -4,9 +4,7 @@ module TH_TyInstWhere2 where
 
 import Language.Haskell.TH
 
-type family F (a :: k) (b :: k) :: Bool
-
-$( do { decs <- [d| type instance where
+$( do { decs <- [d| type family F (a :: k) (b :: k) :: Bool where
                       F a a = True
                       F a b = False |]
       ; reportWarning (pprint decs)
diff --git a/testsuite/tests/th/TH_TyInstWhere2.stderr b/testsuite/tests/th/TH_TyInstWhere2.stderr
index 4ed490e8ea..17caf61bad 100644
--- a/testsuite/tests/th/TH_TyInstWhere2.stderr
+++ b/testsuite/tests/th/TH_TyInstWhere2.stderr
@@ -1,5 +1,5 @@
 
-TH_TyInstWhere2.hs:9:4: Warning:
-    type instance where
-    TH_TyInstWhere2.F a_0 a_0 = 'GHC.Types.True
-    TH_TyInstWhere2.F a_1 b_2 = 'GHC.Types.False
+TH_TyInstWhere2.hs:7:4: Warning:
+    type family F_0 (a_1 :: k_2) (b_3 :: k_2) :: GHC.Types.Bool where
+    F_0 a_4 a_4 = 'GHC.Types.True
+    F_0 a_5 b_6 = 'GHC.Types.False
diff --git a/testsuite/tests/th/TH_TyInstWhere3.hs b/testsuite/tests/th/TH_TyInstWhere3.hs
deleted file mode 100644
index 54d76f5226..0000000000
--- a/testsuite/tests/th/TH_TyInstWhere3.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# LANGUAGE PolyKinds, DataKinds, TemplateHaskell, TypeFamilies #-}
-
-module TH_TyInstWhere3 where
-
-import Language.Haskell.TH
-
-type family F a
-
-$( do { decs <- [d| type instance where
-                      F Int = Int |]
-      ; reportWarning (pprint decs)
-      ; return decs })
-
-type instance F a = a 
-
--- When this test was written, TH considered all singleton type family instance
--- as unbranched. Thus, even though the two instances above would not play nicely
--- without TH, they should be fine with TH.
diff --git a/testsuite/tests/th/TH_TyInstWhere3.stderr b/testsuite/tests/th/TH_TyInstWhere3.stderr
deleted file mode 100644
index eaebfec89f..0000000000
--- a/testsuite/tests/th/TH_TyInstWhere3.stderr
+++ /dev/null
@@ -1,3 +0,0 @@
-
-TH_TyInstWhere3.hs:9:4: Warning:
-    type instance TH_TyInstWhere3.F GHC.Types.Int = GHC.Types.Int
diff --git a/testsuite/tests/th/TH_TyInstWhere4.hs b/testsuite/tests/th/TH_TyInstWhere4.hs
deleted file mode 100644
index 86415ffd5d..0000000000
--- a/testsuite/tests/th/TH_TyInstWhere4.hs
+++ /dev/null
@@ -1,20 +0,0 @@
-{-# LANGUAGE PolyKinds, DataKinds, TemplateHaskell, TypeFamilies #-}
-
-module TH_TyInstWhere4 where
-
-import Language.Haskell.TH
-
-type family F a b :: Bool
-type instance where
-  F a a = True
-  F a b = False
-
-$( do { info1 <- reify ''F
-      ; reportWarning (pprint info1)
-      ; info2 <- reifyInstances ''F [ConT ''Int, ConT ''Int]
-      ; reportWarning (pprint info2)
-      ; info3 <- reifyInstances ''F [ConT ''Int, ConT ''Bool]
-      ; reportWarning (pprint info3)
-      ; return [] })
-
-
diff --git a/testsuite/tests/th/TH_TyInstWhere4.stderr b/testsuite/tests/th/TH_TyInstWhere4.stderr
deleted file mode 100644
index 70dfe85b7a..0000000000
--- a/testsuite/tests/th/TH_TyInstWhere4.stderr
+++ /dev/null
@@ -1,16 +0,0 @@
-
-TH_TyInstWhere4.hs:12:4: Warning:
-    type family TH_TyInstWhere4.F a_0 b_1 :: * -> * -> GHC.Types.Bool
-type instance where
-    TH_TyInstWhere4.F a_2 a_2 = GHC.Types.True
-    TH_TyInstWhere4.F a_3 b_4 = GHC.Types.False
-
-TH_TyInstWhere4.hs:12:4: Warning:
-    type instance where
-    TH_TyInstWhere4.F a_0 a_0 = GHC.Types.True
-    TH_TyInstWhere4.F a_1 b_2 = GHC.Types.False
-
-TH_TyInstWhere4.hs:12:4: Warning:
-    type instance where
-    TH_TyInstWhere4.F a_0 a_0 = GHC.Types.True
-    TH_TyInstWhere4.F a_1 b_2 = GHC.Types.False
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index ad1c4e9782..c6407c462e 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -261,8 +261,6 @@ test('T7276a', combined_output, ghci_script, ['T7276a.script'])
 
 test('TH_TyInstWhere1', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('TH_TyInstWhere2', normal, compile, ['-v0'])
-test('TH_TyInstWhere3', normal, compile, ['-v0'])
-test('TH_TyInstWhere4', normal, compile, ['-v0'])
 
 test('T7445', extra_clean(['T7445a.hi', 'T7445a.o']),
 	      run_command,
@@ -275,3 +273,6 @@ test('T2222', normal, compile, ['-v0'])
 test('T1849', normal, ghci_script, ['T1849.script'])
 test('T7681', normal, compile, ['-v0'])
 test('T7910', normal, compile_and_run, ['-v0'])
+
+test('ClosedFam1', normal, compile, ['-dsuppress-uniques -v0'])
+test('ClosedFam2', normal, compile, ['-v0'])
\ No newline at end of file