X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcErrors.lhs;h=c040473e65ee7157eb334008791479afcb47d636;hb=d93785d99261a433075dcbac8c388730a4dec64f;hp=932e5bcd47deece58f46c8501189d60599c1b99f;hpb=c80364f8e4681b34e974f5df36ecdacec7cd9cd8;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 932e5bc..c040473 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -343,11 +343,9 @@ getUserGivens (CEC {cec_encl = ctxt}) 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 + | 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} @@ -437,14 +435,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) } @@ -573,43 +572,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 @@ -627,10 +593,13 @@ reportDictErrs ctxt wanteds orig <+> 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]] + instance_dicts = filterOut isTyVarClassPred wanteds -- Insts for which it is worth suggesting an adding an -- instance declaration. Exclude tyvar dicts. @@ -639,6 +608,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 @@ -778,7 +835,6 @@ 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