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

Report duplicate instance declarations

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

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