Make unique auxiliary function names in deriving

In deriving for Data, we make some auxiliary functions, but they
didn't always get distinct names (Trac #12245).  This patch fixes
it by using the same mechanism as for dictionary functions, namely
chooseUniqueOccTc.

Some assocated refactoring came along for the ride.

6 files changed, 168 insertions, 143 deletions

diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index 19a9b3babb..6a5c489d9f 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -583,7 +583,7 @@ mkDataConWrapperOcc, mkWorkerOcc,
         mkClassDataConOcc, mkDictOcc,
         mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc,
         mkGenR, mkGen1R,
-        mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
+        mkDataConWorkerOcc, mkNewTyCoOcc,
         mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
         mkTyConRepOcc
@@ -621,12 +621,6 @@ mkTyConRepOcc occ = mk_simple_deriv varName prefix occ
 mkGenR   = mk_simple_deriv tcName "Rep_"
 mkGen1R  = mk_simple_deriv tcName "Rep1_"
 
--- data T = MkT ... deriving( Data ) needs definitions for
---      $tT   :: Data.Generics.Basics.DataType
---      $cMkT :: Data.Generics.Basics.Constr
-mkDataTOcc = mk_simple_deriv varName  "$t"
-mkDataCOcc = mk_simple_deriv varName  "$c"
-
 -- Vectorisation
 mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
  mkPADFunOcc,      mkPReprTyConOcc,
@@ -683,8 +677,7 @@ mkLocalOcc uniq occ
 mkInstTyTcOcc :: String                 -- ^ Family name, e.g. @Map@
               -> OccSet                 -- ^ avoid these Occs
               -> OccName                -- ^ @R:Map@
-mkInstTyTcOcc str set =
-  chooseUniqueOcc tcName ('R' : ':' : str) set
+mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str)
 
 mkDFunOcc :: String             -- ^ Typically the class and type glommed together e.g. @OrdMaybe@.
                                 -- Only used in debug mode, for extra clarity
@@ -702,6 +695,16 @@ mkDFunOcc info_str is_boot set
     prefix | is_boot   = "$fx"
            | otherwise = "$f"
 
+mkDataTOcc, mkDataCOcc
+  :: OccName            -- ^ TyCon or data con string
+  -> OccSet             -- ^ avoid these Occs
+  -> OccName            -- ^ E.g. @$f3OrdMaybe@
+-- data T = MkT ... deriving( Data ) needs definitions for
+--      $tT   :: Data.Generics.Basics.DataType
+--      $cMkT :: Data.Generics.Basics.Constr
+mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ)
+mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ)
+
 {-
 Sometimes we need to pick an OccName that has not already been used,
 given a set of in-use OccNames.
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index fc4fb45e67..70eaf5cb21 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -31,14 +31,11 @@ import TcHsType
 import TcMType
 import TcSimplify
 import TcUnify( buildImplicationFor )
-import LoadIface( loadInterfaceForName )
-import Module( getModule )
 
 import RnNames( extendGlobalRdrEnvRn )
 import RnBinds
 import RnEnv
 import RnSource   ( addTcgDUs )
-import HscTypes
 import Avail
 
 import Unify( tcUnifyTy )
@@ -2273,7 +2270,7 @@ genInst :: DerivSpec ThetaType
         -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name)
 genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
                  , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys
-                 , ds_name = dfun_name, ds_cls = clas, ds_loc = loc })
+                 , ds_cls = clas, ds_loc = loc })
   | Just rhs_ty <- is_newtype   -- See Note [Bindings for Generalised Newtype Deriving]
   = do { inst_spec <- newDerivClsInst theta spec
        ; return ( InstInfo
@@ -2290,9 +2287,7 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
               -- See Note [Newtype deriving and unused constructors]
 
   | otherwise
-  = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
-                                        dfun_name rep_tycon
-                                        tys tvs
+  = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas rep_tycon tys tvs
        ; inst_spec <- newDerivClsInst theta spec
        ; traceTc "newder" (ppr inst_spec)
        ; let inst_info = InstInfo { iSpec   = inst_spec
@@ -2306,9 +2301,9 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
 
 -- Generate the bindings needed for a derived class that isn't handled by
 -- -XGeneralizedNewtypeDeriving.
-genDerivStuff :: SrcSpan -> Class -> Name -> TyCon -> [Type] -> [TyVar]
+genDerivStuff :: SrcSpan -> Class -> TyCon -> [Type] -> [TyVar]
               -> TcM (LHsBinds RdrName, BagDerivStuff)
-genDerivStuff loc clas dfun_name tycon inst_tys tyvars
+genDerivStuff loc clas tycon inst_tys tyvars
   -- Special case for DeriveGeneric
   | let ck = classKey clas
   , ck `elem` [genClassKey, gen1ClassKey]
@@ -2316,55 +2311,32 @@ genDerivStuff loc clas dfun_name tycon inst_tys tyvars
         -- TODO NSF: correctly identify when we're building Both instead of One
     in do
       (binds, faminst) <- gen_Generic_binds gk tycon inst_tys
-                                            (nameModule dfun_name)
       return (binds, unitBag (DerivFamInst faminst))
 
   -- Not deriving Generic(1), so we first check if the compiler has built-in
   -- support for deriving the class in question.
+  | Just gen_fn <- hasBuiltinDeriving clas
+  = gen_fn loc tycon
+
   | otherwise
-  = do { dflags <- getDynFlags
-       ; fix_env <- getDataConFixityFun tycon
-       ; case hasBuiltinDeriving dflags fix_env clas of
-              Just gen_fn -> return (gen_fn loc tycon)
-              Nothing -> 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
 
-  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;
--- but if it is imported (which happens for standalone deriving)
--- we need to get the fixity env from the interface file
--- c.f. RnEnv.lookupFixity, and Trac #9830
-getDataConFixityFun tc
-  = do { this_mod <- getModule
-       ; if nameIsLocalOrFrom this_mod name
-         then do { fix_env <- getFixityEnv
-                 ; return (lookupFixity fix_env) }
-         else do { iface <- loadInterfaceForName doc name
-                            -- Should already be loaded!
-                 ; return (mi_fix iface . nameOccName) } }
-  where
-    name = tyConName tc
-    doc = text "Data con fixities for" <+> ppr name
+       ; dflags <- getDynFlags
+       ; 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]
+                ) }
 
 {-
 Note [Bindings for Generalised Newtype Deriving]
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 81f8c0a04b..53a79f8243 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -30,9 +30,14 @@ module TcGenDeriv (
 
 #include "HsVersions.h"
 
+
+import LoadIface( loadInterfaceForName )
+import HscTypes( lookupFixity, mi_fix )
+import TcRnMonad
 import HsSyn
 import RdrName
 import BasicTypes
+import Module( getModule )
 import DataCon
 import Name
 import Fingerprint
@@ -108,27 +113,51 @@ is willing to support it. The canDeriveAnyClass function checks if this is
 the case.
 -}
 
-hasBuiltinDeriving :: DynFlags
-                   -> (Name -> Fixity)
-                   -> Class
+hasBuiltinDeriving :: Class
                    -> Maybe (SrcSpan
                              -> TyCon
-                             -> (LHsBinds RdrName, BagDerivStuff))
-hasBuiltinDeriving dflags fix_env clas = assocMaybe gen_list (getUnique clas)
+                             -> TcM (LHsBinds RdrName, BagDerivStuff))
+hasBuiltinDeriving clas
+  = assocMaybe gen_list (getUnique clas)
+  where
+    gen_list :: [(Unique, SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff))]
+    gen_list = [ (eqClassKey,          simple gen_Eq_binds)
+               , (ordClassKey,         simple gen_Ord_binds)
+               , (enumClassKey,        simple gen_Enum_binds)
+               , (boundedClassKey,     simple gen_Bounded_binds)
+               , (ixClassKey,          simple gen_Ix_binds)
+               , (showClassKey,        with_fix_env gen_Show_binds)
+               , (readClassKey,        with_fix_env gen_Read_binds)
+               , (dataClassKey,        gen_Data_binds)
+               , (functorClassKey,     simple gen_Functor_binds)
+               , (foldableClassKey,    simple gen_Foldable_binds)
+               , (traversableClassKey, simple gen_Traversable_binds)
+               , (liftClassKey,        simple gen_Lift_binds) ]
+
+    simple gen_fn loc tc
+      = return (gen_fn loc tc)
+
+    with_fix_env gen_fn loc tc
+      = do { fix_env <- getDataConFixityFun tc
+           ; return (gen_fn fix_env loc tc) }
+
+getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
+-- If the TyCon is locally defined, we want the local fixity env;
+-- but if it is imported (which happens for standalone deriving)
+-- we need to get the fixity env from the interface file
+-- c.f. RnEnv.lookupFixity, and Trac #9830
+getDataConFixityFun tc
+  = do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name
+         then do { fix_env <- getFixityEnv
+                 ; return (lookupFixity fix_env) }
+         else do { iface <- loadInterfaceForName doc name
+                            -- Should already be loaded!
+                 ; return (mi_fix iface . nameOccName) } }
   where
-    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
-    gen_list = [ (eqClassKey,          gen_Eq_binds)
-               , (ordClassKey,         gen_Ord_binds)
-               , (enumClassKey,        gen_Enum_binds)
-               , (boundedClassKey,     gen_Bounded_binds)
-               , (ixClassKey,          gen_Ix_binds)
-               , (showClassKey,        gen_Show_binds fix_env)
-               , (readClassKey,        gen_Read_binds fix_env)
-               , (dataClassKey,        gen_Data_binds dflags)
-               , (functorClassKey,     gen_Functor_binds)
-               , (foldableClassKey,    gen_Foldable_binds)
-               , (traversableClassKey, gen_Traversable_binds)
-               , (liftClassKey,        gen_Lift_binds) ]
+    name = tyConName tc
+    doc = text "Data con fixities for" <+> ppr name
+
 
 {-
 ************************************************************************
@@ -1273,57 +1302,71 @@ we generate
     dataCast2 = gcast2   -- if T :: * -> * -> *
 -}
 
-gen_Data_binds :: DynFlags
-               -> SrcSpan
+gen_Data_binds :: SrcSpan
                -> TyCon                 -- For data families, this is the
                                         --  *representation* TyCon
-               -> (LHsBinds RdrName,    -- The method bindings
-                   BagDerivStuff)       -- Auxiliary bindings
-gen_Data_binds dflags loc rep_tc
+               -> TcM (LHsBinds RdrName,    -- The method bindings
+                       BagDerivStuff)       -- Auxiliary bindings
+gen_Data_binds loc rep_tc
+  = do { dflags  <- getDynFlags
+
+       -- Make unique names for the data type and constructor
+       -- auxiliary bindings.  Start with the name of the TyCon/DataCon
+       -- but that might not be unique: see Trac #12245.
+       ; dt_occ  <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
+       ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
+                         (tyConDataCons rep_tc)
+       ; let dt_rdr  = mkRdrUnqual dt_occ
+             dc_rdrs = map mkRdrUnqual dc_occs
+
+       -- OK, now do the work
+       ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
+
+gen_data :: DynFlags -> RdrName -> [RdrName]
+         -> SrcSpan -> TyCon
+         -> (LHsBinds RdrName,    -- The method bindings
+             BagDerivStuff)       -- Auxiliary bindings
+gen_data dflags data_type_name constr_names 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))
+     listToBag ( genDataTyCon
+               : zipWith genDataDataCon data_cons constr_names ) )
   where
     data_cons  = tyConDataCons rep_tc
     n_cons     = length data_cons
     one_constr = n_cons == 1
-
-    genDataTyCon :: (LHsBind RdrName, LSig RdrName)
+    genDataTyCon :: DerivStuff
     genDataTyCon        --  $dT
-      = (mkHsVarBind loc rdr_name rhs,
-         L loc (TypeSig [L loc rdr_name] sig_ty))
+      = DerivHsBind (mkHsVarBind loc data_type_name rhs,
+                     L loc (TypeSig [L loc data_type_name] sig_ty))
+
+    sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
+    rhs    = nlHsVar mkDataType_RDR
+             `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
+             `nlHsApp` nlList (map nlHsVar constr_names)
+
+    genDataDataCon :: DataCon -> RdrName -> DerivStuff
+    genDataDataCon dc constr_name       --  $cT1 etc
+      = DerivHsBind (mkHsVarBind loc constr_name rhs,
+                     L loc (TypeSig [L loc constr_name] sig_ty))
       where
-        rdr_name = mk_data_type_name rep_tc
-        sig_ty   = mkLHsSigWcType (nlHsTyVar dataType_RDR)
-        constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
-        rhs = nlHsVar mkDataType_RDR
-              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
-              `nlHsApp` nlList constrs
-
-    genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
-    genDataDataCon dc       --  $cT1 etc
-      = (mkHsVarBind loc rdr_name rhs,
-         L loc (TypeSig [L loc rdr_name] sig_ty))
-      where
-        rdr_name = mk_constr_name dc
         sig_ty   = mkLHsSigWcType (nlHsTyVar constr_RDR)
         rhs      = nlHsApps mkConstr_RDR constr_args
 
         constr_args
-           = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
-           nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
-           nlHsLit (mkHsString (occNameString dc_occ)),   -- String name
-               nlList  labels,                            -- Field labels
-           nlHsVar fixity]                                -- Fixity
+           = [ -- nlHsIntLit (toInteger (dataConTag dc)),   -- Tag
+               nlHsVar (data_type_name)                     -- DataType
+             , nlHsLit (mkHsString (occNameString dc_occ))  -- String name
+             , nlList  labels                               -- Field labels
+             , nlHsVar fixity ]                             -- Fixity
 
         labels   = map (nlHsLit . mkHsString . unpackFS . flLabel)
                        (dataConFieldLabels dc)
         dc_occ   = getOccName dc
         is_infix = isDataSymOcc dc_occ
         fixity | is_infix  = infix_RDR
-           | otherwise = prefix_RDR
+               | otherwise = prefix_RDR
 
         ------------ gfoldl
     gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons)
@@ -1362,15 +1405,15 @@ gen_Data_binds dflags loc rep_tc
         tag = dataConTag dc
 
         ------------ toConstr
-    toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
-    to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
+    toCon_bind = mk_FunBind loc toConstr_RDR (zipWith to_con_eqn data_cons constr_names)
+    to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
 
         ------------ dataTypeOf
     dataTypeOf_bind = mk_easy_FunBind
                         loc
                         dataTypeOf_RDR
                         [nlWildPat]
-                        (nlHsVar (mk_data_type_name rep_tc))
+                        (nlHsVar data_type_name)
 
         ------------ gcast1/2
         -- Make the binding    dataCast1 x = gcast1 x  -- if T :: * -> *
@@ -2327,12 +2370,6 @@ genAuxBinds loc b = genAuxBinds' b2 where
   add2 x (a,b,c) = (a,x `consBag` b,c)
   add3 x (a,b,c) = (a,b,x `consBag` c)
 
-mk_data_type_name :: TyCon -> RdrName   -- "$tT"
-mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
-
-mk_constr_name :: DataCon -> RdrName    -- "$cC"
-mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
-
 mkParentType :: TyCon -> Type
 -- Turn the representation tycon of a family into
 -- a use of its family constructor
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 195493b6f9..a734ae873e 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -21,8 +21,8 @@ import DataCon
 import TyCon
 import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )
 import FamInst
-import Module           ( Module, moduleName, moduleNameFS
-                        , moduleUnitId, unitIdFS )
+import Module           ( moduleName, moduleNameFS
+                        , moduleUnitId, unitIdFS, getModule )
 import IfaceEnv         ( newGlobalBinder )
 import Name      hiding ( varName )
 import RdrName
@@ -63,10 +63,10 @@ For the generic representation we need to generate:
 \end{itemize}
 -}
 
-gen_Generic_binds :: GenericKind -> TyCon -> [Type] -> Module
+gen_Generic_binds :: GenericKind -> TyCon -> [Type]
                  -> TcM (LHsBinds RdrName, FamInst)
-gen_Generic_binds gk tc inst_tys mod = do
-  repTyInsts <- tc_mkRepFamInsts gk tc inst_tys mod
+gen_Generic_binds gk tc inst_tys = do
+  repTyInsts <- tc_mkRepFamInsts gk tc inst_tys
   return (mkBindsRep gk tc, repTyInsts)
 
 {-
@@ -354,13 +354,12 @@ mkBindsRep gk tycon =
 --       type Rep_D a b = ...representation type for D ...
 --------------------------------------------------------------------------------
 
-tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1
-               -> TyCon         -- The type to generate representation for
-               -> [Type]        -- The type(s) to which Generic(1) is applied
-                                -- in the generated instance
-               -> Module        -- Used as the location of the new RepTy
-               -> TcM (FamInst) -- Generated representation0 coercion
-tc_mkRepFamInsts gk tycon inst_tys mod =
+tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1
+                 -> TyCon         -- The type to generate representation for
+                 -> [Type]        -- The type(s) to which Generic(1) is applied
+                                  -- in the generated instance
+                 -> TcM FamInst   -- Generated representation0 coercion
+tc_mkRepFamInsts gk tycon inst_tys =
        -- Consider the example input tycon `D`, where data D a b = D_ a
        -- Also consider `R:DInt`, where { data family D x y :: * -> *
        --                               ; data instance D Int a b = D_ a }
@@ -404,24 +403,26 @@ tc_mkRepFamInsts gk tycon inst_tys mod =
      ; repTy <- tc_mkRepTy gk_ tycon arg_ki
 
        -- `rep_name` is a name we generate for the synonym
-     ; rep_name <- let mkGen = case gk of Gen0 -> mkGenR; Gen1 -> mkGen1R
-                   in newGlobalBinder mod (mkGen (nameOccName (tyConName tycon)))
-                        (nameSrcSpan (tyConName tycon))
+     ; mod <- getModule
+     ; loc <- getSrcSpanM
+     ; let tc_occ  = nameOccName (tyConName tycon)
+           rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
+     ; rep_name <- newGlobalBinder mod rep_occ loc
 
        -- We make sure to substitute the tyvars with their user-supplied
        -- type arguments before generating the Rep/Rep1 instance, since some
        -- of the tyvars might have been instantiated when deriving.
        -- See Note [Generating a correctly typed Rep instance].
-     ; let env      = zipTyEnv tyvars inst_args
-           in_scope = mkInScopeSet (tyCoVarsOfTypes inst_tys)
-           subst    = mkTvSubst in_scope env
-           repTy'   = substTy  subst repTy
-           tcv' = tyCoVarsOfTypeList inst_ty
+     ; let env        = zipTyEnv tyvars inst_args
+           in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)
+           subst      = mkTvSubst in_scope env
+           repTy'     = substTy  subst repTy
+           tcv'       = tyCoVarsOfTypeList inst_ty
            (tv', cv') = partition isTyVar tcv'
-           tvs'     = toposortTyVars tv'
-           cvs'     = toposortTyVars cv'
-           axiom    = mkSingleCoAxiom Nominal rep_name tvs' cvs'
-                                      fam_tc inst_tys repTy'
+           tvs'       = toposortTyVars tv'
+           cvs'       = toposortTyVars cv'
+           axiom      = mkSingleCoAxiom Nominal rep_name tvs' cvs'
+                                        fam_tc inst_tys repTy'
 
      ; newFamInst SynFamilyInst axiom  }
 
diff --git a/testsuite/tests/deriving/should_compile/T12245.hs b/testsuite/tests/deriving/should_compile/T12245.hs
new file mode 100644
index 0000000000..21e271792a
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T12245.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module T12245 where
+
+import Data.Data ( Data )
+
+data Foo f = Foo (f Bool) (f Int)
+
+deriving instance Data (Foo [])
+deriving instance Data (Foo Maybe)
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 9017687b07..a81c4ce2d7 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -70,4 +70,4 @@ test('T11732a', normal, compile, [''])
 test('T11732b', normal, compile, [''])
 test('T11732c', normal, compile, [''])
 test('T11833', normal, compile, [''])
-test('T11837', normal, compile, [''])
+test('T12245', normal, compile, [''])