Commit 8a5d47de authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

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.
parent 07160d61
......@@ -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}
......@@ -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}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment