Commit 895eefa8 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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.
parent 5f79394f
......@@ -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.
......
......@@ -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]
......
......@@ -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
......
......@@ -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 }
......
{-# 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)
......@@ -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, [''])
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