diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/typecheck/FamInst.hs | 59 | ||||
| -rw-r--r-- | compiler/types/FamInstEnv.hs | 12 |
2 files changed, 44 insertions, 27 deletions
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index 0491891529..b76e10d989 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -314,8 +314,8 @@ checkFamInstConsistency famInstMods directlyImpMods -- defined by the module we are compiling in imports. = partition ((/= this_mod) . nameModule . fi_fam) (famInstEnvElts env1) - ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) check_now - ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now + ; mapM_ (checkForConflicts [env2]) check_now + ; mapM_ (checkForInjectivityConflicts [env2]) check_now ; let check_later_map = extendNameEnvList_C (++) emptyNameEnv [(fi_fam finst, [finst]) | finst <- check_later] @@ -334,8 +334,8 @@ checkRecFamInstConsistency tc = do , Just pairs <- lookupNameEnv (tcg_pending_fam_checks tcg_env) (tyConName tc) = forM_ pairs $ \(check_now, env2) -> do - mapM_ (checkForConflicts (emptyFamInstEnv, env2)) check_now - mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now + mapM_ (checkForConflicts [env2]) check_now + mapM_ (checkForInjectivityConflicts [env2]) check_now | otherwise = return () checkConsistency tc @@ -479,9 +479,26 @@ tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv ; let this_mod = tcg_mod env imports = tcg_imports env + +{- + -- Load the interfaces for all of our dependencies that define + -- family instances. We must do this so that in addLocalFamInst + -- below, the eps_fam_inst_env will contain all the instances + -- we are supposed to check consistency against. ; loadModuleInterfaces (text "Loading family-instance modules") (filter (/= this_mod) (imp_finsts imports)) - ; (inst_env', fam_insts') <- foldlM addLocalFamInst +-} + + -- XXX + ; hpt <- getHpt + ; let hmiModule = mi_module . hm_iface + hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv + . md_fam_insts . hm_details + hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) + | hmi <- eltsHpt hpt] + ; finsts <- mapM (getFamInsts hpt_fam_insts) (filter (/= this_mod) (imp_finsts imports)) + + ; (inst_env', fam_insts') <- foldlM (addLocalFamInst finsts) (tcg_fam_inst_env env, tcg_fam_insts env) fam_insts ; let env' = env { tcg_fam_insts = fam_insts' @@ -493,12 +510,15 @@ tcExtendLocalFamInstEnv fam_insts thing_inside -- and then add it to the home inst env -- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] -- in FamInstEnv.hs -addLocalFamInst :: (FamInstEnv,[FamInst]) +addLocalFamInst :: [FamInstEnv] + -> (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst]) -addLocalFamInst (home_fie, my_fis) fam_inst +addLocalFamInst imp_fies (home_fie, my_fis) fam_inst + -- imp_fies includes all our imp_finsts -- home_fie includes home package and this module - -- my_fies is just the ones from this module + -- (XXX do we really need to check these?) + -- my_fis is just the ones from this module = do { traceTc "addLocalFamInst" (ppr fam_inst) ; isGHCi <- getIsGHCi @@ -512,16 +532,9 @@ addLocalFamInst (home_fie, my_fis) fam_inst | isGHCi = deleteFromFamInstEnv home_fie fam_inst | otherwise = home_fie - -- Fetch imported instances, so that we report + -- Retrieve imported instances, so that we report -- overlaps correctly - -- XXX Technically, we ought to only fetch those instances - -- which are visible from this module. - -- And indeed, rather than getting the WHOLE eps_fam_inst_env, - -- if we just pulled the 'FamInstEnv's of our dependencies, - -- we wouldn't need this "action at a distance" loadModuleInterfaces, - -- above, I think. - ; eps <- getEps - ; let inst_envs = (eps_fam_inst_env eps, home_fie') + ; let inst_envs = home_fie' : imp_fies home_fie'' = extendFamInstEnv home_fie fam_inst -- Check for conflicting instance decls and injectivity violations @@ -544,9 +557,11 @@ Check whether a single family instance conflicts with those in two instance environments (one for the EPS and one for the HPT). -} -checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool +checkForConflicts :: [FamInstEnv] -> FamInst -> TcM Bool checkForConflicts inst_envs fam_inst - = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst + = do { let conflicts = concatMap + (\e -> lookupFamInstEnvConflicts e fam_inst) + inst_envs no_conflicts = null conflicts ; traceTc "checkForConflicts" $ vcat [ ppr (map fim_instance conflicts) @@ -560,13 +575,15 @@ checkForConflicts inst_envs fam_inst -- violating injectivity annotation supplied by the user. Returns True when -- this is possible and False if adding this equation would violate injectivity -- annotation. -checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM Bool +checkForInjectivityConflicts :: [FamInstEnv] -> FamInst -> TcM Bool checkForInjectivityConflicts instEnvs famInst | isTypeFamilyTyCon tycon -- type family is injective in at least one argument , Injective inj <- familyTyConInjectivityInfo tycon = do { let axiom = coAxiomSingleBranch fi_ax - conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst + conflicts = concatMap + (\e -> lookupFamInstEnvInjectivityConflicts inj e famInst) + instEnvs -- see Note [Verifying injectivity annotation] in FamInstEnv errs = makeInjectivityErrors fi_ax axiom inj conflicts ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index d2fb52050d..426b636fc2 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -742,7 +742,7 @@ lookupFamInstEnv match _ _ tpl_tys tys = tcMatchTys tpl_tys tys lookupFamInstEnvConflicts - :: FamInstEnvs + :: FamInstEnv -> FamInst -- Putative new instance -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) -- E.g. when we are about to add @@ -752,8 +752,8 @@ lookupFamInstEnvConflicts -- -- Precondition: the tycon is saturated (or over-saturated) -lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) - = lookup_fam_inst_env my_unify envs fam tys +lookupFamInstEnvConflicts env fam_inst@(FamInst { fi_axiom = new_axiom }) + = lookup_fam_inst_env' my_unify env fam tys where (fam, tys) = famInstSplitLHS fam_inst -- In example above, fam tys' = F [b] @@ -868,14 +868,14 @@ See also Note [Injective type families] in TyCon lookupFamInstEnvInjectivityConflicts :: [Bool] -- injectivity annotation for this type family instance -- INVARIANT: list contains at least one True value - -> FamInstEnvs -- all type instances seens so far + -> FamInstEnv -- type instances seen so far to check against -> FamInst -- new type instance that we're checking -> [CoAxBranch] -- conflicting instance delcarations -lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) +lookupFamInstEnvInjectivityConflicts injList ie fam_inst@(FamInst { fi_axiom = new_axiom }) -- See Note [Verifying injectivity annotation]. This function implements -- check (1.B1) for open type families described there. - = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie + = lookup_inj_fam_conflicts ie where fam = famInstTyCon fam_inst new_branch = coAxiomSingleBranch new_axiom |