X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcErrors.lhs;h=645c43af6d0c39242802001255617c96e5143181;hp=533520fc8600bb9b65ae4c782944d47a945a7b71;hb=35a1ec430a5e44a9bc79d385b997422c20cb427b;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 533520f..645c43a 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1,9 +1,11 @@ \begin{code} module TcErrors( - reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv, - reportUnsolvedWantedEvVars, warnDefaulting, typeExtraInfoMsg, - kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS, - occursCheckErrorTcS, solverDepthErrorTcS + reportUnsolved, + warnDefaulting, + unifyCtxt, + + flattenForAllErrorTcS, + solverDepthErrorTcS ) where #include "HsVersions.h" @@ -12,6 +14,9 @@ import TcRnMonad import TcMType import TcSMonad import TcType +import TypeRep +import Type( isTyVarTy ) + import Inst import InstEnv @@ -19,7 +24,6 @@ import TyCon import Name import NameEnv import Id ( idType ) -import HsExpr ( pprMatchContext ) import Var import VarSet import VarEnv @@ -27,13 +31,12 @@ import SrcLoc import Bag import ListSetOps( equivClasses ) import Util -import Unique import FastString import Outputable import DynFlags import StaticFlags( opt_PprStyle_Debug ) import Data.List( partition ) -import Control.Monad( unless ) +import Control.Monad( when, unless ) \end{code} %************************************************************************ @@ -47,102 +50,91 @@ from the insts, or just whatever seems to be around in the monad just now? \begin{code} -reportUnsolved :: (CanonicalCts, Bag Implication) -> TcM () -reportUnsolved (unsolved_flats, unsolved_implics) - | isEmptyBag unsolved +reportUnsolved :: WantedConstraints -> TcM () +reportUnsolved wanted + | isEmptyWC wanted = return () | otherwise - = do { env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved) - tidy_unsolved = tidyWanteds tidy_env unsolved - err_ctxt = CEC { cec_encl = [] + = do { -- Zonk to un-flatten any flatten-skols + ; wanted <- zonkWC wanted + + ; env0 <- tcInitTidyEnv + ; let tidy_env = tidyFreeTyVars env0 free_tvs + free_tvs = tyVarsOfWC wanted + err_ctxt = CEC { cec_encl = [] + , cec_insol = insolubleWC wanted , cec_extra = empty - , cec_tidy = tidy_env } - ; traceTc "reportUnsolved" (ppr unsolved) - ; reportTidyWanteds err_ctxt tidy_unsolved } - where - unsolved = mkWantedConstraints unsolved_flats unsolved_implics + , cec_tidy = tidy_env } + tidy_wanted = tidyWC tidy_env wanted -reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM () -reportUnsolvedWantedEvVars wanteds - | isEmptyBag wanteds - = return () - | otherwise - = do { env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds) - tidy_unsolved = tidyWantedEvVars tidy_env wanteds - err_ctxt = CEC { cec_encl = [] - , cec_extra = empty - , cec_tidy = tidy_env } - ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) } + ; traceTc "reportUnsolved" (ppr tidy_wanted) -reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM () -reportUnsolvedDeriv unsolved loc - | null unsolved - = return () - | otherwise - = do { env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfTheta unsolved) - tidy_unsolved = map (tidyPred tidy_env) unsolved - err_ctxt = CEC { cec_encl = [] - , cec_extra = alt_fix - , cec_tidy = tidy_env } - ; reportFlat err_ctxt tidy_unsolved loc } - where - alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"), - nest 2 $ ptext (sLit "so you can specify the instance context yourself")] - -reportUnsolvedImplication :: Implication -> TcM () -reportUnsolvedImplication implic - = do { env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfImplication implic) - tidy_implic = tidyImplication tidy_env implic - new_tidy_env = foldNameEnv add tidy_env (ic_env implic) - err_ctxt = CEC { cec_encl = [tidy_implic] - , cec_extra = empty - , cec_tidy = new_tidy_env } - ; reportTidyWanteds err_ctxt (ic_wanted tidy_implic) } - where - -- Extend the tidy env with a mapping from tyvars to the - -- names the user originally used. At the moment we do this - -- from the type env, but it might be better to record the - -- scoped type variable in the Implication. Urgh. - add (ATyVar name ty) (occ_env, var_env) - | Just tv <- tcGetTyVar_maybe ty - , not (getUnique name `elemVarEnvByKey` var_env) - = case tidyOccName occ_env (nameOccName name) of - (occ_env', occ') -> (occ_env', extendVarEnv var_env tv tv') - where - tv' = setTyVarName tv name' - name' = tidyNameOcc name occ' - add _ tidy_env = tidy_env + ; reportTidyWanteds err_ctxt tidy_wanted } + +-------------------------------------------- +-- Internal functions +-------------------------------------------- data ReportErrCtxt = CEC { cec_encl :: [Implication] -- Enclosing implications -- (innermost first) - , cec_tidy :: TidyEnv - , cec_extra :: SDoc -- Add this to each error message + , cec_tidy :: TidyEnv + , cec_extra :: SDoc -- Add this to each error message + , cec_insol :: Bool -- True <=> we are reporting insoluble errors only + -- Main effect: don't say "Cannot deduce..." + -- when reporting equality errors; see misMatchOrCND } reportTidyImplic :: ReportErrCtxt -> Implication -> TcM () reportTidyImplic ctxt implic + | BracketSkol <- ctLocOrigin (ic_loc implic) + , not insoluble -- For Template Haskell brackets report only + = return () -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints + + | otherwise = reportTidyWanteds ctxt' (ic_wanted implic) where - ctxt' = ctxt { cec_encl = implic : cec_encl ctxt } - + insoluble = ic_insol implic + ctxt' = ctxt { cec_encl = implic : cec_encl ctxt + , cec_insol = insoluble } + reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () -reportTidyWanteds ctxt unsolved - = do { let (flats, implics) = splitWanteds unsolved - (ambigs, others) = partition is_ambiguous (bagToList flats) - ; groupErrs (reportFlat ctxt) others +reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) + | cec_insol ctxt -- If there are any insolubles, report only them + -- because they are unconditionally wrong + -- Moreover, if any of the insolubles are givens, stop right there + -- ignoring nested errors, because the code is inaccessible + = do { let (given, other) = partitionBag (isGiven . evVarX) insols + insol_implics = filterBag ic_insol implics + ; if isEmptyBag given + then do { mapBagM_ (reportInsoluble ctxt) other + ; mapBagM_ (reportTidyImplic ctxt) insol_implics } + else mapBagM_ (reportInsoluble ctxt) given } + + | otherwise -- No insoluble ones + = ASSERT( isEmptyBag insols ) + do { let (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats) + (tv_eqs, others) = partition is_tv_eq non_ambigs + + ; groupErrs (reportEqErrs ctxt) tv_eqs + ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others ; mapBagM_ (reportTidyImplic ctxt) implics - ; ifErrsM (return ()) $ - -- Only report ambiguity if no other errors happened - -- See Note [Avoiding spurious errors] - reportAmbigErrs ctxt skols ambigs } + + -- Only report ambiguity if no other errors (at all) happened + -- See Note [Avoiding spurious errors] in TcSimplify + ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs } where skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt) + -- Report equalities of form (a~ty) first. They are usually + -- skolem-equalities, and they cause confusing knock-on + -- effects in other errors; see test T4093b. + is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c + = tcIsTyVarTy ty1 || tcIsTyVarTy ty2 + | otherwise = False + -- Treat it as "ambiguous" if -- (a) it is a class constraint -- (b) it constrains only type variables @@ -151,13 +143,28 @@ reportTidyWanteds ctxt unsolved is_ambiguous d = isTyVarClassPred pred && not (tyVarsOfPred pred `subVarSet` skols) where - pred = wantedEvVarPred d - -reportFlat :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM () -reportFlat ctxt flats loc - = do { unless (null dicts) $ reportDictErrs ctxt dicts loc - ; unless (null eqs) $ reportEqErrs ctxt eqs loc - ; unless (null ips) $ reportIPErrs ctxt ips loc + pred = evVarOfPred d + +reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM () +reportInsoluble ctxt (EvVarX ev flav) + | EqPred ty1 ty2 <- evVarPred ev + = setCtFlavorLoc flav $ + do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg } + ; reportEqErr ctxt2 ty1 ty2 } + | otherwise + = pprPanic "reportInsoluble" (pprEvVarWithType ev) + where + inaccessible_msg | Given loc <- flav + = hang (ptext (sLit "Inaccessible code in")) + 2 (ppr (ctLocOrigin loc)) + | otherwise = empty + +reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +-- The [PredType] are already tidied +reportFlat ctxt flats origin + = do { unless (null dicts) $ reportDictErrs ctxt dicts origin + ; unless (null eqs) $ reportEqErrs ctxt eqs origin + ; unless (null ips) $ reportIPErrs ctxt ips origin ; ASSERT( null others ) return () } where (dicts, non_dicts) = partition isClassPred flats @@ -168,8 +175,8 @@ reportFlat ctxt flats loc -- Support code -------------------------------------------- -groupErrs :: ([PredType] -> WantedLoc -> TcM ()) -- Deal with one group - -> [WantedEvVar] -- Unsolved wanteds +groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group + -> [WantedEvVar] -- Unsolved wanteds -> TcM () -- Group together insts with the same origin -- We want to report them together in error messages @@ -177,39 +184,45 @@ groupErrs :: ([PredType] -> WantedLoc -> TcM ()) -- Deal with one group groupErrs _ [] = return () groupErrs report_err (wanted : wanteds) - = do { setCtLoc the_loc $ report_err the_vars the_loc + = do { setCtLoc the_loc $ + report_err the_vars (ctLocOrigin the_loc) ; groupErrs report_err others } where - the_loc = wantedEvVarLoc wanted + the_loc = evVarX wanted the_key = mk_key the_loc - the_vars = map wantedEvVarPred (wanted:friends) + the_vars = map evVarOfPred (wanted:friends) (friends, others) = partition is_friend wanteds - is_friend friend = mk_key (wantedEvVarLoc friend) == the_key + is_friend friend = mk_key (evVarX friend) `same_key` the_key + + mk_key :: WantedLoc -> (SrcSpan, CtOrigin) + mk_key loc = (ctLocSpan loc, ctLocOrigin loc) + + same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2 + same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2 + same_orig ScOrigin ScOrigin = True + same_orig DerivOrigin DerivOrigin = True + same_orig DefaultOrigin DefaultOrigin = True + same_orig _ _ = False - mk_key :: WantedLoc -> (SrcSpan, String) - mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc))) - -- It may seem crude to compare the error messages, - -- but it makes sure that we combine just what the user sees, - -- and it avoids need equality on InstLocs. -- Add the "arising from..." part to a message about bunch of dicts -addArising :: WantedLoc -> SDoc -> SDoc -addArising loc msg = msg $$ nest 2 (pprArising loc) +addArising :: CtOrigin -> SDoc -> SDoc +addArising orig msg = msg $$ nest 2 (pprArising orig) pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc) -- Print something like -- (Eq a) arising from a use of x at y --- (Show a) arising froma use of p at q --- Also return a location for the erroe message +-- (Show a) arising from a use of p at q +-- Also return a location for the error message pprWithArising [] = panic "pprWithArising" -pprWithArising [WantedEvVar ev loc] - = (loc, pprEvVarTheta [ev] <+> pprArising loc) +pprWithArising [EvVarX ev loc] + = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc)) pprWithArising ev_vars = (first_loc, vcat (map ppr_one ev_vars)) where - first_loc = wantedEvVarLoc (head ev_vars) - ppr_one (WantedEvVar v loc) + first_loc = evVarX (head ev_vars) + ppr_one (EvVarX v loc) = parens (pprPred (evVarPred v)) <+> pprArisingAt loc addErrorReport :: ReportErrCtxt -> SDoc -> TcM () @@ -223,28 +236,21 @@ pprErrCtxtLoc ctxt vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ] where ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc) - ppr_skol skol_info = pprSkolInfo skol_info - -couldNotDeduce :: [EvVar] -> [PredType] -> SDoc -couldNotDeduce givens wanteds - = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds - , nest 2 $ ptext (sLit "from the context") - <+> pprEvVarTheta givens] + ppr_skol skol_info = ppr skol_info -getUserGivens :: ReportErrCtxt -> Maybe [EvVar] --- Just gs => Say "could not deduce ... from gs" --- Nothing => No interesting givens, say something else +getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)] +-- One item for each enclosing implication getUserGivens (CEC {cec_encl = ctxt}) - | null user_givens = Nothing - | otherwise = Just user_givens - where - givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt - user_givens | opt_PprStyle_Debug = givens - | otherwise = filterOut isSelfDict givens - -- In user mode, don't show the "self-dict" given - -- which is only added to do co-inductive solving - -- Rather an awkward hack, but there we are - -- This is the only use of isSelfDict, so it's not in an inner loop + = reverse $ + [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt + , let givens' = get_user_givens givens + , not (null givens') ] + where + get_user_givens givens | opt_PprStyle_Debug = givens + | otherwise = filterOut isSilentEvVar givens + -- In user mode, don't show the "silent" givens, used for + -- the "self" dictionary and silent superclass arguments for dfuns + \end{code} @@ -255,15 +261,17 @@ getUserGivens (CEC {cec_encl = ctxt}) %************************************************************************ \begin{code} -reportIPErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM () -reportIPErrs ctxt ips loc - = addErrorReport ctxt $ addArising loc msg +reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +reportIPErrs ctxt ips orig + = addErrorReport ctxt msg where - msg | Just givens <- getUserGivens ctxt - = couldNotDeduce givens ips - | otherwise - = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips + givens = getUserGivens ctxt + msg | null givens + = addArising orig $ + sep [ ptext (sLit "Unbound implicit parameter") <> plural ips , nest 2 (pprTheta ips) ] + | otherwise + = couldNotDeduce givens (ips, orig) \end{code} @@ -274,42 +282,62 @@ reportIPErrs ctxt ips loc %************************************************************************ \begin{code} -reportEqErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM () -reportEqErrs ctxt eqs loc = mapM_ (reportEqErr ctxt loc) eqs +reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +-- The [PredType] are already tidied +reportEqErrs ctxt eqs orig + = do { orig' <- zonkTidyOrigin ctxt orig + ; mapM_ (report_one orig') eqs } + where + report_one orig (EqPred ty1 ty2) + = do { let extra = getWantedEqExtra orig ty1 ty2 + ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt } + ; reportEqErr ctxt' ty1 ty2 } + report_one _ pred + = pprPanic "reportEqErrs" (ppr pred) + +getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc +getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) + ty1 ty2 + -- If the types in the error message are the same as the types we are unifying, + -- don't add the extra expected/actual message + | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty + | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty + | otherwise = mkExpectedActualMsg act exp + +getWantedEqExtra orig _ _ = pprArising orig + +reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM () +-- ty1 and ty2 are already tidied +reportEqErr ctxt ty1 ty2 + | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2 + | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1 -reportEqErr :: ReportErrCtxt -> WantedLoc -> PredType -> TcM () -reportEqErr ctxt loc pred@(EqPred ty1 ty2) - | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt loc tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt loc tv2 ty1 | otherwise -- Neither side is a type variable -- Since the unsolved constraint is canonical, -- it must therefore be of form (F tys ~ ty) - = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2) - where - msg = case getUserGivens ctxt of - Just givens -> couldNotDeduce givens [pred] - Nothing -> misMatchMsg ty1 ty2 - -reportEqErr _ _ _ = panic "reportEqErr" -- Must be equality pred + = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2) -reportTyVarEqErr :: ReportErrCtxt -> WantedLoc - -> TcTyVar -> TcType -> TcM () -reportTyVarEqErr ctxt loc tv1 ty2 - | not is_meta1 - , Just tv2 <- tcGetTyVar_maybe ty2 - , isMetaTyVar tv2 - = -- sk ~ alpha: swap - reportTyVarEqErr ctxt loc tv2 ty1 - | not is_meta1 - = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match - addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2) +reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM () +-- tv1 and ty2 are already tidied +reportTyVarEqErr ctxt tv1 ty2 + | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would + -- be oriented the other way round; see TcCanonical.reOrient + || isSigTyVar tv1 && not (isTyVarTy ty2) + = addErrorReport (addExtraInfo ctxt ty1 ty2) + (misMatchOrCND ctxt ty1 ty2) -- So tv is a meta tyvar, and presumably it is -- an *untouchable* meta tyvar, else it'd have been unified | not (k2 `isSubKind` k1) -- Kind error = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) + -- Occurs check + | tv1 `elemVarSet` tyVarsOfType ty2 + = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2 + (sep [ppr ty1, char '=', ppr ty2]) + in addErrorReport ctxt occCheckMsg + -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic) @@ -319,16 +347,17 @@ reportTyVarEqErr ctxt loc tv1 ty2 -- place the equality arose to the implication site do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1) ; let msg = misMatchMsg ty1 ty2 - esc_doc | isSingleton esc_skols - = ptext (sLit "because this skolem type variable would escape:") - | otherwise - = ptext (sLit "because these skolem type variables would escape:") - extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols + esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols + <+> pprQuotedList esc_skols + , ptext (sLit "would escape") <+> + if isSingleton esc_skols then ptext (sLit "its scope") + else ptext (sLit "their scope") ] + extra1 = vcat [ nest 2 $ esc_doc , sep [ (if isSingleton esc_skols - then ptext (sLit "This skolem is") - else ptext (sLit "These skolems are")) + then ptext (sLit "This (rigid, skolem) type variable is") + else ptext (sLit "These (rigid, skolem) type variables are")) <+> ptext (sLit "bound by") - , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ] + , nest 2 $ ppr (ctLocOrigin implic_loc) ] ] ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) } -- Nastiest case: attempt to unify an untouchable variable @@ -336,20 +365,33 @@ reportTyVarEqErr ctxt loc tv1 ty2 , let implic_loc = ic_loc implic given = ic_given implic = setCtLoc (ic_loc implic) $ - do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2 - extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable") - , ptext (sLit "inside the constraints") <+> pprEvVarTheta given - , nest 2 (ptext (sLit "bound at") - <+> pprSkolInfo (ctLocOrigin implic_loc)) ] - ; addErrTcM (env1, msg $$ extra) } - - | otherwise -- I'm not sure how this can happen! - = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2) + do { let msg = misMatchMsg ty1 ty2 + extra = quotes (ppr tv1) + <+> sep [ ptext (sLit "is untouchable") + , ptext (sLit "inside the constraints") <+> pprEvVarTheta given + , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)] + ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } + + | otherwise + = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ + return () + -- I don't think this should happen, and if it does I want to know + -- Trac #5130 happened because an actual type error was not + -- reported at all! So not reporting is pretty dangerous. + -- + -- OLD, OUT OF DATE COMMENT + -- This can happen, by a recursive decomposition of frozen + -- occurs check constraints + -- Example: alpha ~ T Int alpha has frozen. + -- Then alpha gets unified to T beta gamma + -- So now we have T beta gamma ~ T Int (T beta gamma) + -- Decompose to (beta ~ Int, gamma ~ T beta gamma) + -- The (gamma ~ T beta gamma) is the occurs check, but + -- the (beta ~ Int) isn't an error at all. So return () where - is_meta1 = isMetaTyVar tv1 - k1 = tyVarKind tv1 - k2 = typeKind ty2 - ty1 = mkTyVarTy tv1 + k1 = tyVarKind tv1 + k2 = typeKind ty2 + ty1 = mkTyVarTy tv1 mkTyFunInfoMsg :: TcType -> TcType -> SDoc -- See Note [Non-injective type functions] @@ -364,15 +406,41 @@ mkTyFunInfoMsg ty1 ty2 pp_inj tc | isInjectiveTyCon tc = empty | otherwise = ptext (sLit (", and may not be injective")) -misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc) --- This version is used by TcSimplify too, which doesn't track the --- expected/acutal thing, so we just have ty1 ty2 here --- NB: The types are already tidied -misMatchMsgWithExtras env ty1 ty2 - = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ]) +misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc +misMatchOrCND ctxt ty1 ty2 + | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally + -- insoluble, don't report the context + | null givens = misMatchMsg ty1 ty2 + | otherwise = couldNotDeduce givens ([EqPred ty1 ty2], orig) where - (env1, extra1) = typeExtraInfoMsg env ty1 - (env2, extra2) = typeExtraInfoMsg env1 ty2 + givens = getUserGivens ctxt + orig = TypeEqOrigin (UnifyOrigin ty1 ty2) + +couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc +couldNotDeduce givens (wanteds, orig) + = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds) + 2 (pprArising orig) + , vcat pp_givens ] + where + pp_givens + = case givens of + [] -> [] + (g:gs) -> ppr_given (ptext (sLit "from the context")) g + : map (ppr_given (ptext (sLit "or from"))) gs + + ppr_given herald (gs,loc) + = hang (herald <+> pprEvVarTheta gs) + 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc) + , ptext (sLit "at") <+> ppr (ctLocSpan loc)]) + +addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt +-- Add on extra info about the types themselves +-- NB: The types themselves are already tidied +addExtraInfo ctxt ty1 ty2 + = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt } + where + extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1 + extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1) @@ -387,17 +455,37 @@ kindErrorMsg ty1 ty2 k1 = typeKind ty1 k2 = typeKind ty2 -typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc) +typeExtraInfoMsg :: [Implication] -> Type -> SDoc -- Shows a bit of extra info about skolem constants -typeExtraInfoMsg env ty +typeExtraInfoMsg implics ty | Just tv <- tcGetTyVar_maybe ty - , isTcTyVar tv - , isSkolemTyVar tv || isSigTyVar tv - , not (isUnk tv) - , let (env1, tv1) = tidySkolemTyVar env tv - = (env1, pprSkolTvBinding tv1) - where -typeExtraInfoMsg env _ty = (env, empty) -- Normal case + , isTcTyVar tv, isSkolemTyVar tv + , let pp_tv = quotes (ppr tv) + = case tcTyVarDetails tv of + SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv) + FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") + RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") + MetaTv {} -> empty + + | otherwise -- Normal case + = empty + + where + ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful + ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"), + sep [ppr info, ptext (sLit "at") <+> ppr loc]] + +-------------------- +unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc) +unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env + = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty + ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty + ; return (env2, mkExpectedActualMsg act_ty' exp_ty') } + +mkExpectedActualMsg :: Type -> Type -> SDoc +mkExpectedActualMsg act_ty exp_ty + = vcat [ text "Expected type" <> colon <+> ppr exp_ty + , text " Actual type" <> colon <+> ppr act_ty ] \end{code} Note [Non-injective type functions] @@ -418,31 +506,74 @@ Warn of loopy local equalities that were dropped. %************************************************************************ \begin{code} -reportDictErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM () -reportDictErrs ctxt wanteds loc +reportDictErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +reportDictErrs ctxt wanteds orig = do { inst_envs <- tcGetInstEnvs - ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds - ; unless (null others) $ - addErrorReport ctxt (mk_no_inst_err others) - ; mapM_ (addErrorReport ctxt) overlaps } + ; non_overlaps <- mapMaybeM (reportOverlap ctxt inst_envs orig) wanteds + ; unless (null non_overlaps) $ + addErrorReport ctxt (mk_no_inst_err non_overlaps) } where - check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc - -- Right msg => overlap message - -- Left inst => no instance - check_overlap inst_envs pred@(ClassP clas tys) - = case lookupInstEnv inst_envs clas tys of - ([], _) -> Left pred -- No match + mk_no_inst_err :: [PredType] -> SDoc + mk_no_inst_err wanteds + | null givens -- Top level + = vcat [ addArising orig $ + ptext (sLit "No instance") <> plural min_wanteds + <+> ptext (sLit "for") <+> pprTheta min_wanteds + , show_fixes (fixes2 ++ fixes3) ] + + | otherwise + = vcat [ couldNotDeduce givens (min_wanteds, orig) + , show_fixes (fix1 : (fixes2 ++ fixes3)) ] + where + givens = getUserGivens ctxt + min_wanteds = mkMinimalBySCs wanteds + fix1 = sep [ ptext (sLit "add") <+> pprTheta min_wanteds + <+> ptext (sLit "to the context of") + , nest 2 $ pprErrCtxtLoc ctxt ] + + fixes2 = case instance_dicts of + [] -> [] + [_] -> [sep [ptext (sLit "add an instance declaration for"), + pprTheta instance_dicts]] + _ -> [sep [ptext (sLit "add instance declarations for"), + pprTheta instance_dicts]] + fixes3 = case orig of + DerivOrigin -> [drv_fix] + _ -> [] + + instance_dicts = filterOut isTyVarClassPred min_wanteds + -- Insts for which it is worth suggesting an adding an + -- instance declaration. Exclude tyvar dicts. + + drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"), + nest 2 $ ptext (sLit "so you can specify the instance context yourself")] + + show_fixes :: [SDoc] -> SDoc + show_fixes [] = empty + show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), + nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] + +reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin + -> PredType -> TcM (Maybe PredType) +-- Report an overlap error if this class constraint results +-- from an overlap (returning Nothing), otherwise return (Just pred) +reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) + = do { tys_flat <- mapM quickFlattenTy tys + -- Note [Flattening in error message generation] + + ; case lookupInstEnv inst_envs clas tys_flat of + ([], _) -> return (Just pred) -- No match -- The case of exactly one match and no unifiers means a -- successful lookup. That can't happen here, because dicts -- only end up here if they didn't match in Inst.lookupInst ([_],[]) | debugIsOn -> pprPanic "check_overlap" (ppr pred) - res -> Right (mk_overlap_msg pred res) - check_overlap _ _ = panic "check_overlap" - - mk_overlap_msg pred (matches, unifiers) + res -> do { addErrorReport ctxt (mk_overlap_msg res) + ; return Nothing } } + where + mk_overlap_msg (matches, unifiers) = ASSERT( not (null matches) ) - vcat [ addArising loc (ptext (sLit "Overlapping instances for") + vcat [ addArising orig (ptext (sLit "Overlapping instances for") <+> pprPred pred) , sep [ptext (sLit "Matching instances") <> colon, nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] @@ -458,41 +589,64 @@ reportDictErrs ctxt wanteds loc where ispecs = [ispec | (ispec, _) <- matches] - mk_no_inst_err :: [PredType] -> SDoc - mk_no_inst_err wanteds - | Just givens <- getUserGivens ctxt - = vcat [ addArising loc $ couldNotDeduce givens wanteds - , show_fixes (fix1 : fixes2) ] - - | otherwise -- Top level - = vcat [ addArising loc $ - ptext (sLit "No instance") <> plural wanteds - <+> ptext (sLit "for") <+> pprTheta wanteds - , show_fixes fixes2 ] - - where - fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds - <+> ptext (sLit "to the context of") - , nest 2 $ pprErrCtxtLoc ctxt ] - - fixes2 | null instance_dicts = [] - | otherwise = [sep [ptext (sLit "add an instance declaration for"), - pprTheta instance_dicts]] - instance_dicts = filterOut isTyVarClassPred wanteds - -- Insts for which it is worth suggesting an adding an - -- instance declaration. Exclude tyvar dicts. +reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP + +---------------------- +quickFlattenTy :: TcType -> TcM TcType +-- See Note [Flattening in error message generation] +quickFlattenTy ty | Just ty' <- tcView ty = quickFlattenTy ty' +quickFlattenTy ty@(TyVarTy {}) = return ty +quickFlattenTy ty@(ForAllTy {}) = return ty -- See +quickFlattenTy ty@(PredTy {}) = return ty -- Note [Quick-flatten polytypes] + -- Don't flatten because of the danger or removing a bound variable +quickFlattenTy (AppTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1 + ; fy2 <- quickFlattenTy ty2 + ; return (AppTy fy1 fy2) } +quickFlattenTy (FunTy ty1 ty2) = do { fy1 <- quickFlattenTy ty1 + ; fy2 <- quickFlattenTy ty2 + ; return (FunTy fy1 fy2) } +quickFlattenTy (TyConApp tc tys) + | not (isSynFamilyTyCon tc) + = do { fys <- mapM quickFlattenTy tys + ; return (TyConApp tc fys) } + | otherwise + = do { let (funtys,resttys) = splitAt (tyConArity tc) tys + -- Ignore the arguments of the type family funtys + ; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys)) + ; flat_resttys <- mapM quickFlattenTy resttys + ; return (foldl AppTy (mkTyVarTy v) flat_resttys) } +\end{code} - show_fixes :: [SDoc] -> SDoc - show_fixes [] = empty - show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), - nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] +Note [Flattening in error message generation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (C (Maybe (F x))), where F is a type function, and we have +instances + C (Maybe Int) and C (Maybe a) +Since (F x) might turn into Int, this is an overlap situation, and +indeed (because of flattening) the main solver will have refrained +from solving. But by the time we get to error message generation, we've +un-flattened the constraint. So we must *re*-flatten it before looking +up in the instance environment, lest we only report one matching +instance when in fact there are two. + +Re-flattening is pretty easy, because we don't need to keep track of +evidence. We don't re-use the code in TcCanonical because that's in +the TcS monad, and we are in TcM here. + +Note [Quick-flatten polytypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see C (Ix a => blah) or C (forall a. blah) we simply refrain from +flattening any further. After all, there can be no instance declarations +that match such things. And flattening under a for-all is problematic +anyway; consider C (forall a. F a) +\begin{code} reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM () reportAmbigErrs ctxt skols ambigs -- Divide into groups that share a common set of ambiguous tyvars = mapM_ report (equivClasses cmp ambigs_w_tvs) where - ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols)) + ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols)) | d <- ambigs ] cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 @@ -516,10 +670,10 @@ mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc) -- ASSUMPTION: the Insts are fully zonked mkMonomorphismMsg ctxt inst_tvs = do { dflags <- getDOpts - ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs) + ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs) ; return (tidy_env, mk_msg dflags docs) } where - mk_msg _ _ | any isRuntimeUnk inst_tvs + mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems] = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+> (pprWithCommas ppr inst_tvs), ptext (sLit "Use :print or :force to determine these types")] @@ -536,11 +690,18 @@ 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! +getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo +getSkolemInfo [] tv + = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) + UnkSkol +getSkolemInfo (implic:implics) tv + | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic) + | otherwise = getSkolemInfo implics tv ----------------------- -- findGlobals looks at the value environment and finds values whose @@ -577,27 +738,25 @@ findGlobals ctxt tvs find_thing :: TidyEnv -> (TcType -> Bool) -> TcTyThing -> TcM (TidyEnv, Maybe SDoc) find_thing tidy_env ignore_it (ATcId { tct_id = id }) - = do { id_ty <- zonkTcType (idType id) - ; if ignore_it id_ty then + = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) + ; if ignore_it tidy_ty then return (tidy_env, Nothing) else do - { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty - msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty + { let msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty , nest 2 (parens (ptext (sLit "bound at") <+> ppr (getSrcLoc id)))] ; return (tidy_env', Just msg) } } find_thing tidy_env ignore_it (ATyVar tv ty) - = do { tv_ty <- zonkTcType ty - ; if ignore_it tv_ty then + = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty + ; if ignore_it tidy_ty then return (tidy_env, Nothing) else do { let -- The name tv is scoped, so we don't need to tidy it - (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff , nest 2 bound_at] - eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty + eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty , getOccName tv == getOccName tv' = empty | otherwise = equals <+> ppr tidy_ty -- It's ok to use Type.getTyVar_maybe because ty is zonked by now @@ -607,73 +766,38 @@ find_thing tidy_env ignore_it (ATyVar tv ty) find_thing _ _ thing = pprPanic "find_thing" (ppr thing) -warnDefaulting :: [WantedEvVar] -> Type -> TcM () +warnDefaulting :: [FlavoredEvVar] -> Type -> TcM () warnDefaulting wanteds default_ty = do { warn_default <- doptM Opt_WarnTypeDefaults + ; env0 <- tcInitTidyEnv + ; let wanted_bag = listToBag wanteds + tidy_env = tidyFreeTyVars env0 $ + tyVarsOfEvVarXs wanted_bag + tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag + (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds)) + warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type") + <+> quotes (ppr default_ty)) + 2 ppr_wanteds ; setCtLoc loc $ warnTc warn_default warn_msg } where - -- Tidy them first - warn_msg = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+> - quotes (ppr default_ty), - nest 2 ppr_wanteds ] - (loc, ppr_wanteds) = pprWithArising wanteds + get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc -- Yuk + get_wev ev = pprPanic "warnDefaulting" (ppr ev) \end{code} +Note [Runtime skolems] +~~~~~~~~~~~~~~~~~~~~~~ +We want to give a reasonably helpful error message for ambiguity +arising from *runtime* skolems in the debugger. These +are created by in RtClosureInspect.zonkRTTIType. + %************************************************************************ %* * Error from the canonicaliser + These ones are called *during* constraint simplification %* * %************************************************************************ \begin{code} -kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a -kindErrorTcS fl ty1 ty2 - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { env0 <- tcInitTidyEnv - ; let (env1, ty1') = tidyOpenType env0 ty1 - (env2, ty2') = tidyOpenType env1 ty2 - ; failWithTcM (env2, kindErrorMsg ty1' ty2') } - -misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a -misMatchErrorTcS fl ty1 ty2 - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { env0 <- tcInitTidyEnv - ; let (env1, ty1') = tidyOpenType env0 ty1 - (env2, ty2') = tidyOpenType env1 ty2 - (env3, msg) = misMatchMsgWithExtras env2 ty1' ty2' - ; failWithTcM (env3, inaccessible_msg $$ msg) } - where - inaccessible_msg - = case fl of - Given loc -> hang (ptext (sLit "Inaccessible code in")) - 2 (mk_what loc) - _ -> empty - mk_what loc - = case ctLocOrigin loc of - PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor") - <+> quotes (ppr dc) <> comma - , ptext (sLit "in") <+> pprMatchContext mc ] - other_skol -> pprSkolInfo other_skol - -occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a -occursCheckErrorTcS fl tv ty - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { env0 <- tcInitTidyEnv - ; let (env1, tv') = tidyOpenTyVar env0 tv - (env2, ty') = tidyOpenType env1 ty - extra = sep [ppr tv', char '=', ppr ty'] - ; failWithTcM (env2, hang msg 2 extra) } - where - msg = text $ "Occurs check: cannot construct the infinite type:" - -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 - solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a solverDepthErrorTcS depth stack | null stack -- Shouldn't happen unless you say -fcontext-stack=0 @@ -681,12 +805,11 @@ solverDepthErrorTcS depth stack | otherwise = wrapErrTcS $ setCtFlavorLoc (cc_flavor top_item) $ - do { env0 <- tcInitTidyEnv - ; let ev_vars = map cc_id stack - env1 = tidyFreeTyVars env0 free_tvs - free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars - extra = pprEvVars (map (tidyEvVar env1) ev_vars) - ; failWithTcM (env1, hang msg 2 extra) } + do { ev_vars <- mapM (zonkEvVar . cc_id) stack + ; env0 <- tcInitTidyEnv + ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars) + tidy_ev_vars = map (tidyEvVar tidy_env) ev_vars + ; failWithTcM (tidy_env, hang msg 2 (pprEvVars tidy_ev_vars)) } where top_item = head stack msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth @@ -694,7 +817,7 @@ solverDepthErrorTcS depth stack flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a flattenForAllErrorTcS fl ty _bad_eqs - = wrapErrTcS $ + = wrapErrTcS $ setCtFlavorLoc fl $ do { env0 <- tcInitTidyEnv ; let (env1, ty') = tidyOpenType env0 ty @@ -702,3 +825,37 @@ flattenForAllErrorTcS fl ty _bad_eqs , ppr ty' ] ; failWithTcM (env1, msg) } \end{code} + +%************************************************************************ +%* * + 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 +\end{code} + +%************************************************************************ +%* * + Tidying +%* * +%************************************************************************ + +\begin{code} +zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) +zonkTidyTcType env ty = do { ty' <- zonkTcType ty + ; return (tidyOpenType env ty') } + +zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin +zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) + = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act + ; (_env2, exp') <- zonkTidyTcType env1 exp + ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) } + -- Drop the returned env on the floor; we may conceivably thereby get + -- inconsistent naming between uses of this function +zonkTidyOrigin _ orig = return orig +\end{code}