From: Manuel M T Chakravarty Date: Thu, 12 Oct 2006 20:37:37 +0000 (+0000) Subject: Overlap check for family instances def'd in current module X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=8a5d47de2b82d9cca86546a7bd89d915488934ef Overlap check for family instances def'd in current module - All family instances are checked for overlap when entered into TcGblEnv. Their are checked against all instances in the EPS and those currently in the TcGblEnv. --- diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 3f22633..41f22be 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -14,7 +14,11 @@ import TcType import TcRnMonad import TyCon import Type +import Name +import SrcLoc import Outputable + +import Monad \end{code} @@ -51,41 +55,42 @@ addLocalFamInst home_fie famInst ty = case tyConFamInst_maybe tycon of Nothing -> panic "FamInst.addLocalFamInst" Just (tc, tys) -> tc `mkTyConApp` tys - ; (tvs', theta', tau') <- tcInstSkolType (FamInstSkol tycon) ty + ; (tvs', _, tau') <- tcInstSkolType (FamInstSkol tycon) ty - ; let (fam, tys') = tcSplitTyConApp tau' + ; let (fam, tys') = tcSplitTyConApp tau' -- Load imported instances, so that we report -- overlaps correctly ; eps <- getEps ; let inst_envs = (eps_fam_inst_env eps, home_fie) -{- !!!TODO: Need to complete this: - -- Check for overlapping instance decls - ; let { (matches, _) = lookupFamInstEnv inst_envs fam tys' - ; dup_ispecs = [ dup_ispec --!!!adapt - | (_, dup_ispec) <- matches - , let (_,_,_,dup_tys) = instanceHead dup_ispec - , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] } - -- Find memebers of the match list which ispec itself matches. - -- If the match is 2-way, it's a duplicate - ; case dup_ispecs of - dup_ispec : _ -> dupInstErr famInst dup_ispec - [] -> return () - -} + -- Check for conflicting instance decls + ; let { matches = lookupFamInstEnvUnify inst_envs fam tys' + ; conflicts = [ conflictingFamInst + | match@(_, conflictingFamInst) <- matches + , conflicting fam tys' tycon match + ] + } + ; unless (null conflicts) $ + conflictInstErr famInst (head conflicts) -- OK, now extend the envt - ; return (extendFamInstEnv home_fie famInst) } + ; return (extendFamInstEnv home_fie famInst) + } + where + -- In the case of data/newtype instances, any overlap is a conflicts (as + -- these instances imply injective type mappings). + conflicting _ _ tycon _ | isAlgTyCon tycon = True + conflicting fam tys' tycon (subst, cFamInst) | otherwise = + panic "FamInst.addLocalFamInst: overlap check for indexed synonyms is still missing" -{- UNUSED??? --SDM -overlapErr famInst dupFamInst +conflictInstErr famInst conflictingFamInst = addFamInstLoc famInst $ - addErr (hang (ptext SLIT("Overlapping family instance declarations:")) - 2 (pprFamInsts [famInst, dupFamInst])) + addErr (hang (ptext SLIT("Conflicting family instance declarations:")) + 2 (pprFamInsts [famInst, conflictingFamInst])) addFamInstLoc famInst thing_inside = setSrcSpan (mkSrcSpan loc loc) thing_inside where loc = getSrcLoc famInst --} \end{code} diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index c44c200..9b49f5c 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -11,13 +11,15 @@ module FamInstEnv ( FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList, famInstEnvElts, familyInstances, - lookupFamInstEnv + + lookupFamInstEnv, lookupFamInstEnvUnify ) where #include "HsVersions.h" import InstEnv import Unify +import TcGadt import TcType import Type import TyCon @@ -210,6 +212,7 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys | otherwise -> find insts -------------- + find [] = [] find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_tys = tpl_tys, fi_tycon = tycon }) : rest) -- Fast check for no match, uses the "rough match" fields @@ -224,3 +227,60 @@ lookupFamInstEnv (pkg_ie, home_ie) fam tys | otherwise = find rest \end{code} + +While @lookupFamInstEnv@ uses a one-way match, the next function +@lookupFamInstEnvUnify@ 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 +function (cf, @InstEnv@). We don't do that for family instances as the +results of matching and unification are used in two different contexts. +Moreover, matching is the wildly more frequently used operation in the case of +indexed synonyms and we don't want to slow that down by needless unification. + +\begin{code} +lookupFamInstEnvUnify :: (FamInstEnv, FamInstEnv) -> TyCon -> [Type] + -> [(TvSubst, FamInst)] +lookupFamInstEnvUnify (pkg_ie, home_ie) fam tys + = home_matches ++ pkg_matches + where + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + home_matches = lookup home_ie + pkg_matches = lookup pkg_ie + + -------------- + lookup env = case lookupUFM env fam of + Nothing -> [] -- No instances for this class + Just (FamIE insts has_tv_insts) + -- Short cut for common case: + -- The thing we are looking up is of form (C a + -- b c), and the FamIE has no instances of + -- that form, so don't bother to search + | all_tvs && not has_tv_insts -> [] + | otherwise -> find insts + + -------------- + find [] = [] + find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, + fi_tys = tpl_tys, fi_tycon = tycon }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find rest + + | otherwise + = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs, + (ppr fam <+> ppr tys <+> ppr all_tvs) $$ + (ppr tycon <+> ppr tpl_tvs <+> ppr tpl_tys) + ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + case tcUnifyTys bind_fn tpl_tys tys of + Just subst -> (subst, item) : find rest + Nothing -> find rest + +-- See explanation at @InstEnv.bind_fn@. +-- +bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem + | otherwise = BindMe +\end{code}