X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcErrors.lhs;h=645c43af6d0c39242802001255617c96e5143181;hp=0ade93c29f0bb83e4324444e0eb62d7709cf5458;hb=35a1ec430a5e44a9bc79d385b997422c20cb427b;hpb=5e86045ae5f90d9138e395fde5792e50ac8f8afd diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 0ade93c..645c43a 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1,10 +1,11 @@ \begin{code} module TcErrors( - reportUnsolved, reportUnsolvedDeriv, - reportUnsolvedWantedEvVars, warnDefaulting, - unifyCtxt, typeExtraInfoMsg, - kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS, - occursCheckErrorTcS, solverDepthErrorTcS + reportUnsolved, + warnDefaulting, + unifyCtxt, + + flattenForAllErrorTcS, + solverDepthErrorTcS ) where #include "HsVersions.h" @@ -13,6 +14,9 @@ import TcRnMonad import TcMType import TcSMonad import TcType +import TypeRep +import Type( isTyVarTy ) + import Inst import InstEnv @@ -20,7 +24,6 @@ import TyCon import Name import NameEnv import Id ( idType ) -import HsExpr ( pprMatchContext ) import Var import VarSet import VarEnv @@ -47,56 +50,26 @@ 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 { unsolved <- mapBagM zonkWanted unsolved - -- Zonk to un-flatten any flatten-skols - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved) - tidy_unsolved = tidyWanteds tidy_env unsolved - err_ctxt = CEC { cec_encl = [] - , cec_extra = empty - , cec_tidy = tidy_env } - ; traceTc "reportUnsolved" (ppr unsolved) - ; reportTidyWanteds err_ctxt tidy_unsolved } - where - unsolved = mkWantedConstraints unsolved_flats unsolved_implics - + = do { -- Zonk to un-flatten any flatten-skols + ; wanted <- zonkWC wanted -reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM () -reportUnsolvedWantedEvVars wanteds - | isEmptyBag wanteds - = return () - | otherwise - = do { wanteds <- mapBagM zonkWantedEvVar wanteds ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds) - tidy_unsolved = tidyWantedEvVars tidy_env wanteds - err_ctxt = CEC { cec_encl = [] + ; 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 } - ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) } + , cec_tidy = tidy_env } + tidy_wanted = tidyWC tidy_env wanted -reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM () -reportUnsolvedDeriv unsolved loc - | null unsolved - = return () - | otherwise - = setCtLoc loc $ - do { unsolved <- zonkTcThetaType unsolved - ; 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 (ctLocOrigin 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")] + ; traceTc "reportUnsolved" (ppr tidy_wanted) + + ; reportTidyWanteds err_ctxt tidy_wanted } -------------------------------------------- -- Internal functions @@ -105,37 +78,60 @@ reportUnsolvedDeriv unsolved loc 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, non_ambigs) = partition is_ambiguous (bagToList flats) +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 - ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics + ; mapBagM_ (reportTidyImplic ctxt) implics - -- Only report ambiguity if no other errors happened - -- See Note [Avoiding spurious errors] - ; when (isEmptyBag implics && null non_ambigs) $ - 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 <- wantedEvVarPred c + is_tv_eq c | EqPred ty1 ty2 <- evVarOfPred c = tcIsTyVarTy ty1 || tcIsTyVarTy ty2 | otherwise = False @@ -147,9 +143,24 @@ reportTidyWanteds ctxt unsolved is_ambiguous d = isTyVarClassPred pred && not (tyVarsOfPred pred `subVarSet` skols) where - pred = wantedEvVarPred d + 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 @@ -173,21 +184,26 @@ groupErrs :: ([PredType] -> CtOrigin -> TcM ()) -- Deal with one group groupErrs _ [] = return () groupErrs report_err (wanted : wanteds) - = do { setCtLoc 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 :: CtOrigin -> SDoc -> SDoc @@ -196,17 +212,17 @@ 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] +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 () @@ -220,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} @@ -254,13 +263,15 @@ getUserGivens (CEC {cec_encl = ctxt}) \begin{code} reportIPErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () reportIPErrs ctxt ips orig - = addErrorReport ctxt $ addArising orig msg + = 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} @@ -272,48 +283,61 @@ reportIPErrs ctxt ips orig \begin{code} reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +-- The [PredType] are already tidied reportEqErrs ctxt eqs orig - = mapM_ report_one eqs + = do { orig' <- zonkTidyOrigin ctxt orig + ; mapM_ (report_one orig') eqs } where - env0 = cec_tidy ctxt - report_one (EqPred ty1 ty2) - = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2 - ; let ctxt' = ctxt { cec_tidy = env1 - , cec_extra = cec_extra ctxt $$ extra } + 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 + 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 + | 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 [EqPred ty1 ty2] - Nothing -> misMatchMsg ty1 ty2 + = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2) + reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM () +-- tv1 and ty2 are already tidied reportTyVarEqErr ctxt tv1 ty2 - | not is_meta1 - , Just tv2 <- tcGetTyVar_maybe ty2 - , isMetaTyVar tv2 - = -- sk ~ alpha: swap - reportTyVarEqErr ctxt tv2 ty1 - - | not is_meta1 - = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match - addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 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) @@ -323,16 +347,17 @@ reportTyVarEqErr ctxt 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 @@ -340,20 +365,33 @@ reportTyVarEqErr ctxt 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] @@ -368,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) @@ -391,26 +455,32 @@ 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 { act_ty' <- zonkTcType act_ty - ; exp_ty' <- zonkTcType exp_ty - ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty' - (env2, act_ty'') = tidyOpenType env1 act_ty' - ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') } + = 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 @@ -439,26 +509,69 @@ Warn of loopy local equalities that were dropped. 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 orig (ptext (sLit "Overlapping instances for") <+> pprPred pred) @@ -476,41 +589,64 @@ reportDictErrs ctxt wanteds orig where ispecs = [ispec | (ispec, _) <- matches] - mk_no_inst_err :: [PredType] -> SDoc - mk_no_inst_err wanteds - | Just givens <- getUserGivens ctxt - = vcat [ addArising orig $ couldNotDeduce givens wanteds - , show_fixes (fix1 : fixes2) ] - - | otherwise -- Top level - = vcat [ addArising orig $ - 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 @@ -534,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")] @@ -559,6 +695,13 @@ monomorphism_fix dflags 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 @@ -595,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 @@ -625,18 +766,30 @@ 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 @@ -645,44 +798,6 @@ warnDefaulting wanteds default_ty %************************************************************************ \begin{code} -kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS () --- If there's a kind error, we don't want to blindly say "kind error" --- We might, say, be unifying a skolem 'a' with a type 'Int', --- 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 - = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra -> - do { let ctxt = CEC { cec_encl = [] - , cec_extra = extra - , cec_tidy = env0 } - ; reportEqErr ctxt ty1 ty2 } - -misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a -misMatchErrorTcS fl ty1 ty2 - = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra -> - do { let (env1, msg) = misMatchMsgWithExtras env0 ty1 ty2 - ; failWithTcM (env1, inaccessible_msg $$ msg $$ extra) } - 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 - = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 ty1 ty2 extra2 -> - do { let extra1 = sep [ppr ty1, char '=', ppr ty2] - ; failWithTcM (env0, hang msg 2 (extra1 $$ extra2)) } - where - msg = text $ "Occurs check: cannot construct the infinite type:" - solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a solverDepthErrorTcS depth stack | null stack -- Shouldn't happen unless you say -fcontext-stack=0 @@ -690,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 @@ -723,65 +837,25 @@ 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} -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 +%************************************************************************ +%* * + Tidying +%* * +%************************************************************************ -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') } +\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}