[commit: ghc] ghc-7.8: Fix #8884. (a78d602)

git at git.haskell.org git at git.haskell.org
Mon Mar 17 15:36:43 UTC 2014


Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.8
Link       : http://ghc.haskell.org/trac/ghc/changeset/a78d60201e126f2533752041538a67385b2a081d/ghc

>---------------------------------------------------------------

commit a78d60201e126f2533752041538a67385b2a081d
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Thu Mar 13 15:48:56 2014 -0400

    Fix #8884.
    
    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.
    
    (cherry picked from commit 8c5ea91d68cdc79b413e05f7dacfd052f5de8c64)
    
    Conflicts:
    	testsuite/tests/th/all.T


>---------------------------------------------------------------

a78d60201e126f2533752041538a67385b2a081d
 compiler/typecheck/TcSplice.lhs         |   19 +++++++++++++------
 testsuite/tests/th/T7477.stderr         |    2 +-
 testsuite/tests/th/T8884.hs             |   21 +++++++++++++++++++++
 testsuite/tests/th/T8884.stderr         |    3 +++
 testsuite/tests/th/TH_reifyDecl1.stderr |   12 ++++++------
 testsuite/tests/th/all.T                |    1 +
 6 files changed, 45 insertions(+), 13 deletions(-)

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 0a47da1..4dbf2d3 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -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)) }
 
diff --git a/testsuite/tests/th/T7477.stderr b/testsuite/tests/th/T7477.stderr
index f6a9e0d..f94de68 100644
--- a/testsuite/tests/th/T7477.stderr
+++ b/testsuite/tests/th/T7477.stderr
@@ -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
index 0000000..782bf90
--- /dev/null
+++ b/testsuite/tests/th/T8884.hs
@@ -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
index 0000000..3c45d0e
--- /dev/null
+++ b/testsuite/tests/th/T8884.stderr
@@ -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
diff --git a/testsuite/tests/th/TH_reifyDecl1.stderr b/testsuite/tests/th/TH_reifyDecl1.stderr
index 82a4f57..9c3b6da 100644
--- a/testsuite/tests/th/TH_reifyDecl1.stderr
+++ b/testsuite/tests/th/TH_reifyDecl1.stderr
@@ -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
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 3e88970..c39fc6d 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -319,3 +319,4 @@ test('T8633', normal, compile_and_run, [''])
 test('T8625', normal, ghci_script, ['T8625.script'])
 test('T8759', normal, compile_fail, ['-v0'])
 test('T8759a', normal, compile_fail, ['-v0'])
+test('T8884', normal, compile, ['-v0'])



More information about the ghc-commits mailing list