[project @ 2003-07-21 11:45:47 by simonmar]

[ghc-hetmet.git] / ghc / compiler / types / InstEnv.lhs

diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs
index 4f36597..73a6ce9 100644 (file)
--- 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}