X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcErrors.lhs;h=b199053ac2e5bbebe6452a0298035b51919ce651;hp=873af7385c11354943dfd05376fa6e9f0140a9af;hb=HEAD;hpb=bac10a99aba7d223d70b93f398d5239a166e929f diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 873af73..b199053 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1,8 +1,8 @@ \begin{code} module TcErrors( - reportUnsolved, reportUnsolvedDeriv, - reportUnsolvedWantedEvVars, warnDefaulting, - unifyCtxt, typeExtraInfoMsg, + reportUnsolved, + warnDefaulting, + unifyCtxt, flattenForAllErrorTcS, solverDepthErrorTcS @@ -15,15 +15,14 @@ import TcMType import TcSMonad import TcType import TypeRep - +import Type( isTyVarTy ) +import Unify ( tcMatchTys ) import Inst import InstEnv - import TyCon import Name import NameEnv -import Id ( idType ) -import HsExpr ( pprMatchContext ) +import Id ( idType, evVarPred ) import Var import VarSet import VarEnv @@ -50,158 +49,26 @@ from the insts, or just whatever seems to be around in the monad just now? \begin{code} -reportUnsolved :: (Bag WantedEvVar, Bag Implication) -> Bag FrozenError -> TcM () -reportUnsolved (unsolved_flats, unsolved_implics) frozen_errors - | isEmptyBag unsolved && isEmptyBag frozen_errors +reportUnsolved :: WantedConstraints -> TcM () +reportUnsolved wanted + | isEmptyWC wanted = return () | otherwise - = do { frozen_errors_zonked <- mapBagM zonk_frozen frozen_errors - ; let frozen_tvs = tyVarsOfFrozen frozen_errors_zonked + = do { -- Zonk to un-flatten any flatten-skols + ; wanted <- zonkWC wanted - ; unsolved <- mapBagM zonkWanted unsolved - -- Zonk to un-flatten any flatten-skols ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 $ - tyVarsOfWanteds unsolved `unionVarSet` frozen_tvs - - tidy_unsolved = tidyWanteds tidy_env unsolved - 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 - } - - ; traceTc "reportUnsolved" (vcat [ - text "Unsolved constraints =" <+> ppr unsolved, - text "Frozen errors =" <+> ppr frozen_errors_zonked ]) + , cec_tidy = tidy_env } + tidy_wanted = tidyWC tidy_env wanted - ; let tidy_frozen_errors_zonked = tidyFrozen tidy_env frozen_errors_zonked + ; traceTc "reportUnsolved" (ppr tidy_wanted) - ; reportTidyFrozens tidy_env tidy_frozen_errors_zonked - ; reportTidyWanteds err_ctxt tidy_unsolved } - where - unsolved = Bag.mapBag WcEvVar unsolved_flats `unionBags` - Bag.mapBag WcImplic unsolved_implics - - zonk_frozen (FrozenError frknd fl ty1 ty2) - = do { ty1z <- zonkTcType ty1 - ; ty2z <- zonkTcType ty2 - ; return (FrozenError frknd fl ty1z ty2z) } - - tyVarsOfFrozen fr - = unionVarSets $ bagToList (mapBag tvs_of_frozen fr) - tvs_of_frozen (FrozenError _ _ ty1 ty2) = tyVarsOfTypes [ty1,ty2] - - tidyFrozen env fr = mapBag (tidy_frozen env) fr - tidy_frozen env (FrozenError frknd fl ty1 ty2) - = FrozenError frknd fl (tidyType env ty1) (tidyType env ty2) - -reportTidyFrozens :: TidyEnv -> Bag FrozenError -> TcM () -reportTidyFrozens tidy_env fr = mapBagM_ (reportTidyFrozen tidy_env) fr - -reportTidyFrozen :: TidyEnv -> FrozenError -> TcM () -reportTidyFrozen tidy_env err@(FrozenError _ fl _ty1 _ty2) - = do { let dec_errs = decompFrozenError err - init_err_ctxt = CEC { cec_encl = [] - , cec_extra = empty - , cec_tidy = tidy_env } - ; mapM_ (report_dec_err init_err_ctxt) dec_errs } - where - report_dec_err err_ctxt (ty1,ty2) - -- The only annoying thing here is that in the given case, - -- the ``Inaccessible code'' message will be printed once for - -- each decomposed equality. - = do { (tidy_env2,extra2) - <- if isGiven fl - then return (cec_tidy err_ctxt, inaccessible_msg) - else getWantedEqExtra emptyTvSubst (cec_tidy err_ctxt) loc_orig ty1 ty2 - ; let err_ctxt2 = err_ctxt { cec_tidy = tidy_env2 - , cec_extra = cec_extra err_ctxt $$ extra2 } - ; setCtFlavorLoc fl $ - reportEqErr err_ctxt2 ty1 ty2 - } - - loc_orig | Wanted loc <- fl = ctLocOrigin loc - | Derived loc _ <- fl = ctLocOrigin loc - | otherwise = pprPanic "loc_orig" empty - - inaccessible_msg - | Given loc <- fl - = hang (ptext (sLit "Inaccessible code in")) 2 (mk_what loc) - | otherwise = pprPanic "inaccessible_msg" 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 - - -decompFrozenError :: FrozenError -> [(TcType,TcType)] --- Postcondition: will always return a non-empty list -decompFrozenError (FrozenError errk _fl ty1 ty2) - | OccCheckError <- errk - = dec_occ_check ty1 ty2 - | otherwise - = [(ty1,ty2)] - where dec_occ_check :: TcType -> TcType -> [(TcType,TcType)] - -- This error arises from an original: - -- a ~ Maybe a - -- But by now the a has been substituted away, eg: - -- Int ~ Maybe Int - -- Maybe b ~ Maybe (Maybe b) - dec_occ_check ty1 ty2 - | tcEqType ty1 ty2 = [] - dec_occ_check ty1@(TyVarTy {}) ty2 = [(ty1,ty2)] - dec_occ_check (FunTy s1 t1) (FunTy s2 t2) - = let errs1 = dec_occ_check s1 s2 - errs2 = dec_occ_check t1 t2 - in errs1 ++ errs2 - dec_occ_check ty1@(TyConApp fn1 tys1) ty2@(TyConApp fn2 tys2) - | fn1 == fn2 && length tys1 == length tys2 - , not (isSynFamilyTyCon fn1) - = concatMap (\(t1,t2) -> dec_occ_check t1 t2) (zip tys1 tys2) - | otherwise - = [(ty1,ty2)] - dec_occ_check ty1 ty2 - | Just (s1,t1) <- tcSplitAppTy_maybe ty1 - , Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = let errs1 = dec_occ_check s1 s2 - errs2 = dec_occ_check t1 t2 - in errs1 ++ errs2 - dec_occ_check ty1 ty2 = [(ty1,ty2)] - -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 = [] - , cec_extra = empty - , cec_tidy = tidy_env } - ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) } - -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")] + ; reportTidyWanteds err_ctxt tidy_wanted } -------------------------------------------- -- Internal functions @@ -210,32 +77,49 @@ 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 (isGivenOrSolved . 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 - ; traceTc "rtw" (vcat [ - text "unsolved =" <+> ppr unsolved, - text "tveqs =" <+> ppr tv_eqs, - text "others =" <+> ppr others, - text "ambigs =" <+> ppr ambigs , - text "implics =" <+> ppr implics]) - - ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics + ; mapBagM_ (reportTidyImplic ctxt) implics -- Only report ambiguity if no other errors (at all) happened -- See Note [Avoiding spurious errors] in TcSimplify @@ -246,7 +130,7 @@ reportTidyWanteds ctxt unsolved -- 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 @@ -258,7 +142,22 @@ 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 GivenOrig <- flav + -- If a GivenSolved then we should not report inaccessible code + = hang (ptext (sLit "Inaccessible code in")) + 2 (ppr (ctLocOrigin loc)) + | otherwise = empty reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () -- The [PredType] are already tidied @@ -285,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 @@ -308,18 +212,18 @@ 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) - = parens (pprPred (evVarPred v)) <+> pprArisingAt loc + first_loc = evVarX (head ev_vars) + ppr_one (EvVarX v loc) + = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc addErrorReport :: ReportErrCtxt -> SDoc -> TcM () addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) @@ -332,22 +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 + 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} @@ -360,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} @@ -380,17 +285,27 @@ reportIPErrs ctxt ips orig 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 = extra $$ cec_extra ctxt } + 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 `eqType` ty1 && exp `eqType` ty2 = empty + | exp `eqType` ty1 && act `eqType` 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 @@ -406,15 +321,10 @@ reportEqErr ctxt 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 - addErrorReport (addExtraInfo 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 @@ -447,7 +357,7 @@ reportTyVarEqErr ctxt tv1 ty2 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 @@ -459,24 +369,29 @@ reportTyVarEqErr ctxt tv1 ty2 extra = quotes (ppr tv1) <+> sep [ ptext (sLit "is untouchable") , ptext (sLit "inside the constraints") <+> pprEvVarTheta given - , ptext (sLit "bound at") <+> pprSkolInfo (ctLocOrigin implic_loc)] + , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)] ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } - | otherwise -- 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 () - = return () - + | 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] @@ -493,25 +408,39 @@ mkTyFunInfoMsg ty1 ty2 misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc misMatchOrCND ctxt ty1 ty2 - = case getUserGivens ctxt of - Just givens -> couldNotDeduce givens [EqPred ty1 ty2] - Nothing -> misMatchMsg ty1 ty2 - -couldNotDeduce :: [EvVar] -> [PredType] -> SDoc -couldNotDeduce givens wanteds - = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds - , nest 2 $ ptext (sLit "from the context") - <+> pprEvVarTheta givens] + | 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 + 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 givens)] + +pp_givens :: [([EvVar], GivenLoc)] -> [SDoc] +pp_givens givens + = case givens of + [] -> [] + (g:gs) -> ppr_given (ptext (sLit "from the context")) g + : map (ppr_given (ptext (sLit "or from"))) gs + where 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_tidy = env2 - , cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt } + = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt } where - (env1, extra1) = typeExtraInfoMsg (cec_tidy ctxt) ty1 - (env2, extra2) = typeExtraInfoMsg env1 ty2 + 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) @@ -526,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 (isUnkSkol 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 @@ -580,28 +515,39 @@ reportDictErrs ctxt wanteds orig where 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 + | null givens -- Top level = vcat [ addArising orig $ - ptext (sLit "No instance") <> plural wanteds - <+> ptext (sLit "for") <+> pprTheta wanteds - , show_fixes fixes2 ] + 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 - fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds + 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 | null instance_dicts = [] - | otherwise = [sep [ptext (sLit "add an instance declaration for"), - pprTheta instance_dicts]] - instance_dicts = filterOut isTyVarClassPred wanteds + 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:"), @@ -628,9 +574,21 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) mk_overlap_msg (matches, unifiers) = ASSERT( not (null matches) ) vcat [ addArising orig (ptext (sLit "Overlapping instances for") - <+> pprPred pred) + <+> pprPredTy pred) , sep [ptext (sLit "Matching instances") <> colon, nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] + + , if not (null overlapping_givens) then + sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)] + else empty + + , if null overlapping_givens && isSingleton matches && null unifiers then + -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities) + -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten + -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem. + sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))] + else empty + , if not (isSingleton matches) then -- Two or more matches empty @@ -638,11 +596,39 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) ASSERT( not (null unifiers) ) parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+> quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))), - ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), - ptext (sLit "when compiling the other instance declarations")])] + if null (overlapping_givens) then + vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), + ptext (sLit "when compiling the other instance declarations")] + else empty])] where ispecs = [ispec | (ispec, _) <- matches] + givens = getUserGivens ctxt + overlapping_givens = unifiable_givens givens + + unifiable_givens [] = [] + unifiable_givens (gg:ggs) + | Just ggdoc <- matchable gg + = ggdoc : unifiable_givens ggs + | otherwise + = unifiable_givens ggs + + matchable (evvars,gloc) + = case ev_vars_matching of + [] -> Nothing + _ -> Just $ hang (pprTheta ev_vars_matching) + 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc) + , ptext (sLit "at") <+> ppr (ctLocSpan gloc)]) + where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) + ev_var_matches (ClassP clas' tys') + | clas' == clas + , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys' + = True + ev_var_matches (ClassP clas' tys') = + any ev_var_matches (immSuperClasses clas' tys') + ev_var_matches _ = False + + reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP ---------------------- @@ -700,7 +686,7 @@ 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 @@ -724,7 +710,6 @@ mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc) -- ASSUMPTION: the Insts are fully zonked mkMonomorphismMsg ctxt inst_tvs = do { dflags <- getDOpts - ; traceTc "Mono" (vcat (map pprSkolTvBinding inst_tvs)) ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs) ; return (tidy_env, mk_msg dflags docs) } where @@ -750,6 +735,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 @@ -786,27 +778,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 @@ -816,16 +806,22 @@ 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] @@ -842,7 +838,6 @@ are created by in RtClosureInspect.zonkRTTIType. %************************************************************************ \begin{code} - solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a solverDepthErrorTcS depth stack | null stack -- Shouldn't happen unless you say -fcontext-stack=0 @@ -850,12 +845,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 @@ -881,42 +875,27 @@ flattenForAllErrorTcS fl ty _bad_eqs \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 - -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') } +setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing +setCtFlavorLoc (Given loc _gk) 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}