Fill in associated type defaults with DeriveAnyClass

Summary:
Unlike `-XDefaultSignatures`, `-XDeriveAnyClass` would not fill in
associated type family defaults when deriving a class which contained
them.

In order to fix this properly, `tcATDefault` needed to be used from
`TcGenDeriv`. To avoid a module import cycle, `tcATDefault` was moved
from `TcInstDcls` to `TcClsDcl`.

Fixes #10361.

Test Plan: ./validate

Reviewers: kosmikus, dreixel, bgamari, austin, simonpj

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1283

GHC Trac Issues: #10361

9 files changed, 291 insertions, 86 deletions

diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index bb4159a4be..2409b7b4e5 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -12,7 +12,8 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
                     findMethodBind, instantiateMethod,
                     tcClassMinimalDef,
                     HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
-                    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
+                    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,
+                    tcATDefault
                   ) where
 
 #include "HsVersions.h"
@@ -30,13 +31,21 @@ import TcType
 import TcRnMonad
 import BuildTyCl( TcMethInfo )
 import Class
+import Coercion ( pprCoAxiom )
+import DynFlags
+import FamInst
+import FamInstEnv
 import Id
 import Name
 import NameEnv
 import NameSet
 import Var
+import VarEnv
+import VarSet
 import Outputable
 import SrcLoc
+import TyCon
+import TypeRep
 import Maybes
 import BasicTypes
 import Bag
@@ -45,6 +54,7 @@ import BooleanFormula
 import Util
 
 import Control.Monad
+import Data.List ( mapAccumL )
 
 {-
 Dictionary handling
@@ -418,3 +428,64 @@ warningMinimalDefIncomplete mindef
   = vcat [ ptext (sLit "The MINIMAL pragma does not require:")
          , nest 2 (pprBooleanFormulaNice mindef)
          , ptext (sLit "but there is no default implementation.") ]
+
+tcATDefault :: Bool -- If a warning should be emitted when a default instance
+                    -- definition is not provided by the user
+            -> SrcSpan
+            -> TvSubst
+            -> NameSet
+            -> ClassATItem
+            -> TcM [FamInst]
+-- ^ Construct default instances for any associated types that
+-- aren't given a user definition
+-- Returns [] or singleton
+tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)
+  -- User supplied instances ==> everything is OK
+  | tyConName fam_tc `elemNameSet` defined_ats
+  = return []
+
+  -- No user instance, have defaults ==> instatiate them
+   -- Example:   class C a where { type F a b :: *; type F a b = () }
+   --            instance C [x]
+   -- Then we want to generate the decl:   type F [x] b = ()
+  | Just (rhs_ty, _loc) <- defs
+  = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
+                                            (tyConTyVars fam_tc)
+             rhs'     = substTy subst' rhs_ty
+             tv_set'  = tyVarsOfTypes pat_tys'
+             tvs'     = varSetElemsKvsFirst tv_set'
+       ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'
+       ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs'
+                                     fam_tc pat_tys' rhs'
+           -- NB: no validity check. We check validity of default instances
+           -- in the class definition. Because type instance arguments cannot
+           -- be type family applications and cannot be polytypes, the
+           -- validity check is redundant.
+
+       ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
+                                              , pprCoAxiom axiom ])
+       ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' )
+                     newFamInst SynFamilyInst axiom
+       ; return [fam_inst] }
+
+   -- No defaults ==> generate a warning
+  | otherwise  -- defs = Nothing
+  = do { when emit_warn $ warnMissingAT (tyConName fam_tc)
+       ; return [] }
+  where
+    subst_tv subst tc_tv
+      | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
+      = (subst, ty)
+      | otherwise
+      = (extendTvSubst subst tc_tv ty', ty')
+      where
+        ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv)
+
+warnMissingAT :: Name -> TcM ()
+warnMissingAT name
+  = do { warn <- woptM Opt_WarnMissingMethods
+       ; traceTc "warn" (ppr name <+> ppr warn)
+       ; warnTc warn  -- Warn only if -fwarn-missing-methods
+                (ptext (sLit "No explicit") <+> text "associated type"
+                    <+> ptext (sLit "or default declaration for     ")
+                    <+> quotes (ppr name)) }
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 2b1b77491e..05d689a203 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -19,7 +19,7 @@ import TcRnMonad
 import FamInst
 import TcErrors( reportAllUnsolved )
 import TcValidity( validDerivPred )
-import TcClassDcl( tcMkDeclCtxt )
+import TcClassDcl( tcATDefault, tcMkDeclCtxt )
 import TcEnv
 import TcGenDeriv                       -- Deriv stuff
 import TcGenGenerics
@@ -52,6 +52,7 @@ import NameSet
 import TyCon
 import TcType
 import Var
+import VarEnv
 import VarSet
 import PrelNames
 import THNames ( liftClassKey )
@@ -1986,6 +1987,7 @@ genInst comauxs
   | otherwise
   = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
                                         dfun_name rep_tycon
+                                        tys tvs
                                         (lookupNameEnv comauxs
                                                        (tyConName rep_tycon))
        ; inst_spec <- newDerivClsInst theta spec
@@ -2001,12 +2003,15 @@ genInst comauxs
   where
     rhs_ty = newTyConInstRhs rep_tycon rep_tc_args
 
-genDerivStuff :: SrcSpan -> Class -> Name -> TyCon
+-- Generate the bindings needed for a derived class that isn't handled by
+-- -XGeneralizedNewtypeDeriving.
+genDerivStuff :: SrcSpan -> Class -> Name -> TyCon -> [Type] -> [TyVar]
               -> Maybe CommonAuxiliary
               -> TcM (LHsBinds RdrName, BagDerivStuff)
-genDerivStuff loc clas dfun_name tycon comaux_maybe
+genDerivStuff loc clas dfun_name tycon inst_tys tyvars comaux_maybe
+  -- Special case for DeriveGeneric
   | let ck = classKey clas
-  , -- Special case because monadic
+  ,
     Just gk <- lookup ck [(genClassKey, Gen0), (gen1ClassKey, Gen1)]
   = let -- TODO NSF: correctly identify when we're building Both instead of One
         Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
@@ -2014,10 +2019,35 @@ genDerivStuff loc clas dfun_name tycon comaux_maybe
       (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name)
       return (binds, unitBag (DerivFamInst faminst))
 
-  | otherwise                      -- Non-monadic generators
+  -- Not deriving Generic(1), so we first check if the compiler has built-in
+  -- support for deriving the class in question.
+  | otherwise
   = do { dflags <- getDynFlags
        ; fix_env <- getDataConFixityFun tycon
-       ; return (genDerivedBinds dflags fix_env clas loc tycon) }
+       ; case hasBuiltinDeriving dflags fix_env clas of
+              Just gen_fn -> return (gen_fn loc tycon)
+              Nothing -> genDerivAnyClass dflags }
+
+  where
+    genDerivAnyClass :: DynFlags -> TcM (LHsBinds RdrName, BagDerivStuff)
+    genDerivAnyClass dflags =
+      do { -- If there isn't compiler support for deriving the class, our last
+           -- resort is -XDeriveAnyClass (since -XGeneralizedNewtypeDeriving
+           -- fell through).
+          let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
+              mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
+
+         ; tyfam_insts <-
+             ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
+                    , ppr "genDerivStuff: bad derived class" <+> ppr clas )
+             mapM (tcATDefault False loc mini_subst emptyNameSet)
+                  (classATItems clas)
+         ; return ( emptyBag -- No method bindings are needed...
+                  , listToBag (map DerivFamInst (concat tyfam_insts))
+                  -- ...but we may need to generate binding for associated type
+                  -- family default instances.
+                  -- See Note [DeriveAnyClass and default family instances]
+                  ) }
 
 getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
 -- If the TyCon is locally defined, we want the local fixity env;
@@ -2057,6 +2087,31 @@ representation type.
 
 See the paper "Safe zero-cost coercions for Hsakell".
 
+Note [DeriveAnyClass and default family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When a class has a associated type family with a default instance, e.g.:
+
+  class C a where
+    type T a
+    type T a = Char
+
+then there are a couple of scenarios in which a user would expect T a to
+default to Char. One is when an instance declaration for C is given without
+an implementation for T:
+
+  instance C Int
+
+Another scenario in which this can occur is when the -XDeriveAnyClass extension
+is used:
+
+  data Example = Example deriving (C, Generic)
+
+In the latter case, we must take care to check if C has any associated type
+families with default instances, because -XDeriveAnyClass will never provide
+an implementation for them. We "fill in" the default instances using the
+tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle
+the empty instance declaration case).
 
 ************************************************************************
 *                                                                      *
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index b60fc8c032..eb9c00d16b 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -18,8 +18,7 @@ This is where we do all the grimy bindings' generation.
 module TcGenDeriv (
         BagDerivStuff, DerivStuff(..),
 
-        canDeriveAnyClass,
-        genDerivedBinds,
+        hasBuiltinDeriving, canDeriveAnyClass,
         FFoldType(..), functorLikeTraverse,
         deepSubtypesContaining, foldDataConArgs,
         mkCoerceClassMethEqn,
@@ -75,7 +74,6 @@ import StaticFlags( opt_PprStyle_Debug )
 
 import ListSetOps ( assocMaybe )
 import Data.List  ( partition, intersperse )
-import Data.Maybe ( isNothing )
 
 type BagDerivStuff = Bag DerivStuff
 
@@ -101,26 +99,26 @@ data DerivStuff     -- Please add this auxiliary stuff
 {-
 ************************************************************************
 *                                                                      *
-                Top level function
+                Class deriving diagnostics
 *                                                                      *
 ************************************************************************
--}
 
-genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon
-                -> ( LHsBinds RdrName  -- The method bindings of the instance declaration
-                   , BagDerivStuff)    -- Specifies extra top-level declarations needed
-                                       -- to support the instance declaration
-genDerivedBinds dflags fix_env clas loc tycon
-  | Just gen_fn <- assocMaybe gen_list (getUnique clas)
-  = gen_fn loc tycon
+Only certain blessed classes can be used in a deriving clause. These classes
+are listed below in the definition of hasBuiltinDeriving (with the exception
+of Generic and Generic1, which are handled separately in TcGenGenerics).
 
-  | otherwise
-  -- Deriving any class simply means giving an empty instance, so no
-  -- bindings have to be generated.
-  = ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
-           , ppr "genDerivStuff: bad derived class" <+> ppr clas )
-    (emptyBag, emptyBag)
+A class might be able to be used in a deriving clause if it -XDeriveAnyClass
+is willing to support it. The canDeriveAnyClass function checks if this is
+the case.
+-}
 
+hasBuiltinDeriving :: DynFlags
+                   -> (Name -> Fixity)
+                   -> Class
+                   -> Maybe (SrcSpan
+                             -> TyCon
+                             -> (LHsBinds RdrName, BagDerivStuff))
+hasBuiltinDeriving dflags fix_env clas = assocMaybe gen_list (getUnique clas)
   where
     gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
     gen_list = [ (eqClassKey,          gen_Eq_binds)
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index d5dee95b00..c97e4e128c 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -15,7 +15,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
 import HsSyn
 import TcBinds
 import TcTyClsDecls
-import TcClassDcl( tcClassDecl2,
+import TcClassDcl( tcClassDecl2, tcATDefault,
                    HsSigFun, lookupHsSig, mkHsSigFun,
                    findMethodBind, instantiateMethod )
 import TcPat      ( TcIdSigInfo, addInlinePrags, completeIdSigPolyId, lookupPragEnv, emptyPragEnv )
@@ -32,7 +32,6 @@ import TcDeriv
 import TcEnv
 import TcHsType
 import TcUnify
-import Coercion   ( pprCoAxiom {- , isReflCo, mkSymCo, mkSubCo -} )
 import MkCore     ( nO_METHOD_BINDING_ERROR_ID )
 import Type
 import TcEvidence
@@ -62,7 +61,7 @@ import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
 
 import Control.Monad
 import Maybes
-import Data.List  ( mapAccumL, partition )
+import Data.List  ( partition )
 
 {-
 Typechecking instance declarations is done in two passes. The first
@@ -537,7 +536,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
         ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
                             `unionNameSet`
                             mkNameSet (map (unLoc . dfid_tycon . unLoc) adts)
-        ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats)
+        ; tyfam_insts1 <- mapM (tcATDefault True loc mini_subst defined_ats)
                                (classATItems clas)
 
         -- Finally, construct the Core representation of the instance.
@@ -559,51 +558,6 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
                  , deriv_infos ) }
 
 
-tcATDefault :: SrcSpan -> TvSubst -> NameSet -> ClassATItem -> TcM [FamInst]
--- ^ Construct default instances for any associated types that
--- aren't given a user definition
--- Returns [] or singleton
-tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
-  -- User supplied instances ==> everything is OK
-  | tyConName fam_tc `elemNameSet` defined_ats
-  = return []
-
-  -- No user instance, have defaults ==> instatiate them
-   -- Example:   class C a where { type F a b :: *; type F a b = () }
-   --            instance C [x]
-   -- Then we want to generate the decl:   type F [x] b = ()
-  | Just (rhs_ty, _loc) <- defs
-  = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
-                                            (tyConTyVars fam_tc)
-             rhs'     = substTy subst' rhs_ty
-             tv_set'  = tyVarsOfTypes pat_tys'
-             tvs'     = varSetElemsKvsFirst tv_set'
-       ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'
-       ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' fam_tc pat_tys' rhs'
-           -- NB: no validity check. We check validity of default instances
-           -- in the class definition. Because type instance arguments cannot
-           -- be type family applications and cannot be polytypes, the
-           -- validity check is redundant.
-
-       ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
-                                              , pprCoAxiom axiom ])
-       ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' )
-                     newFamInst SynFamilyInst axiom
-       ; return [fam_inst] }
-
-   -- No defaults ==> generate a warning
-  | otherwise  -- defs = Nothing
-  = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc)
-       ; return [] }
-  where
-    subst_tv subst tc_tv
-      | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
-      = (subst, ty)
-      | otherwise
-      = (extendTvSubst subst tc_tv ty', ty')
-      where
-        ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv)
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1576,16 +1530,6 @@ derivBindCtxt sel_id clas tys
                     <+> quotes (pprClassPred clas tys) <> colon)
           , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
 
-warnMissingMethodOrAT :: String -> Name -> TcM ()
-warnMissingMethodOrAT what name
-  = do { warn <- woptM Opt_WarnMissingMethods
-       ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name))))
-       ; warnTc (warn  -- Warn only if -fwarn-missing-methods
-                 && not (startsWithUnderscore (getOccName name)))
-                                        -- Don't warn about _foo methods
-                (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for")
-                 <+> quotes (ppr name)) }
-
 warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
 warnUnsatisfiedMinimalDefinition mindef
   = do { warn <- woptM Opt_WarnMissingMethods
diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst
index dc87c59c9e..0e1d0a2563 100644
--- a/docs/users_guide/7.12.1-notes.rst
+++ b/docs/users_guide/7.12.1-notes.rst
@@ -78,6 +78,9 @@ Language
    arguments with certain unlifted types. See :ref:`generic-programming` for
    more details.
 
+-  The ``-XDeriveAnyClass`` extension now fills in associated type family
+   default instances when deriving a class that contains them.
+
 Compiler
 ~~~~~~~~
 
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index bc9e0233f3..59bbd2e16e 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -4118,11 +4118,53 @@ With ``-XDeriveAnyClass`` you can derive any other class. The compiler
 will simply generate an empty instance. The instance context will be
 generated according to the same rules used when deriving ``Eq``. This is
 mostly useful in classes whose `minimal set <#minimal-pragma>`__ is
-empty, and especially when writing `generic
-functions <#generic-programming>`__. In case you try to derive some
+empty, and especially when writing
+`generic functions <#generic-programming>`__. In case you try to derive some
 class on a newtype, and ``-XGeneralizedNewtypeDeriving`` is also on,
 ``-XDeriveAnyClass`` takes precedence.
 
+As an example, consider a simple pretty-printer class ``SPretty``, which outputs
+pretty strings: ::
+
+    {-# LANGUAGE DefaultSignatures, DeriveAnyClass #-}
+
+    class SPretty a where
+      sPpr :: a -> String
+      default sPpr :: Show a => a -> String
+      sPpr = show
+
+If a user does not provide a manual implementation for ``sPpr``, then it will
+default to ``show``. Now we can leverage the ``-XDeriveAnyClass`` extension to
+easily implement a ``SPretty`` instance for a new data type: ::
+
+    data Foo = Foo deriving (Show, SPretty)
+
+The above code is equivalent to: ::
+
+    data Foo = Foo deriving Show
+    instance SPretty Foo
+
+That is, an ``SPretty Foo`` instance will be created with empty implementations
+for all methods. Since we are using ``-XDefaultSignatures`` in this example, a
+default implementation of ``sPpr`` is filled in automatically.
+
+Similarly, ``-XDeriveAnyClass`` can be used to fill in default instances for
+associated type families: ::
+
+    {-# LANGUAGE DeriveAnyClass, TypeFamilies #-}
+
+    class Sizable a where
+      type Size a
+      type Size a = Int
+
+    data Bar = Bar deriving Sizable
+
+    doubleBarSize :: Size Bar -> Size Bar
+    doubleBarSize s = 2*s
+
+Since ``-XDeriveAnyClass`` does not generate an instance definition for ``Size
+Bar``, it will default to ``Int``.
+
 .. _type-class-extensions:
 
 Class and instances declarations
diff --git a/testsuite/tests/generics/T10361a.hs b/testsuite/tests/generics/T10361a.hs
new file mode 100644
index 0000000000..cc5fbb9dca
--- /dev/null
+++ b/testsuite/tests/generics/T10361a.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+module T10361a where
+
+class C1 a where
+  type T1 a
+  type instance T1 a = Char
+
+class C2 a where -- equivalent to C1
+  type T2 a
+  type instance T2 a = Char
+
+class C3 a where -- equivalent to C1, C2
+  type T3 a
+  type instance T3 a = Char
+
+data A = B
+  deriving C1
+
+deriving instance C2 A
+
+instance C3 A
+
+test1 :: T1 A
+test1 = 'x'
+
+test2 :: T2 A
+test2 = 'x'
+
+test3 :: T3 A
+test3 = 'x'
diff --git a/testsuite/tests/generics/T10361b.hs b/testsuite/tests/generics/T10361b.hs
new file mode 100644
index 0000000000..6ecd99e644
--- /dev/null
+++ b/testsuite/tests/generics/T10361b.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module T10361b where
+
+import GHC.Generics
+
+---------------------------------------------------------------------
+class Convert a where
+    type Result a
+    type instance Result a = GResult (Rep a)
+
+    convert :: a -> Result a
+    default convert :: (Generic a, GConvert (Rep a)) => a -> GResult (Rep a)
+    convert x = gconvert (from x)
+
+instance Convert Float where
+    type Result Float = Float
+    convert = id
+
+instance Convert Int where
+    type Result Int = Int
+    convert = id
+
+---------------------------------------------------------------------
+class GConvert f where
+    type GResult f
+    gconvert :: f p -> GResult f
+
+instance (Convert c) => GConvert (K1 i c) where
+    type GResult (K1 i c) = Result c
+    gconvert (K1 x) = convert x
+
+instance (GConvert f) => GConvert (M1 i t f) where
+    type GResult (M1 i t f) = GResult f
+    gconvert (M1 x) = gconvert x
+
+instance (GConvert f, GConvert g) => GConvert (f :*: g) where
+    type GResult (f :*: g) = (GResult f, GResult g)
+    gconvert (x :*: y) = (gconvert x, gconvert y)
+
+---------------------------------------------------------------------
+
+data Data1 = Data1 Int Float
+    deriving (Generic)
+
+instance Convert Data1
+
+val :: (Int, Float)
+val = convert $ Data1 0 0.0
+
+data Data2 = Data2 Int Float
+    deriving (Generic, Convert)
diff --git a/testsuite/tests/generics/all.T b/testsuite/tests/generics/all.T
index 31a6809c82..cbf70cf8bf 100644
--- a/testsuite/tests/generics/all.T
+++ b/testsuite/tests/generics/all.T
@@ -40,3 +40,5 @@ test('T8468', normal, compile_fail, [''])
 test('T8479', normal, compile, [''])
 test('T9563', normal, compile, [''])
 test('T10030', normal, compile_and_run, [''])
+test('T10361a', normal, compile, [''])
+test('T10361b', normal, compile, [''])