Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
f7865a6b
Commit
f7865a6b
authored
Oct 21, 2003
by
simonpj
Browse files
[project @ 2003-10-21 12:36:29 by simonpj]
Report duplicate instance declarations
parent
c550e0e2
Changes
2
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/typecheck/Inst.lhs
View file @
f7865a6b
...
...
@@ -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}
%************************************************************************
...
...
ghc/compiler/types/InstEnv.lhs
View file @
f7865a6b
...
...
@@ -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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment