X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FInstEnv.lhs;h=73a6ce9734902275ece0dcac8df5299860bff381;hb=3087014ae03067cf0f9c9e0d8d49fb885e2cd0a8;hp=4f36597c58633da716fe0e66013d67c2c8547267;hpb=91c750cbd18e3d610b0db498ded38d5b3c5adfac;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs
index 4f36597..73a6ce9 100644
--- a/ghc/compiler/types/InstEnv.lhs
+++ b/ghc/compiler/types/InstEnv.lhs
@@ -21,7 +21,8 @@ import Var		( TyVar, Id )
 import VarSet
 import VarEnv
 import Maybes		( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
-import Name		( getSrcLoc )
+import Name		( getSrcLoc, nameModule )
+import SrcLoc		( SrcLoc, isGoodSrcLoc )
 import TcType		( Type, tcTyConAppTyCon, mkTyVarTy,
 			  tcSplitDFunTy, tyVarsOfTypes,
 			  matchTys, unifyTyListsX, allDistinctTyVars
@@ -31,9 +32,10 @@ import FunDeps		( checkClsFD )
 import TyCon		( TyCon )
 import Outputable
 import UniqFM		( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM )
-import Id		( idType )
+import Id		( idType, idName )
 import ErrUtils		( Message )
 import CmdLineOpts
+import Util             ( notNull )
 \end{code}
 
 
@@ -313,20 +315,20 @@ True => overlap is permitted, but only if one template matches the other;
         not if they unify but neither is 
 
 \begin{code}
-extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [Message])
+extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [(SrcLoc,Message)])
   -- Similar, but all we have is the DFuns
 extendInstEnv dflags env dfun_ids = foldl (addToInstEnv dflags) (env, []) dfun_ids
 
 
 addToInstEnv :: DynFlags
-             -> (InstEnv, [Message])
+             -> (InstEnv, [(SrcLoc,Message)])
 	     -> DFunId
-	     -> (InstEnv, [Message])	-- Resulting InstEnv and augmented error messages
+	     -> (InstEnv, [(SrcLoc,Message)])	-- Resulting InstEnv and augmented error messages
 
 addToInstEnv dflags (inst_env, errs) dfun_id
 	-- Check first that the new instance doesn't 
 	-- conflict with another.  See notes below about fundeps.
-  | not (null bad_fundeps)
+  | notNull bad_fundeps
   = (inst_env, fundep_err : errs)		-- Bad fundeps; report the first only
 
   | otherwise
@@ -426,7 +428,7 @@ badFunDeps :: ClsInstEnv -> Class
 badFunDeps cls_inst_env clas ins_tv_set ins_tys 
   = [ dfun_id | fd <- fds,
 	       (tvs, tys, dfun_id) <- cls_inst_env,
-	       not (null (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys))
+	       notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys)
     ]
   where
     (clas_tvs, fds) = classTvsFds clas
@@ -439,10 +441,19 @@ overlapErr dfun1 dfun2 = addInstErr (ptext SLIT("Overlapping instance declaratio
 fundepErr  dfun1 dfun2 = addInstErr (ptext SLIT("Functional dependencies conflict between instance declarations:")) 
 				    dfun1 dfun2
 
+addInstErr :: SDoc -> DFunId -> DFunId -> (SrcLoc, Message)
 addInstErr what dfun1 dfun2 
- = hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)
+ = (getSrcLoc dfun1, hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2))
   where
-    ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> pprClassPred clas tys
-		  where
-		    (_,_,clas,tys) = tcSplitDFunTy (idType dfun)
+   
+    ppr_dfun dfun = pp_loc <> colon <+> pprClassPred clas tys
+      where
+	(_,_,clas,tys) = tcSplitDFunTy (idType dfun)
+	loc = getSrcLoc dfun
+	mod = nameModule (idName dfun)
+	
+	-- Worth trying to print a good location... imported dfuns
+	-- don't have a useful SrcLoc but we can say which module they come from
+	pp_loc | isGoodSrcLoc loc = ppr loc
+	       | otherwise	  = ptext SLIT("In module") <+> ppr mod
 \end{code}