-setCtFlavorLoc (Wanted loc) thing = setWantedLoc loc thing
-setCtFlavorLoc (Derived loc) thing = setWantedLoc loc thing
-setCtFlavorLoc (Given loc) thing = setGivenLoc loc thing
-
-setWantedLoc :: WantedLoc -> TcM a -> TcM a
-setWantedLoc loc thing_inside
- = setCtLoc loc $
- add_origin (ctLocOrigin loc) $
- thing_inside
- where
- add_origin (TypeEqOrigin item) = addErrCtxtM (unifyCtxt item)
- add_origin orig = addErrCtxt (ptext (sLit "At") <+> ppr orig)
-
-setGivenLoc :: GivenLoc -> TcM a -> TcM a
-setGivenLoc loc thing_inside
- = setCtLoc loc $
- add_origin (ctLocOrigin loc) $
- thing_inside
- where
- add_origin skol = addErrCtxt (ptext (sLit "In") <+> pprSkolInfo skol)
+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 -> SDoc -> TcM a)
+ -> TcS a
+wrapEqErrTcS fl ty1 ty2 thing_inside
+ = do { ty_binds_var <- getTcSTyBinds
+ ; wrapErrTcS $ setCtFlavorLoc fl $
+ do { env0 <- tcInitTidyEnv
+ ; ty_binds_bag <- readTcRef ty_binds_var
+ ; let subst = mkOpenTvSubst (mkVarEnv (bagToList ty_binds_bag))
+ ; case fl of
+ Wanted loc -> getWantedEqExtra subst env0 (ctLocOrigin loc) ty1 ty2 thing_inside
+ Derived loc -> getWantedEqExtra subst env0 (ctLocOrigin loc) ty1 ty2 thing_inside
+ Given {} -> thing_inside env0 empty -- We could print more info, but it
+ -- seems to be coming out already
+ } }
+
+getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
+ -> (TidyEnv -> SDoc -> TcM a)
+ -> TcM a
+getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2 thing_inside
+ -- If the types in the error message are the same
+ -- as the types we are unifying (remember to zonk the latter)
+ -- don't add the extra expected/actual message
+ --
+ -- The complication is that the types in the TypeEqOrigin must
+ -- (a) be zonked
+ -- (b) have any TcS-monad pending equalities applied to them
+ -- (hence the passed-in substitution)
+ = do { act0 <- zonkTcType (uo_actual item)
+ ; exp0 <- zonkTcType (uo_expected item)
+ ; let act1 = substTy subst act0
+ exp1 = substTy subst exp0
+ (env1, exp2) = tidyOpenType env0 exp1
+ (env2, act2) = tidyOpenType env1 act1
+ ; if (act1 `tcEqType` ty1 && exp1 `tcEqType` ty2)
+ || (exp1 `tcEqType` ty1 && act1 `tcEqType` ty2)
+ then
+ thing_inside env0 empty
+ else
+ thing_inside env2 (mkExpectedActualMsg act2 exp2) }
+
+getWantedEqExtra _ env0 orig _ _ thing_inside
+ = thing_inside env0 (pprArising orig)