Commit f7865a6b authored by simonpj's avatar simonpj
Browse files

[project @ 2003-10-21 12:36:29 by simonpj]

Report duplicate instance declarations
parent c550e0e2
......@@ -540,18 +540,35 @@ tcExtendLocalInstEnv dfuns thing_inside
= do { traceDFuns dfuns
; eps <- getEps
; env <- getGblEnv
; inst_env' <- foldlM (extend (eps_inst_env eps))
; dflags <- getDOpts
; inst_env' <- foldlM (extend dflags (eps_inst_env eps))
(tcg_inst_env env)
dfuns
; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
where
extend pkg_ie home_ie dfun
= do { case checkFunDeps (home_ie, pkg_ie) dfun of
extend dflags pkg_ie home_ie dfun
= do { checkNewInst dflags (home_ie, pkg_ie) dfun
; return (extendInstEnv home_ie dfun) }
checkNewInst :: DynFlags -> (InstEnv, InstEnv) -> DFunId -> TcM ()
-- Check that the proposed new instance is OK
checkNewInst dflags ies dfun
= do { -- Check functional dependencies
case checkFunDeps (home_ie, pkg_ie) dfun of
Just dfuns -> funDepErr dfun dfuns
Nothing -> return ()
; return (extendInstEnv home_ie dfun) }
-- Check for duplicate instance decls
; mappM_ (dupInstErr dfun) dup_dfuns }
where
(tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
(matches, _) = lookupInstEnv dflags ies clas tys
dup_dfuns = [dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
isJust (matchTys tvs tys dup_tys)]
-- Find memebers of the match list which
-- dfun itself matches. If the match is 2-way, it's a duplicate
traceDFuns dfuns
= traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
......@@ -562,6 +579,10 @@ funDepErr dfun dfuns
= addSrcLoc (getSrcLoc dfun) $
addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
2 (pprDFuns (dfun:dfuns)))
dupInstErr dfun dup_dfun
= addSrcLoc (getSrcLoc dfun) $
addErr (hang (ptext SLIT("Duplicate instance declarations:"))
2 (pprDFuns [dfun, dup_dfun]))
\end{code}
%************************************************************************
......
......@@ -272,20 +272,20 @@ lookupInstEnv dflags (home_ie, pkg_ie) cls tys
where
incoherent_ok = dopt Opt_AllowIncoherentInstances dflags
overlap_ok = dopt Opt_AllowOverlappingInstances dflags
(home_matches, home_unifs) = lookup_inst_env incoherent_ok home_ie cls tys
(pkg_matches, pkg_unifs) = lookup_inst_env incoherent_ok pkg_ie cls tys
(home_matches, home_unifs) = lookup_inst_env home_ie cls tys
(pkg_matches, pkg_unifs) = lookup_inst_env pkg_ie cls tys
all_matches = home_matches ++ pkg_matches
all_unifs = home_unifs ++ pkg_unifs
all_unifs | incoherent_ok = [] -- Don't worry about these if incoherent is ok!
| otherwise = home_unifs ++ pkg_unifs
pruned_matches | overlap_ok = foldr insert_overlapping [] all_matches
| otherwise = all_matches
lookup_inst_env :: Bool
-> InstEnv -- The envt
-> Class -> [Type] -- What we are looking for
-> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches
[Id]) -- These don't match but do unify
lookup_inst_env incoherent_ok env key_cls key_tys
lookup_inst_env :: InstEnv -- The envt
-> Class -> [Type] -- What we are looking for
-> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches
[Id]) -- These don't match but do unify
lookup_inst_env env key_cls key_tys
= find (classInstEnv env key_cls) [] []
where
key_vars = tyVarsOfTypes key_tys
......@@ -296,10 +296,6 @@ lookup_inst_env incoherent_ok env key_cls key_tys
Just (subst, leftovers) -> ASSERT( null leftovers )
find rest ((subst,item):ms) us
Nothing
| incoherent_ok -> find rest ms us
-- If we allow incoherent instances we don't worry about the
-- test and just blaze on anyhow. Requested by John Hughes.
| otherwise
-- Does not match, so next check whether the things unify
-- [see notes about overlapping instances above]
-> case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of
......
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