X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcErrors.lhs;h=0d0a9f8e083076f03a9d2abeabb58419b9144660;hp=9cbd47bcd811677afd5e13f04ea8aae28ae5b673;hb=224ef3094189bc9a33f23285b5dccbffdd8d7de0;hpb=fdf8656855d26105ff36bdd24d41827b05037b91 diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 9cbd47b..0d0a9f8 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -15,6 +15,7 @@ import TcMType import TcSMonad import TcType import TypeRep +import Type( isTyVarTy ) import Inst import InstEnv import TyCon @@ -318,15 +319,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 @@ -374,21 +370,26 @@ reportTyVarEqErr ctxt tv1 ty2 , 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] @@ -456,12 +457,22 @@ typeExtraInfoMsg :: [Implication] -> Type -> SDoc -- Shows a bit of extra info about skolem constants typeExtraInfoMsg implics ty | Just tv <- tcGetTyVar_maybe ty - , isTcTyVar tv - , isSkolemTyVar tv - = pprSkolTvBinding implics tv - where -typeExtraInfoMsg _ _ = 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 @@ -657,7 +668,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 (cec_encl ctxt)) inst_tvs)) ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs) ; return (tidy_env, mk_msg dflags docs) } where @@ -683,28 +693,6 @@ monomorphism_fix dflags else empty] -- Only suggest adding "-XNoMonomorphismRestriction" -- if it is not already set! - -pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc --- Print info about the binding of a skolem tyvar, --- or nothing if we don't have anything useful to say -pprSkolTvBinding implics tv - | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv) - | otherwise = quotes (ppr tv) <+> ppr_skol (getSkolemInfo implics tv) - where - ppr_details (SkolemTv {}) = ppr_skol (getSkolemInfo implics tv) - ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable") - ppr_details (RuntimeUnk {}) = ptext (sLit "is an interactive-debugger skolem") - ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for") - <+> quotes (ppr n) - ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable") - - - ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful - ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type") - ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"), - sep [ppr info, - ptext (sLit "at") <+> ppr (getSrcLoc tv)]] - getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo getSkolemInfo [] tv = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )