From 73855b2d99dfb60b89c057f43ab313b243cfc574 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 17 Sep 2010 12:12:06 +0000 Subject: [PATCH] Yet more error message improvement --- compiler/typecheck/TcErrors.lhs | 95 ++++++++++++++++++++++----------------- compiler/typecheck/TcSMonad.lhs | 2 +- 2 files changed, 54 insertions(+), 43 deletions(-) diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index c30d702..30a0530 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -281,11 +281,12 @@ reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () reportEqErrs ctxt eqs orig = mapM_ report_one eqs where + env0 = cec_tidy ctxt report_one (EqPred ty1 ty2) - = do { (env1, extra) <- getWantedEqExtra (cec_tidy ctxt) orig ty1 ty2 - ; let ctxt' = ctxt { cec_tidy = env1 - , cec_extra = cec_extra ctxt $$ extra } - ; reportEqErr ctxt' ty1 ty2 } + = getWantedEqExtra emptyTvSubst env0 orig ty1 ty2 $ \ env1 extra -> + let ctxt' = ctxt { cec_tidy = env1 + , cec_extra = cec_extra ctxt $$ extra } + in reportEqErr ctxt' ty1 ty2 report_one pred = pprPanic "reportEqErrs" (ppr pred) @@ -655,27 +656,21 @@ kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS () -- in which case that's the error to report. So we set things -- up to call reportEqErr, which does the business properly kindErrorTcS fl ty1 ty2 - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { env0 <- tcInitTidyEnv - ; (env1, extra) <- getEqExtra env0 fl ty1 ty2 - ; let (env2, ty1') = tidyOpenType env1 ty1 - (env3, ty2') = tidyOpenType env2 ty2 + = wrapEqErrTcS fl ty1 ty2 $ \ env0 extra -> + do { let (env1, ty1') = tidyOpenType env0 ty1 + (env2, ty2') = tidyOpenType env1 ty2 ctxt = CEC { cec_encl = [] , cec_extra = extra - , cec_tidy = env3 } + , cec_tidy = env2 } ; reportEqErr ctxt ty1' ty2' } misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a misMatchErrorTcS fl ty1 ty2 - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { env0 <- tcInitTidyEnv - ; let (env1, ty1') = tidyOpenType env0 ty1 + = wrapEqErrTcS fl ty1 ty2 $ \ env0 extra -> + do { let (env1, ty1') = tidyOpenType env0 ty1 (env2, ty2') = tidyOpenType env1 ty2 (env3, msg) = misMatchMsgWithExtras env2 ty1' ty2' - ; (env4, extra) <- getEqExtra env3 fl ty1 ty2 - ; failWithTcM (env4, inaccessible_msg $$ msg $$ extra) } + ; failWithTcM (env3, inaccessible_msg $$ msg $$ extra) } where inaccessible_msg = case fl of @@ -691,14 +686,11 @@ misMatchErrorTcS fl ty1 ty2 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a occursCheckErrorTcS fl tv ty - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { env0 <- tcInitTidyEnv - ; let (env1, tv') = tidyOpenTyVar env0 tv + = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 extra2 -> + do { let (env1, tv') = tidyOpenTyVar env0 tv (env2, ty') = tidyOpenType env1 ty extra1 = sep [ppr tv', char '=', ppr ty'] - ; (env3, extra2) <- getEqExtra env2 fl (mkTyVarTy tv) ty - ; failWithTcM (env3, hang msg 2 (extra1 $$ extra2)) } + ; failWithTcM (env2, hang msg 2 (extra1 $$ extra2)) } where msg = text $ "Occurs check: cannot construct the infinite type:" @@ -743,28 +735,47 @@ setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing setCtFlavorLoc (Given loc) thing = setCtLoc loc thing -getEqExtra :: TidyEnv -> CtFlavor -> TcType -> TcType -> TcM (TidyEnv, SDoc) -getEqExtra env (Wanted loc) ty1 ty2 = getWantedEqExtra env (ctLocOrigin loc) ty1 ty2 -getEqExtra env (Derived loc) ty1 ty2 = getWantedEqExtra env (ctLocOrigin loc) ty1 ty2 -getEqExtra env (Given _) _ _ = return (env, empty) - -- We could print more info, but it seems to be already coming out - -getWantedEqExtra :: TidyEnv -> CtOrigin -> TcType -> TcType -> TcM (TidyEnv, SDoc) -getWantedEqExtra env0 (TypeEqOrigin item) ty1 ty2 +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 - = do { act <- zonkTcType (uo_actual item) - ; exp <- zonkTcType (uo_expected item) - ; if (act `tcEqType` ty1 && exp `tcEqType` ty2) - || (exp `tcEqType` ty1 && act `tcEqType` ty2) + -- + -- 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 - return (env0, empty) - else do - { let (env1, exp') = tidyOpenType env0 exp - (env2, act') = tidyOpenType env1 act - ; return (env2, mkExpectedActualMsg act' exp') } } + thing_inside env0 empty + else + thing_inside env2 (mkExpectedActualMsg act2 exp2) } -getWantedEqExtra env0 orig _ _ - = return (env0, pprArising orig) +getWantedEqExtra _ env0 orig _ _ thing_inside + = thing_inside env0 (pprArising orig) \end{code} diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 2524afc..d77b0c2 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -31,7 +31,7 @@ module TcSMonad ( getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS, - getTcEvBindsBag, getTcSContext, + getTcEvBindsBag, getTcSContext, getTcSTyBinds, newFlattenSkolemTy, -- Flatten skolems -- 1.7.10.4