Commit 863854a3 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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.
parent 2a67fb39
......@@ -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
......
{-# 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)
......@@ -51,3 +51,5 @@ test('T8963', normal, compile, [''])
test('T7269', normal, compile, [''])
test('T9069', normal, compile, [''])
test('T9359', normal, compile, [''])
test('T4896', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment