X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcErrors.lhs;h=db2165976b3d337c754420c648dd4a07e2619502;hb=e4b5abb6ddfd07a7f95455c94faf2946a1bc078e;hp=437815d4e1dfbe469337d1c7334841d6540e56c2;hpb=7966f85171e278ff415d48545212107cfbc984cb;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 437815d..db21659 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -158,7 +158,7 @@ reportTidyWanteds ctxt unsolved reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () reportFlat ctxt flats origin = do { unless (null dicts) $ reportDictErrs ctxt dicts origin - ; unless (null eqs) $ reportEqErrs ctxt eqs + ; unless (null eqs) $ reportEqErrs ctxt eqs origin ; unless (null ips) $ reportIPErrs ctxt ips origin ; ASSERT( null others ) return () } where @@ -277,12 +277,18 @@ reportIPErrs ctxt ips orig %************************************************************************ \begin{code} -reportEqErrs :: ReportErrCtxt -> [PredType] -> TcM () -reportEqErrs ctxt eqs +reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +reportEqErrs ctxt eqs orig = mapM_ report_one eqs where - report_one (EqPred ty1 ty2) = reportEqErr ctxt ty1 ty2 - report_one pred = pprPanic "reportEqErrs" (ppr pred) + env0 = cec_tidy ctxt + report_one (EqPred 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) reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM () reportEqErr ctxt ty1 ty2 @@ -554,7 +560,7 @@ monomorphism_fix :: DynFlags -> SDoc monomorphism_fix dflags = ptext (sLit "Probable fix:") <+> vcat [ptext (sLit "give these definition(s) an explicit type signature"), - if dopt Opt_MonomorphismRestriction dflags + if xopt Opt_MonomorphismRestriction dflags then ptext (sLit "or use -XNoMonomorphismRestriction") else empty] -- Only suggest adding "-XNoMonomorphismRestriction" -- if it is not already set! @@ -650,10 +656,8 @@ 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, extra) <- getEqExtra fl ty1 ty2 - ; let (env1, ty1') = tidyOpenType env0 ty1 + = 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 @@ -662,10 +666,8 @@ kindErrorTcS fl ty1 ty2 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a misMatchErrorTcS fl ty1 ty2 - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { (env0, extra) <- getEqExtra fl ty1 ty2 - ; 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' ; failWithTcM (env3, inaccessible_msg $$ msg $$ extra) } @@ -684,10 +686,8 @@ misMatchErrorTcS fl ty1 ty2 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a occursCheckErrorTcS fl tv ty - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { (env0, extra2) <- getEqExtra fl (mkTyVarTy tv) ty - ; 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'] ; failWithTcM (env2, hang msg 2 (extra1 $$ extra2)) } @@ -735,31 +735,47 @@ setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing setCtFlavorLoc (Given loc) thing = setCtLoc loc thing -getEqExtra :: CtFlavor -> TcType -> TcType -> TcM (TidyEnv, SDoc) -getEqExtra (Wanted loc) ty1 ty2 = getWantedEqExtra (ctLocOrigin loc) ty1 ty2 -getEqExtra (Derived loc) ty1 ty2 = getWantedEqExtra (ctLocOrigin loc) ty1 ty2 -getEqExtra (Given _) _ _ = do { env0 <- tcInitTidyEnv - ; return (env0, empty) } - -- We could print more info, but it seems to be already coming out - -getWantedEqExtra :: CtOrigin -> TcType -> TcType -> TcM (TidyEnv, SDoc) -getWantedEqExtra (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) - ; env0 <- tcInitTidyEnv - ; 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 orig _ _ - = do { env0 <- tcInitTidyEnv - ; return (env0, pprArising orig) } +getWantedEqExtra _ env0 orig _ _ thing_inside + = thing_inside env0 (pprArising orig) \end{code}