diff options
Diffstat (limited to 'compiler/types/InstEnv.lhs')
| -rw-r--r-- | compiler/types/InstEnv.lhs | 139 |
1 files changed, 86 insertions, 53 deletions
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index dd70be8748..ab90be248a 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -13,8 +13,8 @@ module InstEnv ( instanceHead, mkLocalInstance, mkImportedInstance, instanceDFunId, setInstanceDFunId, instanceRoughTcs, - InstEnv, emptyInstEnv, extendInstEnv, - extendInstEnvList, lookupInstEnv, instEnvElts, + InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv, + extendInstEnvList, lookupInstEnv', lookupInstEnv, instEnvElts, classInstances, instanceBindFun, instanceCantMatch, roughMatchTcs ) where @@ -387,6 +387,29 @@ extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm }) = addToUFM_C add inst_env cls_nm (ClsIE [ins_item]) where add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) + +overwriteInstEnv :: InstEnv -> Instance -> InstEnv +overwriteInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tys = tys }) + = addToUFM_C add inst_env cls_nm (ClsIE [ins_item]) + where + add (ClsIE cur_insts) _ = ClsIE (replaceInst cur_insts) + + rough_tcs = roughMatchTcs tys + replaceInst [] = [ins_item] + replaceInst (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs, + is_tys = tpl_tys, + is_dfun = dfun }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = item : replaceInst rest + + | Just _ <- tcMatchTys tpl_tvs tpl_tys tys + = let (dfun_tvs, _) = tcSplitForAllTys (idType dfun) + in ASSERT( all (`elemVarSet` tpl_tvs) dfun_tvs ) -- Check invariant + ins_item : rest + + | otherwise + = item : replaceInst rest \end{code} @@ -418,17 +441,15 @@ might have some tyvars that *only* appear in arguments When we match this against D [ty], we return the instantiating types [Right ty, Left b] where the Nothing indicates that 'b' can be freely instantiated. -(The caller instantiates it to a flexi type variable, which will presumably +(The caller instantiates it to a flexi type variable, which will presumably later become fixed via functional dependencies.) \begin{code} -lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env - -> Class -> [Type] -- What we are looking for - -> ([InstMatch], -- Successful matches - [Instance], -- These don't match but do unify - Bool) -- True if error condition caused by - -- Safe Haskell condition. +lookupInstEnv' :: InstEnv -- InstEnv to look in + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + [Instance]) -- These don't match but do unify -- The second component of the result pair happens when we look up -- Foo [a] -- in an InstEnv that has entries for @@ -439,53 +460,11 @@ lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env -- but Foo [Int] is a unifier. This gives the caller a better chance of -- giving a suitable error message -lookupInstEnv (pkg_ie, home_ie) cls tys - = (safe_matches, all_unifs, safe_fail) +lookupInstEnv' ie cls tys + = lookup ie where rough_tcs = roughMatchTcs tys all_tvs = all isNothing rough_tcs - (home_matches, home_unifs) = lookup home_ie - (pkg_matches, pkg_unifs) = lookup pkg_ie - all_matches = home_matches ++ pkg_matches - all_unifs = home_unifs ++ pkg_unifs - pruned_matches = foldr insert_overlapping [] all_matches - (safe_matches, safe_fail) = if length pruned_matches == 1 - then check_safe (head pruned_matches) all_matches - else (pruned_matches, False) - -- Even if the unifs is non-empty (an error situation) - -- we still prune the matches, so that the error message isn't - -- misleading (complaining of multiple matches when some should be - -- overlapped away) - - -- Safe Haskell: We restrict code compiled in 'Safe' mode from - -- overriding code compiled in any other mode. The rational is - -- that code compiled in 'Safe' mode is code that is untrusted - -- by the ghc user. So we shouldn't let that code change the - -- behaviour of code the user didn't compile in 'Safe' mode - -- since thats the code they trust. So 'Safe' instances can only - -- overlap instances from the same module. A same instance origin - -- policy for safe compiled instances. - check_safe match@(inst,_) others - = case isSafeOverlap (is_flag inst) of - -- most specific isn't from a Safe module so OK - False -> ([match], False) - -- otherwise we make sure it only overlaps instances from - -- the same module - True -> (go [] others, True) - where - go bad [] = match:bad - go bad (i@(x,_):unchecked) = - if inSameMod x - then go bad unchecked - else go (i:bad) unchecked - - inSameMod b = - let na = getName $ getName inst - la = isInternalName na - nb = getName $ getName b - lb = isInternalName nb - in (la && lb) || (nameModule na == nameModule nb) - -------------- lookup env = case lookupUFM env cls of Nothing -> ([],[]) -- No instances for this class @@ -531,6 +510,60 @@ lookupInstEnv (pkg_ie, home_ie) cls tys Nothing -> Left tv --------------- +-- This is the common way to call this function. +lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + [Instance], -- These don't match but do unify + Bool) -- True if error condition caused by + -- SafeHaskell condition. + +lookupInstEnv (pkg_ie, home_ie) cls tys + = (safe_matches, all_unifs, safe_fail) + where + (home_matches, home_unifs) = lookupInstEnv' home_ie cls tys + (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie cls tys + all_matches = home_matches ++ pkg_matches + all_unifs = home_unifs ++ pkg_unifs + pruned_matches = foldr insert_overlapping [] all_matches + (safe_matches, safe_fail) = if length pruned_matches == 1 + then check_safe (head pruned_matches) all_matches + else (pruned_matches, False) + -- Even if the unifs is non-empty (an error situation) + -- we still prune the matches, so that the error message isn't + -- misleading (complaining of multiple matches when some should be + -- overlapped away) + + -- Safe Haskell: We restrict code compiled in 'Safe' mode from + -- overriding code compiled in any other mode. The rational is + -- that code compiled in 'Safe' mode is code that is untrusted + -- by the ghc user. So we shouldn't let that code change the + -- behaviour of code the user didn't compile in 'Safe' mode + -- since that's the code they trust. So 'Safe' instances can only + -- overlap instances from the same module. A same instance origin + -- policy for safe compiled instances. + check_safe match@(inst,_) others + = case isSafeOverlap (is_flag inst) of + -- most specific isn't from a Safe module so OK + False -> ([match], False) + -- otherwise we make sure it only overlaps instances from + -- the same module + True -> (go [] others, True) + where + go bad [] = match:bad + go bad (i@(x,_):unchecked) = + if inSameMod x + then go bad unchecked + else go (i:bad) unchecked + + inSameMod b = + let na = getName $ getName inst + la = isInternalName na + nb = getName $ getName b + lb = isInternalName nb + in (la && lb) || (nameModule na == nameModule nb) + +--------------- --------------- insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] -- Add a new solution, knocking out strictly less specific ones |