diff options
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 16 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyDecls.lhs | 22 |
2 files changed, 28 insertions, 10 deletions
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 70e72f593f..f4e4dabd1b 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1524,14 +1524,16 @@ checkValidRoles tc = return () where check_dc_roles datacon - = let univ_tvs = dataConUnivTyVars datacon - ex_tvs = dataConExTyVars datacon - args = dataConRepArgTys datacon - univ_roles = zipVarEnv univ_tvs (tyConRoles tc) + = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) + ; mapM_ (check_ty_roles role_env Representational) $ + eqSpecPreds eq_spec ++ theta ++ arg_tys } + -- See Note [Role-checking data constructor arguments] in TcTyDecls + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig datacon + univ_roles = zipVarEnv univ_tvs (tyConRoles tc) -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs - ex_roles = mkVarEnv (zip ex_tvs (repeat Nominal)) - role_env = univ_roles `plusVarEnv` ex_roles in - mapM_ (check_ty_roles role_env Representational) args + ex_roles = mkVarEnv (zip ex_tvs (repeat Nominal)) + role_env = univ_roles `plusVarEnv` ex_roles check_ty_roles env role (TyVarTy tv) = case lookupVarEnv env tv of diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index bea2cd19be..5091cab802 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -615,6 +615,19 @@ roles(~#) = N, N With -dcore-lint on, the output of this algorithm is checked in checkValidRoles, called from checkValidTycon. +Note [Role-checking data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a where + MkT :: Eq b => F a -> (a->a) -> T (G a) + +Then we want to check the roles at which 'a' is used +in MkT's type. We want to work on the user-written type, +so we need to take into account + * the arguments: (F a) and (a->a) + * the context: C a b + * the result type: (G a) -- this is in the eq_spec + \begin{code} type RoleEnv = NameEnv [Role] -- from tycon names to roles type RoleAnnots = NameEnv [Maybe Role] -- from tycon names to role annotations, @@ -695,9 +708,12 @@ irClass tc_name cls -- See Note [Role inference] irDataCon :: Name -> DataCon -> RoleM () irDataCon tc_name datacon - = addRoleInferenceInfo tc_name (dataConUnivTyVars datacon) $ - let ex_var_set = mkVarSet $ dataConExTyVars datacon in - mapM_ (irType ex_var_set) (dataConRepArgTys datacon) + = addRoleInferenceInfo tc_name univ_tvs $ + mapM_ (irType ex_var_set) (eqSpecPreds eq_spec ++ theta ++ arg_tys) + -- See Note [Role-checking data constructor arguments] + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig datacon + ex_var_set = mkVarSet ex_tvs irType :: VarSet -> Type -> RoleM () irType = go |