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

Report duplicate instance declarations

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index f035eef..b742a4c 100644 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -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}
 
 %************************************************************************

diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs
index 64591bc..f8daac9 100644 (file)
--- a/ghc/compiler/types/InstEnv.lhs
+++ b/ghc/compiler/types/InstEnv.lhs
@@ -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