+
+%************************************************************************
+%* *
+ Setting the context
+%* *
+%************************************************************************
+
+\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
+
+wrapEqErrTcS :: CtFlavor -> TcType -> TcType
+ -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
+ -> TcS a
+wrapEqErrTcS fl ty1 ty2 thing_inside
+ = do { ty_binds_var <- getTcSTyBinds
+ ; wrapErrTcS $ setCtFlavorLoc fl $
+ do { -- Apply the current substitition
+ -- and zonk to get rid of flatten-skolems
+ ; 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
+ ; let do_wanted loc = do { (env3, extra) <- getWantedEqExtra subst env2
+ (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
+ -- seems to be coming out already
+ } }
+ where
+
+getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
+ -> TcM (TidyEnv, SDoc)
+getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
+ -- 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 { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
+ ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
+ ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
+ || (exp `tcEqType` ty1 && act `tcEqType` ty2)
+ then
+ return (env0, empty)
+ else
+ return (env2, mkExpectedActualMsg act exp) }
+
+getWantedEqExtra _ env0 orig _ _
+ = return (env0, pprArising orig)
+
+zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
+-- In general, becore printing a type, we want to
+-- a) Zonk it. Even during constraint simplification this is
+-- is important, to un-flatten the flatten skolems in a type
+-- b) Substitute any solved unification variables. This is
+-- only important *during* solving, becuase after solving
+-- the substitution is expressed in the mutable type variables
+-- But during solving there may be constraint (F xi ~ ty)
+-- where the substitution has not been applied to the RHS
+zonkSubstTidy env subst ty
+ = do { ty' <- zonkTcTypeAndSubst subst ty
+ ; return (tidyOpenType env ty') }
+\end{code}