X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=e864b05f42930e415b700a31f9bca452f9a2dc0f;hb=f670c47f9f93ffd6d06b331cd40554cd5e92484c;hp=11e202be9b3e57ecfa8e86a58ecfc16bb367eb78;hpb=9d0c8f842e35dde3d570580cf62a32779f66a6de;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 11e202b..e864b05 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -45,7 +45,6 @@ import Class
 import FunDeps
 import PrelInfo
 import PrelNames
-import Type
 import TysWiredIn
 import ErrUtils
 import BasicTypes
@@ -54,7 +53,6 @@ import VarEnv
 import FiniteMap
 import Bag
 import Outputable
-import Maybes
 import ListSetOps
 import Util
 import SrcLoc
@@ -1589,13 +1587,23 @@ Simpler, maybe, but alas not simple (see Trac #2494)
 tcSimplifyRuleLhs :: [Inst] -> TcM ([Inst], TcDictBinds)
 tcSimplifyRuleLhs wanteds
   = do	{ wanteds' <- zonkInsts wanteds
-	; (irreds, binds) <- go [] emptyBag wanteds'
+    	
+		-- Simplify equalities  
+		-- It's important to do this: Trac #3346 for example
+        ; (_, wanteds'', tybinds, binds1) <- tcReduceEqs [] wanteds'
+        ; execTcTyVarBinds tybinds
+
+	  	-- Simplify other constraints
+	; (irreds, binds2) <- go [] emptyBag wanteds''
+
+	  	-- Report anything that is left
 	; let (dicts, bad_irreds) = partition isDict irreds
 	; traceTc (text "tcSimplifyrulelhs" <+> pprInsts bad_irreds)
 	; addNoInstanceErrs (nub bad_irreds)
 		-- The nub removes duplicates, which has
 		-- not happened otherwise (see notes above)
-	; return (dicts, binds) }
+
+	; return (dicts, binds1 `unionBags` binds2) }
   where
     go :: [Inst] -> TcDictBinds -> [Inst] -> TcM ([Inst], TcDictBinds)
     go irreds binds []
@@ -3099,7 +3107,7 @@ groupErrs report_err (inst:insts)
    (friends, others) = partition is_friend insts
    loc_msg	     = showSDoc (pprInstLoc (instLoc inst))
    is_friend friend  = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
-   do_one insts = addInstCtxt (instLoc (head insts)) (report_err insts)
+   do_one insts = setInstCtxt (instLoc (head insts)) (report_err insts)
 		-- Add location and context information derived from the Insts
 
 -- Add the "arising from..." part to a message about bunch of dicts
@@ -3308,7 +3316,7 @@ monomorphism_fix dflags
 warnDefault :: [(Inst, Class, Var)] -> Type -> TcM ()
 warnDefault ups default_ty = do
     warn_flag <- doptM Opt_WarnTypeDefaults
-    addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
+    setInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
   where
     dicts = [d | (d,_,_) <- ups]