diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-12-02 13:20:33 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-12-02 13:28:27 +0000 |
commit | 863854a3a490afd9e3ecf0da6294a3b078f4a6a1 (patch) | |
tree | 5648cd57535f0ccdd07011e24355b07b3db0cc5f | |
parent | 2a67fb3990f23391fecaec335f0d010434d2738e (diff) | |
download | haskell-863854a3a490afd9e3ecf0da6294a3b078f4a6a1.tar.gz |
Fix another bug in deriving( Data ) for data families; Trac #4896
If we have
data family D a
data instance D (a,b,c) = ... deriving( Data )
then we want to generate
instance ... => Data (D (a,b,c)) where
...
dataCast1 x = gcast1 x
The "1" here comes from the kind of D. But the kind of the
*representation* TyCon is
data Drep a b c = ....
ie Drep :: * -> * -> * -> *
So we must look for the *family* TyCon in this (rather horrible)
dataCast1 / dataCast2 binding.
-rw-r--r-- | compiler/typecheck/TcGenDeriv.lhs | 34 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_compile/T4896.hs | 19 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_compile/all.T | 2 |
3 files changed, 46 insertions, 9 deletions
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 9b5ef8bbfe..0d4374ba4d 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1323,18 +1323,19 @@ we generate \begin{code} gen_Data_binds :: DynFlags - -> SrcSpan - -> TyCon + -> SrcSpan + -> TyCon -- For data families, this is the + -- *representation* TyCon -> (LHsBinds RdrName, -- The method bindings BagDerivStuff) -- Auxiliary bindings -gen_Data_binds dflags loc tycon +gen_Data_binds dflags loc rep_tc = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] `unionBags` gcast_binds, -- Auxiliary definitions: the data type and constructors listToBag ( DerivHsBind (genDataTyCon) : map (DerivHsBind . genDataDataCon) data_cons)) where - data_cons = tyConDataCons tycon + data_cons = tyConDataCons rep_tc n_cons = length data_cons one_constr = n_cons == 1 @@ -1343,11 +1344,11 @@ gen_Data_binds dflags loc tycon = (mkHsVarBind loc rdr_name rhs, L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder)) where - rdr_name = mk_data_type_name tycon + rdr_name = mk_data_type_name rep_tc sig_ty = nlHsTyVar dataType_RDR - constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] + constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc] rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr tycon))) + `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc))) `nlHsApp` nlList constrs genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName) @@ -1418,10 +1419,25 @@ gen_Data_binds dflags loc tycon loc dataTypeOf_RDR [nlWildPat] - (nlHsVar (mk_data_type_name tycon)) + (nlHsVar (mk_data_type_name rep_tc)) ------------ gcast1/2 - tycon_kind = tyConKind tycon + -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> * + -- or dataCast2 x = gcast2 s -- if T :: * -> * -> * + -- (or nothing if T has neither of these two types) + + -- But care is needed for data families: + -- If we have data family D a + -- data instance D (a,b,c) = A | B deriving( Data ) + -- and we want instance ... => Data (D [(a,b,c)]) where ... + -- then we need dataCast1 x = gcast1 x + -- because D :: * -> * + -- even though rep_tc has kind * -> * -> * -> * + -- Hence looking for the kind of fam_tc not rep_tc + -- See Trac #4896 + tycon_kind = case tyConFamInst_maybe rep_tc of + Just (fam_tc, _) -> tyConKind fam_tc + Nothing -> tyConKind rep_tc gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR | otherwise = emptyBag diff --git a/testsuite/tests/deriving/should_compile/T4896.hs b/testsuite/tests/deriving/should_compile/T4896.hs new file mode 100644 index 0000000000..18fcc7c72b --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T4896.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeFamilies, DeriveDataTypeable, StandaloneDeriving #-} + +module T4896 where + +import Data.Data +import Data.Typeable + +--instance Typeable1 Bar where +-- typeOf1 _ = mkTyConApp (mkTyCon "Main.Bar") [] +deriving instance Typeable Bar + +class Foo a where + data Bar a + +data D a b = D Int a deriving (Typeable, Data) + +instance Foo (D a b) where + data Bar (D a b) = B { l :: a } deriving (Eq, Ord, Read, Show, Data) + diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index 3bf871db61..2234dd552e 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -51,3 +51,5 @@ test('T8963', normal, compile, ['']) test('T7269', normal, compile, ['']) test('T9069', normal, compile, ['']) test('T9359', normal, compile, ['']) +test('T4896', normal, compile, ['']) + |