X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcErrors.lhs;h=0ade93c29f0bb83e4324444e0eb62d7709cf5458;hb=a66541af84d102f32b73fb7f89f48008c01092a6;hp=9531a503e921bff14cf8ba6e3d2440f6acfcb00f;hpb=c1e6031c54cda2c6f9fc107eb6cb04ab490f1fef;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 9531a50..0ade93c 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -33,7 +33,7 @@ import Outputable
 import DynFlags
 import StaticFlags( opt_PprStyle_Debug )
 import Data.List( partition )
-import Control.Monad( unless )
+import Control.Monad( when, unless )
 \end{code}
 
 %************************************************************************
@@ -117,17 +117,28 @@ reportTidyImplic ctxt implic
   
 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
 reportTidyWanteds ctxt unsolved
-  = do { let (flats, implics) = splitWanteds unsolved
-             (ambigs, others) = partition is_ambiguous (bagToList flats)
-       ; groupErrs (reportFlat ctxt) others
-       ; mapBagM_ (reportTidyImplic ctxt) implics
-       ; ifErrsM (return ()) $
+  = do { let (flats,  implics)    = splitWanteds unsolved
+             (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
+       	     (tv_eqs, others)     = partition is_tv_eq non_ambigs
+
+       ; groupErrs (reportEqErrs ctxt) tv_eqs
+       ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
+       ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics
+
        	   -- Only report ambiguity if no other errors happened
 	   -- See Note [Avoiding spurious errors]
+       ; when (isEmptyBag implics && null non_ambigs) $
          reportAmbigErrs ctxt skols ambigs }
   where
     skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
  
+	-- Report equalities of form (a~ty) first.  They are usually
+	-- skolem-equalities, and they cause confusing knock-on 
+	-- effects in other errors; see test T4093b.
+    is_tv_eq c | EqPred ty1 ty2 <- wantedEvVarPred c
+               = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
+               | otherwise = False
+
 	-- Treat it as "ambiguous" if 
 	--   (a) it is a class constraint
         --   (b) it constrains only type variables
@@ -721,8 +732,8 @@ wrapEqErrTcS fl ty1 ty2 thing_inside
        ; wrapErrTcS $ setCtFlavorLoc fl $ 
     do {   -- Apply the current substitition
            -- and zonk to get rid of flatten-skolems
-       ; ty_binds_bag <- readTcRef ty_binds_var
-       ; let subst = mkOpenTvSubst (mkVarEnv (bagToList ty_binds_bag))
+       ; ty_binds_map <- readTcRef ty_binds_var
+       ; let subst = mkOpenTvSubst (mapVarEnv snd ty_binds_map)
        ; env0 <- tcInitTidyEnv 
        ; (env1, ty1) <- zonkSubstTidy env0 subst ty1
        ; (env2, ty2) <- zonkSubstTidy env1 subst ty2