X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcErrors.lhs;h=873af7385c11354943dfd05376fa6e9f0140a9af;hp=437815d4e1dfbe469337d1c7334841d6540e56c2;hb=bac10a99aba7d223d70b93f398d5239a166e929f;hpb=7966f85171e278ff415d48545212107cfbc984cb diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 437815d..873af73 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1,10 +1,11 @@ \begin{code} module TcErrors( - reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv, + reportUnsolved, reportUnsolvedDeriv, reportUnsolvedWantedEvVars, warnDefaulting, unifyCtxt, typeExtraInfoMsg, - kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS, - occursCheckErrorTcS, solverDepthErrorTcS + + flattenForAllErrorTcS, + solverDepthErrorTcS ) where #include "HsVersions.h" @@ -13,6 +14,8 @@ import TcRnMonad import TcMType import TcSMonad import TcType +import TypeRep + import Inst import InstEnv @@ -28,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} %************************************************************************ @@ -48,28 +50,134 @@ 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 :: (Bag WantedEvVar, Bag Implication) -> Bag FrozenError -> TcM () +reportUnsolved (unsolved_flats, unsolved_implics) frozen_errors + | isEmptyBag unsolved && isEmptyBag frozen_errors = return () | otherwise - = do { env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved) + = do { frozen_errors_zonked <- mapBagM zonk_frozen frozen_errors + ; let frozen_tvs = tyVarsOfFrozen frozen_errors_zonked + + ; 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 = [] , cec_extra = empty - , cec_tidy = tidy_env } - ; traceTc "reportUnsolved" (ppr unsolved) + , cec_tidy = tidy_env + } + + ; traceTc "reportUnsolved" (vcat [ + text "Unsolved constraints =" <+> ppr unsolved, + text "Frozen errors =" <+> ppr frozen_errors_zonked ]) + + ; let tidy_frozen_errors_zonked = tidyFrozen tidy_env frozen_errors_zonked + + ; reportTidyFrozens tidy_env tidy_frozen_errors_zonked ; reportTidyWanteds err_ctxt tidy_unsolved } where - unsolved = mkWantedConstraints unsolved_flats unsolved_implics + 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 { env0 <- tcInitTidyEnv + = 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 = [] @@ -83,7 +191,8 @@ reportUnsolvedDeriv unsolved loc = return () | otherwise = setCtLoc loc $ - do { env0 <- tcInitTidyEnv + 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 = [] @@ -94,36 +203,15 @@ reportUnsolvedDeriv unsolved loc 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 +-------------------------------------------- +-- 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 } reportTidyImplic :: ReportErrCtxt -> Implication -> TcM () @@ -134,17 +222,34 @@ reportTidyImplic ctxt implic reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () reportTidyWanteds ctxt unsolved - = do { let (flats, implics) = splitWanteds unsolved - (ambigs, others) = partition is_ambiguous (bagToList flats) - ; 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 } + = do { let (flats, implics) = splitWanteds unsolved + (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 + + -- 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 + = tcIsTyVarTy ty1 || tcIsTyVarTy ty2 + | otherwise = False + -- Treat it as "ambiguous" if -- (a) it is a class constraint -- (b) it constrains only type variables @@ -156,9 +261,10 @@ reportTidyWanteds ctxt unsolved pred = wantedEvVarPred d 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 + ; unless (null eqs) $ reportEqErrs ctxt eqs origin ; unless (null ips) $ reportIPErrs ctxt ips origin ; ASSERT( null others ) return () } where @@ -228,12 +334,6 @@ pprErrCtxtLoc ctxt 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] - getUserGivens :: ReportErrCtxt -> Maybe [EvVar] -- Just gs => Say "could not deduce ... from gs" -- Nothing => No interesting givens, say something else @@ -277,27 +377,34 @@ reportIPErrs ctxt ips orig %************************************************************************ \begin{code} -reportEqErrs :: ReportErrCtxt -> [PredType] -> TcM () -reportEqErrs ctxt eqs +reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () +-- The [PredType] are already tidied +reportEqErrs ctxt eqs orig = mapM_ report_one eqs where - report_one (EqPred ty1 ty2) = reportEqErr ctxt ty1 ty2 - report_one pred = pprPanic "reportEqErrs" (ppr pred) + env0 = cec_tidy ctxt + report_one (EqPred ty1 ty2) + = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2 + ; let ctxt' = ctxt { cec_tidy = env1 + , cec_extra = extra $$ cec_extra ctxt } + ; reportEqErr ctxt' ty1 ty2 } + report_one pred + = pprPanic "reportEqErrs" (ppr pred) 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 @@ -307,13 +414,20 @@ reportTyVarEqErr ctxt tv1 ty2 | not is_meta1 = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match - addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 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,14 +437,15 @@ 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) ] ] ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) } @@ -340,15 +455,23 @@ 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") <+> pprSkolInfo (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 () + where is_meta1 = isMetaTyVar tv1 k1 = tyVarKind tv1 @@ -368,15 +491,27 @@ 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 + = 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] + +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 } where - (env1, extra1) = typeExtraInfoMsg env ty1 - (env2, extra2) = typeExtraInfoMsg env1 ty2 + (env1, extra1) = typeExtraInfoMsg (cec_tidy ctxt) ty1 + (env2, extra2) = typeExtraInfoMsg env1 ty2 misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1) @@ -397,7 +532,7 @@ typeExtraInfoMsg env ty | Just tv <- tcGetTyVar_maybe ty , isTcTyVar tv , isSkolemTyVar tv || isSigTyVar tv - , not (isUnk tv) + , not (isUnkSkol tv) , let (env1, tv1) = tidySkolemTyVar env tv = (env1, pprSkolTvBinding tv1) where @@ -439,43 +574,10 @@ 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 - -- 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) - = ASSERT( not (null matches) ) - vcat [ addArising orig (ptext (sLit "Overlapping instances for") - <+> pprPred pred) - , sep [ptext (sLit "Matching instances") <> colon, - nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] - , if not (isSingleton matches) - then -- Two or more matches - empty - else -- One match, plus some unifiers - 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")])] - where - ispecs = [ispec | (ispec, _) <- matches] - mk_no_inst_err :: [PredType] -> SDoc mk_no_inst_err wanteds | Just givens <- getUserGivens ctxt @@ -505,6 +607,94 @@ reportDictErrs ctxt wanteds orig 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 -> 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) + , sep [ptext (sLit "Matching instances") <> colon, + nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] + , if not (isSingleton matches) + then -- Two or more matches + empty + else -- One match, plus some unifiers + 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")])] + where + ispecs = [ispec | (ispec, _) <- matches] + +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} + +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 @@ -534,10 +724,11 @@ 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) + ; traceTc "Mono" (vcat (map pprSkolTvBinding 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")] @@ -554,7 +745,7 @@ monomorphism_fix :: DynFlags -> SDoc monomorphism_fix dflags = ptext (sLit "Probable fix:") <+> vcat [ptext (sLit "give these definition(s) an explicit type signature"), - if dopt Opt_MonomorphismRestriction dflags + if xopt Opt_MonomorphismRestriction dflags then ptext (sLit "or use -XNoMonomorphismRestriction") else empty] -- Only suggest adding "-XNoMonomorphismRestriction" -- if it is not already set! @@ -637,62 +828,20 @@ warnDefaulting wanteds default_ty (loc, ppr_wanteds) = pprWithArising wanteds \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 () --- 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 - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { (env0, extra) <- getEqExtra fl ty1 ty2 - ; let (env1, ty1') = tidyOpenType env0 ty1 - (env2, ty2') = tidyOpenType env1 ty2 - ctxt = CEC { cec_encl = [] - , cec_extra = extra - , cec_tidy = env2 } - ; reportEqErr ctxt ty1' ty2' } - -misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a -misMatchErrorTcS fl ty1 ty2 - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { (env0, extra) <- getEqExtra fl ty1 ty2 - ; let (env1, ty1') = tidyOpenType env0 ty1 - (env2, ty2') = tidyOpenType env1 ty2 - (env3, msg) = misMatchMsgWithExtras env2 ty1' ty2' - ; failWithTcM (env3, 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 - = wrapErrTcS $ - setCtFlavorLoc fl $ - do { (env0, extra2) <- getEqExtra fl (mkTyVarTy tv) ty - ; let (env1, tv') = tidyOpenTyVar env0 tv - (env2, ty') = tidyOpenType env1 ty - extra1 = sep [ppr tv', char '=', ppr ty'] - ; failWithTcM (env2, hang msg 2 (extra1 $$ extra2)) } - where - msg = text $ "Occurs check: cannot construct the infinite type:" solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a solverDepthErrorTcS depth stack @@ -731,35 +880,43 @@ 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 - -getEqExtra :: CtFlavor -> TcType -> TcType -> TcM (TidyEnv, SDoc) -getEqExtra (Wanted loc) ty1 ty2 = getWantedEqExtra (ctLocOrigin loc) ty1 ty2 -getEqExtra (Derived loc) ty1 ty2 = getWantedEqExtra (ctLocOrigin loc) ty1 ty2 -getEqExtra (Given _) _ _ = do { env0 <- tcInitTidyEnv - ; return (env0, empty) } - -- We could print more info, but it seems to be already coming out - -getWantedEqExtra :: CtOrigin -> TcType -> TcType -> TcM (TidyEnv, SDoc) -getWantedEqExtra (TypeEqOrigin item) ty1 ty2 +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 - = do { act <- zonkTcType (uo_actual item) - ; exp <- zonkTcType (uo_expected item) - ; env0 <- tcInitTidyEnv + -- + -- 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 do - { let (env1, exp') = tidyOpenType env0 exp - (env2, act') = tidyOpenType env1 act - ; return (env2, mkExpectedActualMsg act' exp') } } - -getWantedEqExtra orig _ _ - = do { env0 <- tcInitTidyEnv - ; return (env0, pprArising orig) } + 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') } \end{code}