[commit: ghc] master: Fix another bug in deriving( Data ) for data families; Trac #4896 (863854a)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/863854a3a490afd9e3ecf0da6294a3b078f4a6a1/ghc

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

commit 863854a3a490afd9e3ecf0da6294a3b078f4a6a1
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Dec 2 13:20:33 2014 +0000

    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.


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

863854a3a490afd9e3ecf0da6294a3b078f4a6a1
 compiler/typecheck/TcGenDeriv.lhs                | 34 +++++++++++++++++-------
 testsuite/tests/deriving/should_compile/T4896.hs | 19 +++++++++++++
 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 9b5ef8b..0d4374b 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 0000000..18fcc7c
--- /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 3bf871d..2234dd5 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, [''])
+