From: simonpj <unknown>
Date: Mon, 27 Oct 2003 14:08:06 +0000 (+0000)
Subject: [project @ 2003-10-27 14:08:04 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~321
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=a0908440c99383763cb39bf611ef2c8e049bc48d;p=ghc-hetmet.git

[project @ 2003-10-27 14:08:04 by simonpj]
Improve duplicate-instance reporting; swap inst-env param order
---

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 11d41a4..ad51a49 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -540,40 +540,40 @@ tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
   -- Add new locally-defined instances
 tcExtendLocalInstEnv dfuns thing_inside
  = do { traceDFuns dfuns
-      ; eps <- getEps
       ; env <- getGblEnv
       ; dflags  <- getDOpts
-      ; inst_env' <- foldlM (extend dflags (eps_inst_env eps)) 
-			    (tcg_inst_env env) 
-			    dfuns
+      ; inst_env' <- foldlM (addInst dflags) (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 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 ies dfun of
+addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
+-- Check that the proposed new instance is OK, 
+-- and then add it to the home inst env
+addInst dflags home_ie dfun
+  = do	{ 	-- Load imported instances, so that we report
+		-- duplicates correctly
+	  pkg_ie  <- loadImportedInsts cls tys
+
+		-- Check functional dependencies
+	; case checkFunDeps (pkg_ie, home_ie) dfun of
 		Just dfuns -> funDepErr dfun dfuns
 		Nothing    -> return ()
 
 		-- Check for duplicate instance decls
+	; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys
+	      ;	dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
+			  		isJust (matchTys (mkVarSet tvs) tys dup_tys)] }
+		-- Find memebers of the match list which 
+		-- dfun itself matches. If the match is 2-way, it's a duplicate
 	; case dup_dfuns of
 	    dup_dfun : _ -> dupInstErr dfun dup_dfun
 	    []           -> return ()
-	}
+
+		-- OK, now extend the envt
+	; return (extendInstEnv home_ie dfun) }
   where
     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
-    (matches, _) = lookupInstEnv dflags ies cls tys
-    dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
-			    isJust (matchTys (mkVarSet 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))
diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs
index f8daac9..a5f28a9 100644
--- a/ghc/compiler/types/InstEnv.lhs
+++ b/ghc/compiler/types/InstEnv.lhs
@@ -250,8 +250,8 @@ thing we are looking up can have an arbitrary "flexi" part.
 
 \begin{code}
 lookupInstEnv :: DynFlags
-	      -> (InstEnv, 	-- Home-package inst-env
-		  InstEnv) 	-- External package inst-env
+	      -> (InstEnv 	-- External package inst-env
+		 ,InstEnv) 	-- Home-package inst-env
 	      -> Class -> [Type]			-- What we are looking for
 	      -> ([(TyVarSubstEnv, InstEnvElt)], 	-- Successful matches
 		  [Id])					-- These don't match but do unify
@@ -265,7 +265,7 @@ lookupInstEnv :: DynFlags
 	-- but Foo [Int] is a unifier.  This gives the caller a better chance of
 	-- giving a suitable error messagen
 
-lookupInstEnv dflags (home_ie, pkg_ie) cls tys
+lookupInstEnv dflags (pkg_ie, home_ie) cls tys
   | not (null all_unifs) = (all_matches, all_unifs)	-- This is always an error situation,
 							-- so don't attempt to pune the matches
   | otherwise		 = (pruned_matches, [])
@@ -362,7 +362,7 @@ checkFunDeps :: (InstEnv, InstEnv) -> DFunId
 	     -> Maybe [DFunId]	-- Nothing  <=> ok
 				-- Just dfs <=> conflict with dfs
 -- Check wheher adding DFunId would break functional-dependency constraints
-checkFunDeps (home_ie, pkg_ie) dfun
+checkFunDeps (pkg_ie, home_ie) dfun
   | null bad_fundeps = Nothing
   | otherwise	     = Just bad_fundeps
   where