X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcErrors.lhs;h=572f82cb4422452da0b2d1f7278446f806d1e1bb;hp=1254dd6aae252a61eac33231c3ed9f99502b820a;hb=8657bb00544468adc7ad63e962af71674c3b4500;hpb=98bbd9b2bf02496f9fc21f1f443f315292a6ce5f

diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 1254dd6..572f82c 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -644,7 +644,7 @@ warnDefaulting wanteds default_ty
 %************************************************************************
 
 \begin{code}
-kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
+kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 -- If there's a kind error, we don't want to blindly say "kind error"
 -- We might, say, be unifying a skolem 'a' with a type 'Int', 
 -- in which case that's the error to report.  So we set things
@@ -654,7 +654,9 @@ kindErrorTcS fl ty1 ty2
     do { let ctxt = CEC { cec_encl = []
                         , cec_extra = extra
                         , cec_tidy = env0 }
-       ; reportEqErr ctxt ty1 ty2 }
+       ; reportEqErr ctxt ty1 ty2 
+       ; failM
+       }
 
 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 misMatchErrorTcS fl ty1 ty2
@@ -719,9 +721,9 @@ flattenForAllErrorTcS fl ty _bad_eqs
 
 \begin{code}
 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
+setCtFlavorLoc (Given   loc)   thing = setCtLoc loc thing
 
 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
              -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
@@ -740,10 +742,10 @@ wrapEqErrTcS fl ty1 ty2 thing_inside
                                                      (ctLocOrigin loc) ty1 ty2
                                 ; thing_inside env3 ty1 ty2 extra } 
        ; case fl of
-           Wanted  loc -> do_wanted loc
-           Derived loc -> do_wanted loc
-           Given {}    -> thing_inside env2 ty1 ty2 empty 
-	   	       	  	 -- We could print more info, but it
+           Wanted  loc   -> do_wanted loc
+           Derived loc _ -> do_wanted loc
+           Given {}      -> thing_inside env2 ty1 ty2 empty 
+	   	       	    	 -- We could print more info, but it
                                  -- seems to be coming out already
        } }  
   where