X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcUnify.lhs;h=04e9379e7c0b64d9887197d80774e762f6d22dfd;hb=2e68d0410f319a99f3f36c5e9d9be656ca10dc70;hp=af7463d198f6841d18867d1d2812bb2b538fb698;hpb=7a59d519f4d754d025fbc92e0be902932c4e5ea1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index af7463d..04e9379 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -200,7 +200,10 @@ subFunTys error_herald n_pats res_ty thing_inside
       = do { arg_tys <- newFlexiTyVarTys n argTypeKind
            ; res_ty' <- newFlexiTyVarTy openTypeKind
            ; let fun_ty = mkFunTys arg_tys res_ty'
-           ; coi <- defer_unification False False fun_ty ty
+                 err    = error_herald <> comma $$
+                          text "which does not match its type"
+           ; coi <- addErrCtxt err $
+                      defer_unification False False fun_ty ty
            ; res <- thing_inside (reverse args_so_far ++ arg_tys) res_ty'
            ; return (coiToHsWrapper coi, res)
            }
@@ -1750,13 +1753,9 @@ unifyForAllCtxt tvs phi1 phi2 env
 
 -----------------------
 unifyMisMatch outer swapped ty1 ty2
-  = do	{ (env, msg) <- if swapped then misMatchMsg ty2 ty1
-				   else misMatchMsg ty1 ty2
-
-	-- This is the whole point of the 'outer' stuff
-	; if outer then popErrCtxt (failWithTcM (env, msg))
-	  	   else failWithTcM (env, msg)
-	} 
+  | swapped   = unifyMisMatch outer False ty2 ty1
+  | outer     = popErrCtxt $ unifyMisMatch False swapped ty1 ty2  -- This is the whole point of the 'outer' stuff
+  | otherwise = failWithMisMatch ty1 ty2
 \end{code}