Fix Trac #3346: tcSimplify for LHS of RULES with type equalities

[ghc-hetmet.git] / compiler / typecheck / TcSimplify.lhs

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index cd3da49..8632895 100644 (file)
--- 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 []
@@ -1637,7 +1645,7 @@ this bracket again at its usage site.
 \begin{code}
 tcSimplifyBracket :: [Inst] -> TcM ()
 tcSimplifyBracket wanteds
-  = do { tryHardCheckLoop doc wanteds
+  = do { _ <- tryHardCheckLoop doc wanteds
        ; return () }
   where
     doc = text "tcSimplifyBracket"
@@ -2856,6 +2864,7 @@ disambiguate doc interactive dflags insts
 
   where
    extended_defaulting = interactive || dopt Opt_ExtendedDefaultRules dflags
+                      -- See also Trac #1974
    ovl_strings = dopt Opt_OverloadedStrings dflags
 
    unaries :: [(Inst, Class, TcTyVar)]  -- (C tv) constraints
@@ -2902,12 +2911,16 @@ disambigGroup :: [Type]                 -- The default types
              -> TcM () -- Just does unification, to fix the default types
 
 disambigGroup default_tys dicts
-  = try_default default_tys
+  = do { mb_chosen_ty <- try_default default_tys
+       ; case mb_chosen_ty of
+            Nothing        -> return ()
+            Just chosen_ty -> do { _ <- unifyType chosen_ty (mkTyVarTy tyvar) 
+                                ; warnDefault dicts chosen_ty } }
   where
     (_,_,tyvar) = ASSERT(not (null dicts)) head dicts  -- Should be non-empty
     classes = [c | (_,c,_) <- dicts]
 
-    try_default [] = return ()
+    try_default [] = return Nothing
     try_default (default_ty : default_tys)
       = tryTcLIE_ (try_default default_tys) $
        do { tcSimplifyDefault [mkClassPred clas [default_ty] | clas <- classes]
@@ -2917,10 +2930,7 @@ disambigGroup default_tys dicts
                -- For example, if Real a is reqd, but the only type in the
                -- default list is Int.
 
-               -- After this we can't fail
-          ; warnDefault dicts default_ty
-          ; unifyType default_ty (mkTyVarTy tyvar) 
-          ; return () -- TOMDO: do something with the coercion
+          ; return (Just default_ty) -- TOMDO: do something with the coercion
           }