Fix #8884.
authorRichard Eisenberg <eir@cis.upenn.edu>
Thu, 13 Mar 2014 19:48:56 +0000 (15:48 -0400)
committerRichard Eisenberg <eir@cis.upenn.edu>
Fri, 14 Mar 2014 03:34:56 +0000 (23:34 -0400)
There were two unrelated errors fixed here:
 1) Make sure that only the *result kind* is reified when reifying
    a type family. Previously, the whole kind was reified, which
    defies the TH spec.

 2) Omit kind patterns in equations.

compiler/typecheck/TcSplice.lhs
testsuite/tests/th/T7477.stderr
testsuite/tests/th/T8884.hs [new file with mode: 0644]
testsuite/tests/th/T8884.stderr [new file with mode: 0644]
testsuite/tests/th/TH_reifyDecl1.stderr
testsuite/tests/th/all.T

index 9129ed8..2f4687d 100644 (file)
@@ -1194,7 +1194,8 @@ reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
 -------------------------------------------
 reifyAxBranch :: CoAxBranch -> TcM TH.TySynEqn
 reifyAxBranch (CoAxBranch { cab_lhs = args, cab_rhs = rhs })
-  = do { args' <- mapM reifyType args
+            -- remove kind patterns (#8884)
+  = do { args' <- mapM reifyType (filter (not . isKind) args)
        ; rhs'  <- reifyType rhs
        ; return (TH.TySynEqn args' rhs') }
 
@@ -1210,10 +1211,15 @@ reifyTyCon tc
   = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
 
   | isFamilyTyCon tc
-  = do { let tvs     = tyConTyVars tc
-             kind    = tyConKind tc
-       ; kind' <- if isLiftedTypeKind kind then return Nothing
-                  else fmap Just (reifyKind kind)
+  = do { let tvs      = tyConTyVars tc
+             kind     = tyConKind tc
+
+             -- we need the *result kind* (see #8884)
+             (kvs, mono_kind) = splitForAllTys kind
+                                -- tyConArity includes *kind* params
+             (_, res_kind)    = splitKindFunTysN (tyConArity tc - length kvs)
+                                                 mono_kind
+       ; kind' <- fmap Just (reifyKind res_kind)
 
        ; tvs' <- reifyTyVars tvs
        ; flav' <- reifyFamFlavour tc
@@ -1315,7 +1321,8 @@ reifyFamilyInstance (FamInst { fi_flavor = flavor
                              , fi_rhs = rhs })
   = case flavor of
       SynFamilyInst ->
-        do { th_lhs <- reifyTypes lhs
+               -- remove kind patterns (#8884)
+        do { th_lhs <- reifyTypes (filter (not . isKind) lhs)
            ; th_rhs <- reifyType  rhs
            ; return (TH.TySynInstD (reifyName fam) (TH.TySynEqn th_lhs th_rhs)) }
 
index f6a9e0d..f94de68 100644 (file)
@@ -1,3 +1,3 @@
 
 T7477.hs:10:4: Warning:
-    type instance T7477.F GHC.Prim.* GHC.Types.Int = GHC.Types.Bool
+    type instance T7477.F GHC.Types.Int = GHC.Types.Bool
diff --git a/testsuite/tests/th/T8884.hs b/testsuite/tests/th/T8884.hs
new file mode 100644 (file)
index 0000000..782bf90
--- /dev/null
@@ -0,0 +1,21 @@
+{-# LANGUAGE TemplateHaskell, TypeFamilies, PolyKinds #-}
+
+module T8884 where
+
+import Language.Haskell.TH
+
+type family Foo a where
+  Foo x = x
+
+type family Baz (a :: k)
+type instance Baz x = x
+
+$( do FamilyI foo@(ClosedTypeFamilyD _ tvbs1 m_kind1 eqns1) [] <- reify ''Foo
+      FamilyI baz@(FamilyD TypeFam _ tvbs2 m_kind2)
+              [inst@(TySynInstD _ eqn2)] <- reify ''Baz
+      runIO $ putStrLn $ pprint foo
+      runIO $ putStrLn $ pprint baz
+      runIO $ putStrLn $ pprint inst
+      return [ ClosedTypeFamilyD (mkName "Foo'") tvbs1 m_kind1 eqns1
+             , FamilyD TypeFam (mkName "Baz'") tvbs2 m_kind2
+             , TySynInstD (mkName "Baz'") eqn2 ] )
\ No newline at end of file
diff --git a/testsuite/tests/th/T8884.stderr b/testsuite/tests/th/T8884.stderr
new file mode 100644 (file)
index 0000000..3c45d0e
--- /dev/null
@@ -0,0 +1,3 @@
+type family T8884.Foo (a_0 :: k_1) :: k_1 where T8884.Foo x_2 = x_2
+type family T8884.Baz (a_0 :: k_1) :: *
+type instance T8884.Baz x_0 = x_0
index 82a4f57..9c3b6da 100644 (file)
@@ -21,15 +21,15 @@ class TH_reifyDecl1.C2 a_0
 instance TH_reifyDecl1.C2 GHC.Types.Int
 class TH_reifyDecl1.C3 a_0
 instance TH_reifyDecl1.C3 GHC.Types.Int
-type family TH_reifyDecl1.AT1 a_0 :: * -> *
+type family TH_reifyDecl1.AT1 a_0 :: *
 type instance TH_reifyDecl1.AT1 GHC.Types.Int = GHC.Types.Bool
-data family TH_reifyDecl1.AT2 a_0 :: * -> *
+data family TH_reifyDecl1.AT2 a_0 :: *
 data instance TH_reifyDecl1.AT2 GHC.Types.Int
     = TH_reifyDecl1.AT2Int
-type family TH_reifyDecl1.TF1 a_0 :: * -> *
-type family TH_reifyDecl1.TF2 a_0 :: * -> *
+type family TH_reifyDecl1.TF1 a_0 :: *
+type family TH_reifyDecl1.TF2 a_0 :: *
 type instance TH_reifyDecl1.TF2 GHC.Types.Bool = GHC.Types.Bool
-data family TH_reifyDecl1.DF1 a_0 :: * -> *
-data family TH_reifyDecl1.DF2 a_0 :: * -> *
+data family TH_reifyDecl1.DF1 a_0 :: *
+data family TH_reifyDecl1.DF2 a_0 :: *
 data instance TH_reifyDecl1.DF2 GHC.Types.Bool
     = TH_reifyDecl1.DBool
index e7db161..60203ca 100644 (file)
@@ -322,3 +322,4 @@ test('T8759a', normal, compile_fail, ['-v0'])
 test('T7021',
      extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile, ['T7021','-v0'])
 test('T8807', normal, compile, ['-v0'])
+test('T8884', normal, compile, ['-v0'])
\ No newline at end of file