= 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))
= 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}
%************************************************************************
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
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