X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstUtil.lhs;h=b41b4ea943956c0d29be82802c8dcc957b6a6690;hb=5cf27e8f1731c52fe63a5b9615f927484164c61b;hp=599d53f2affda92544efaba7eae59f35f8da66cf;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs
index 599d53f..b41b4ea 100644
--- a/ghc/compiler/typecheck/TcInstUtil.lhs
+++ b/ghc/compiler/typecheck/TcInstUtil.lhs
@@ -20,7 +20,7 @@ import HsSyn		( MonoBinds, Fake, InPat, Sig )
 import RnHsSyn		( RenamedMonoBinds(..), RenamedSig(..), 
 			  RenamedInstancePragmas(..) )
 
-import TcMonad
+import TcMonad		hiding ( rnMtoTcM )
 import Inst		( InstanceMapper(..) )
 
 import Bag		( bagToList )
@@ -30,7 +30,7 @@ import CoreSyn		( GenCoreExpr(..), mkValLam, mkTyApp )
 import Id		( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
 import MatchEnv		( nullMEnv, insertMEnv )
 import Maybes		( MaybeErr(..), mkLookupFunDef )
-import Name		( getSrcLoc )
+import Name		( getSrcLoc, Name{--O only-} )
 import PprType		( GenClass, GenType, GenTyVar )
 import Pretty
 import SpecEnv		( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
@@ -41,7 +41,6 @@ import TyVar		( GenTyVar )
 import Unique		( Unique )
 import Util		( equivClasses, zipWithEqual, panic )
 
-
 import IdInfo		( noIdInfo )
 --import TcPragmas	( tcDictFunPragmas, tcGenPragmas )
 \end{code}
@@ -77,6 +76,7 @@ data InstInfo
 
 \begin{code}
 mkInstanceRelatedIds :: Bool
+		     -> SrcLoc
 		     -> Maybe Module
                      -> RenamedInstancePragmas
 		     -> Class 
@@ -86,7 +86,7 @@ mkInstanceRelatedIds :: Bool
 		     -> [RenamedSig]
 		     -> TcM s (Id, ThetaType, [Id])
 
-mkInstanceRelatedIds from_here inst_mod inst_pragmas
+mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
 		     clas inst_tyvars inst_ty inst_decl_theta uprags
   = 	-- MAKE THE DFUN ID
     let
@@ -114,7 +114,7 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas
 -}
 	let dfun_id_info = noIdInfo in	-- For now
 
-	returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here inst_mod dfun_id_info)
+	returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here src_loc inst_mod dfun_id_info)
     ) `thenTc` \ dfun_id ->
 
 	-- MAKE THE CONSTANT-METHOD IDS
@@ -131,7 +131,7 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas
     (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas
     tenv = [(class_tyvar, inst_ty)]
   
-    super_class_theta = super_classes `zip` (repeat inst_ty)
+    super_class_theta = super_classes `zip` repeat inst_ty
 
     mk_const_meth_id op
 	= tcGetUnique		`thenNF_Tc` \ uniq ->
@@ -147,7 +147,7 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas
 	     let id_info = noIdInfo 	-- For now
 	     in
 	     returnTc (mkConstMethodId uniq clas op inst_ty meth_ty
-				       from_here inst_mod id_info)
+				       from_here src_loc inst_mod id_info)
 	  )
 	where
 	  op_ty       = classOpLocalType op
@@ -235,8 +235,8 @@ addClassInstance
 
 	-- Add the instance to the class's instance environment
     case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
-	Failed (ty', dfun_id')    -> failTc (dupInstErr clas (inst_ty, src_loc) 
-							     (ty', getSrcLoc dfun_id'));
+	Failed (ty', dfun_id')    -> dupInstFailure clas (inst_ty, src_loc) 
+							 (ty', getSrcLoc dfun_id');
 	Succeeded class_inst_env' -> 
 
 	-- If there are any constant methods, then add them to 
@@ -265,7 +265,7 @@ addClassInstance
 		-- a dictionary to be chucked away.
 
       op_spec_envs' | null const_meth_ids = op_spec_envs
-		    | otherwise		  = zipWithEqual add_const_meth op_spec_envs const_meth_ids
+		    | otherwise		  = zipWithEqual "add_const_meth" add_const_meth op_spec_envs const_meth_ids
 
       add_const_meth (op,spec_env) meth_id
         = (op, case addOneToSpecEnv spec_env (inst_ty : local_tyvar_tys) rhs of
@@ -283,13 +283,13 @@ addClassInstance
 \end{code}
 
 \begin{code}
-dupInstErr clas info1@(ty1, locn1) info2@(ty2, locn2) sty
+dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2)
 	-- Overlapping/duplicate instances for given class; msg could be more glamourous
-  = ppHang (ppBesides [ppStr "Duplicate/overlapping instances: class `", ppr sty clas, ppStr "'"])
-	 4 (showOverlap sty info1 info2)
-
-showOverlap sty (ty1,loc1) (ty2,loc2)
-  = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"],
-	   ppBesides [ppStr "at ", ppr sty loc1],
-	   ppBesides [ppStr "and ", ppr sty loc2]]
+  = tcAddErrCtxt ctxt $
+    failTc (\sty -> ppStr "Duplicate or overlapping instance declarations")
+  where
+    ctxt sty = ppHang (ppSep [ppBesides[ppStr "Class `", ppr sty clas, ppStr "'"],
+			      ppBesides[ppStr "type `", ppr sty ty1, ppStr "'"]])
+		    4 (ppSep [ppBesides [ppStr "at ", ppr sty locn1],
+		    	      ppBesides [ppStr "and ", ppr sty locn2]])
 \end{code}