diff options
| author | Manuel M T Chakravarty <chak@cse.unsw.edu.au> | 2009-07-07 05:54:42 +0000 |
|---|---|---|
| committer | Manuel M T Chakravarty <chak@cse.unsw.edu.au> | 2009-07-07 05:54:42 +0000 |
| commit | 8897e76874e10daa4dc695342e68b15e114a6de0 (patch) | |
| tree | 83f5fa87254a521a273eeea850da03bf797b7453 | |
| parent | 90d1a7615977f2040e82661704c82b49a9b11ea5 (diff) | |
| download | haskell-8897e76874e10daa4dc695342e68b15e114a6de0.tar.gz | |
FIX #2677
| -rw-r--r-- | compiler/typecheck/FamInst.lhs | 3 | ||||
| -rw-r--r-- | compiler/types/FamInstEnv.lhs | 17 |
2 files changed, 13 insertions, 7 deletions
diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 5a3a6648f6..609c0ba008 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -178,7 +178,8 @@ checkForConflicts inst_envs famInst -- We use tcInstSkolType because we don't want to allocate -- fresh *meta* type variables. - ; skol_tvs <- tcInstSkolTyVars FamInstSkol (tyConTyVars (famInstTyCon famInst)) + ; skol_tvs <- tcInstSkolTyVars FamInstSkol + (tyConTyVars (famInstTyCon famInst)) ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs ; unless (null conflicts) $ conflictInstErr famInst (fst (head conflicts)) diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 50c827f222..5ea2096ae1 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -228,7 +228,7 @@ lookupFamInstEnv -> [FamInstMatch] -- Successful matches lookupFamInstEnv - = lookup_fam_inst_env match + = lookup_fam_inst_env match True where match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys @@ -245,7 +245,7 @@ lookupFamInstEnvConflicts -- unique supply to hand lookupFamInstEnvConflicts envs fam_inst skol_tvs - = lookup_fam_inst_env my_unify envs fam tys' + = lookup_fam_inst_env my_unify False envs fam tys' where inst_tycon = famInstTyCon fam_inst (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts" @@ -275,12 +275,13 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs | otherwise = not (old_rhs `tcEqType` new_rhs) where old_tycon = famInstTyCon old_fam_inst - old_rhs = mkTyConApp old_tycon (substTyVars subst (tyConTyVars old_tycon)) + old_tvs = tyConTyVars old_tycon + old_rhs = mkTyConApp old_tycon (substTyVars subst old_tvs) new_rhs = mkTyConApp inst_tycon (substTyVars subst skol_tvs) \end{code} While @lookupFamInstEnv@ uses a one-way match, the next function -@lookupFamInstEnvUnify@ uses two-way matching (ie, unification). This is +@lookupFamInstEnvConflicts@ uses two-way matching (ie, unification). This is needed to check for overlapping instances. For class instances, these two variants of lookup are combined into one @@ -297,12 +298,16 @@ type MatchFun = FamInst -- The FamInst template -> [Type] -- Target to match against -> Maybe TvSubst +type OneSidedMatch = Bool -- Are optimisations that are only valid for + -- one sided matches allowed? + lookup_fam_inst_env -- The worker, local to this module :: MatchFun + -> OneSidedMatch -> FamInstEnvs -> TyCon -> [Type] -- What we are looking for -> [FamInstMatch] -- Successful matches -lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys +lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys | not (isOpenTyCon fam) = [] | otherwise @@ -323,7 +328,7 @@ lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys -------------- rough_tcs = roughMatchTcs match_tys - all_tvs = all isNothing rough_tcs + all_tvs = all isNothing rough_tcs && one_sided -------------- lookup env = case lookupUFM env fam of |