[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