X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcUnify.lhs;h=e34cfa07fe98314e9e9eaa8b4d3a52716cad2e26;hb=dbe50b77059c7d55f909ba4c10ac03b8374f5b5e;hp=86928b7099341d7e2d3978db4a9a25edf9bebc6a;hpb=351d6c8923f7f21afe974d2c90f89bf5ed9d4eed;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 86928b7..e34cfa0 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -60,6 +60,7 @@ import BasicTypes import Util import Outputable import Unique +import FastString import Control.Monad \end{code} @@ -191,7 +192,7 @@ subFunTys error_herald n_pats res_ty thing_inside loop n args_so_far res_ty = bale_out args_so_far - -- build a template type a1 -> ... -> an -> b and defer an equality + -- Build a template type a1 -> ... -> an -> b and defer an equality -- between that template and the expected result type res_ty; then, -- use the template to type the thing_inside defer n args_so_far ty @@ -201,7 +202,7 @@ subFunTys error_herald n_pats res_ty thing_inside err = error_herald <> comma $$ text "which does not match its type" ; coi <- addErrCtxt err $ - defer_unification False False fun_ty ty + defer_unification (Unify False fun_ty ty) False fun_ty ty ; res <- thing_inside (reverse args_so_far ++ arg_tys) res_ty' ; return (coiToHsWrapper coi, res) } @@ -214,9 +215,9 @@ subFunTys error_herald n_pats res_ty thing_inside mk_msg res_ty n_actual = error_herald <> comma $$ - sep [ptext SLIT("but its type") <+> quotes (pprType res_ty), - if n_actual == 0 then ptext SLIT("has none") - else ptext SLIT("has only") <+> speakN n_actual] + sep [ptext (sLit "but its type") <+> quotes (pprType res_ty), + if n_actual == 0 then ptext (sLit "has none") + else ptext (sLit "has only") <+> speakN n_actual] \end{code} \begin{code} @@ -363,19 +364,17 @@ boxySplitAppTy orig_ty mk_res_ty _other = panic "TcUnify.mk_res_ty2" ------------------ -boxySplitFailure actual_ty expected_ty - = unifyMisMatch False False actual_ty expected_ty - -- "outer" is False, so we don't pop the context - -- which is what we want since we have not pushed one! +boxySplitFailure actual_ty expected_ty = failWithMisMatch actual_ty expected_ty ------------------ boxySplitDefer :: [Kind] -- kinds of required arguments -> ([TcType] -> TcTauType) -- construct lhs from argument tyvars -> BoxyRhoType -- type to split -> TcM ([TcType], CoercionI) -boxySplitDefer kinds mkTy orig_ty +boxySplitDefer kinds mk_ty orig_ty = do { tau_tys <- mapM newFlexiTyVarTy kinds - ; coi <- defer_unification False False (mkTy tau_tys) orig_ty + ; let ty1 = mk_ty tau_tys + ; coi <- defer_unification (Unify False ty1 orig_ty) False ty1 orig_ty ; return (tau_tys, coi) } \end{code} @@ -615,6 +614,12 @@ boxy_match tmpl_tvs orig_tmpl_ty boxy_tvs orig_boxy_ty subst Nothing -> orig_boxy_ty Just ty -> ty `boxyLub` orig_boxy_ty + go _ (TyVarTy tv) | isMetaTyVar tv + = subst -- Don't fail if the template has more info than the target! + -- Otherwise, with tmpl_tvs = [a], matching (a -> Int) ~ (Bool -> beta) + -- would fail to instantiate 'a', because the meta-type-variable + -- beta is as yet un-filled-in + go _ _ = emptyTvSubst -- It's important to *fail* by returning the empty substitution -- Example: Tree a ~ Maybe Int -- We do not want to bind (a |-> Int) in pre-matching, because that can give very @@ -643,6 +648,10 @@ boxyLub orig_ty1 orig_ty2 | isTcTyVar tv1, isBoxyTyVar tv1 -- choose ty2 if ty2 is a box = orig_ty2 + go ty1 (TyVarTy tv2) -- Symmetrical case + | isTcTyVar tv2, isBoxyTyVar tv2 + = orig_ty1 + -- Look inside type synonyms, but only if the naive version fails go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2 | Just ty2' <- tcView ty1 = go ty1 ty2' @@ -738,7 +747,7 @@ tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty tc_sub1 orig act_sty (TyVarTy tv) exp_ib exp_sty exp_ty = do { traceTc (text "tc_sub1 - case 1") ; coi <- addSubCtxt orig act_sty exp_sty $ - uVar True False tv exp_ib exp_sty exp_ty + uVar (Unify True act_sty exp_sty) False tv exp_ib exp_sty exp_ty ; traceTc (case coi of IdCo -> text "tc_sub1 (Rule SBOXY) IdCo" ACo co -> text "tc_sub1 (Rule SBOXY) ACo" <+> ppr co) @@ -845,7 +854,8 @@ tc_sub1 orig act_sty actual_ty exp_ib exp_sty expected_ty ----------------------------------- defer_to_boxy_matching orig act_sty actual_ty exp_ib exp_sty expected_ty = do { coi <- addSubCtxt orig act_sty exp_sty $ - u_tys True False act_sty actual_ty exp_ib exp_sty expected_ty + u_tys (Unify True act_sty exp_sty) + False act_sty actual_ty exp_ib exp_sty expected_ty ; return $ coiToHsWrapper coi } ----------------------------------- @@ -856,7 +866,7 @@ tc_sub_funs orig act_arg act_res exp_ib exp_arg exp_res ; wrapper1 <- wrapFunResCoercion [exp_arg] co_fn_res ; let wrapper2 = case arg_coi of IdCo -> idHsWrapper - ACo co -> WpCo $ FunTy co act_res + ACo co -> WpCast $ FunTy co act_res ; return (wrapper1 <.> wrapper2) } ----------------------------------- @@ -870,7 +880,7 @@ wrapFunResCoercion arg_tys co_fn_res | null arg_tys = return co_fn_res | otherwise - = do { arg_ids <- newSysLocalIds FSLIT("sub") arg_tys + = do { arg_ids <- newSysLocalIds (fsLit "sub") arg_tys ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpApps arg_ids) } \end{code} @@ -904,12 +914,13 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty) ; return ((forall_tvs, theta, rho_ty), skol_info) }) -#ifdef DEBUG - ; traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs, - text "expected_ty" <+> ppr expected_ty, - text "inst ty" <+> ppr tvs' <+> ppr theta' <+> ppr rho', - text "free_tvs" <+> ppr free_tvs]) -#endif + ; when debugIsOn $ + traceTc (text "tcGen" <+> vcat [ + text "extra_tvs" <+> ppr extra_tvs, + text "expected_ty" <+> ppr expected_ty, + text "inst ty" <+> ppr tvs' <+> ppr theta' + <+> ppr rho', + text "free_tvs" <+> ppr free_tvs]) -- Type-check the arg and unify with poly type ; (result, lie) <- getLIE (thing_inside tvs' rho') @@ -955,9 +966,8 @@ non-exported generic functions. \begin{code} boxyUnify :: BoxyType -> BoxyType -> TcM CoercionI -- Acutal and expected, respectively -boxyUnify ty1 ty2 - = addErrCtxtM (unifyCtxt ty1 ty2) $ - uTysOuter False ty1 False ty2 +boxyUnify ty1 ty2 = addErrCtxtM (unifyCtxt ty1 ty2) $ + uTysOuter False ty1 False ty2 --------------- boxyUnifyList :: [BoxyType] -> [BoxyType] -> TcM [CoercionI] @@ -978,15 +988,14 @@ unifyType ty1 ty2 -- ty1 expected, ty2 inferred --------------- unifyPred :: PredType -> PredType -> TcM CoercionI -- Acutal and expected types -unifyPred p1 p2 = addErrCtxtM (unifyCtxt (mkPredTy p1) (mkPredTy p2)) $ - uPred True True p1 True p2 +unifyPred p1 p2 = uPred (Unify False (mkPredTy p1) (mkPredTy p2)) True p1 True p2 unifyTheta :: TcThetaType -> TcThetaType -> TcM [CoercionI] -- Acutal and expected types unifyTheta theta1 theta2 = do { checkTc (equalLength theta1 theta2) - (vcat [ptext SLIT("Contexts differ in length"), - nest 2 $ parens $ ptext SLIT("Use -fglasgow-exts to allow this")]) + (vcat [ptext (sLit "Contexts differ in length"), + nest 2 $ parens $ ptext (sLit "Use -fglasgow-exts to allow this")]) ; uList unifyPred theta1 theta2 } @@ -1042,23 +1051,32 @@ type InBox = Bool -- True <=> we are inside a box -- we must not allow polytypes. But if we are in a box on -- just one side, then we can allow polytypes -type Outer = Bool -- True <=> this is the outer level of a unification - -- so that the types being unified are the - -- very ones we began with, not some sub - -- component or synonym expansion --- The idea is that if Outer is true then unifyMisMatch should --- pop the context to remove the "Expected/Acutal" context +data Outer = Unify Bool TcType TcType + -- If there is a unification error, report these types as mis-matching + -- Bool = True <=> the context says "Expected = ty1, Acutal = ty2" + -- for this particular ty1,ty2 -uTysOuter, uTys - :: InBox -> TcType -- ty1 is the *actual* type - -> InBox -> TcType -- ty2 is the *expected* type - -> TcM CoercionI +instance Outputable Outer where + ppr (Unify c ty1 ty2) = pp_c <+> pprParendType ty1 <+> ptext (sLit "~") + <+> pprParendType ty2 + where + pp_c = if c then ptext (sLit "Top") else ptext (sLit "NonTop") + + +------------------------- +uTysOuter :: InBox -> TcType -- ty1 is the *actual* type + -> InBox -> TcType -- ty2 is the *expected* type + -> TcM CoercionI +-- We've just pushed a context describing ty1,ty2 uTysOuter nb1 ty1 nb2 ty2 = do { traceTc (text "uTysOuter" <+> ppr ty1 <+> ppr ty2) - ; u_tys True nb1 ty1 ty1 nb2 ty2 ty2 } + ; u_tys (Unify True ty1 ty2) nb1 ty1 ty1 nb2 ty2 ty2 } + +uTys :: InBox -> TcType -> InBox -> TcType -> TcM CoercionI +-- The context does not describe ty1,ty2 uTys nb1 ty1 nb2 ty2 - = do { traceTc (text "uTys" <+> ppr ty1 <+> ppr ty2) - ; u_tys False nb1 ty1 ty1 nb2 ty2 ty2 } + = do { traceTc (text "uTys" <+> ppr ty1 <+> ppr ty2) + ; u_tys (Unify False ty1 ty2) nb1 ty1 ty1 nb2 ty2 ty2 } -------------- @@ -1068,8 +1086,7 @@ uTys_s :: InBox -> [TcType] -- tys1 are the *actual* types uTys_s nb1 [] nb2 [] = return [] uTys_s nb1 (ty1:tys1) nb2 (ty2:tys2) = do { coi <- uTys nb1 ty1 nb2 ty2 ; cois <- uTys_s nb1 tys1 nb2 tys2 - ; return (coi:cois) - } + ; return (coi:cois) } uTys_s nb1 ty1s nb2 ty2s = panic "Unify.uTys_s: mismatched type lists!" -------------- @@ -1079,43 +1096,48 @@ u_tys :: Outer -> TcM CoercionI u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 - = do { traceTc (text "u_tys " <+> ppr ty1 <+> text " " <+> ppr ty2) - ; coi <- go outer ty1 ty2 + = do { traceTc (text "u_tys " <+> vcat [sep [ braces (ppr orig_ty1 <+> text "/" <+> ppr ty1), + text "~", + braces (ppr orig_ty2 <+> text "/" <+> ppr ty2)], + ppr outer]) + ; coi <- go outer orig_ty1 ty1 orig_ty2 ty2 ; traceTc (case coi of - ACo co -> text "u_tys yields coercion: " <+> ppr co + ACo co -> text "u_tys yields coercion:" <+> ppr co IdCo -> text "u_tys yields no coercion") ; return coi } where - - go :: Outer -> TcType -> TcType -> TcM CoercionI - go outer ty1 ty2 = - do { traceTc (text "go " <+> ppr orig_ty1 <+> text "/" <+> ppr ty1 - <+> ppr orig_ty2 <+> text "/" <+> ppr ty2) - ; go1 outer ty1 ty2 - } - - go1 :: Outer -> TcType -> TcType -> TcM CoercionI + bale_out :: Outer -> TcM a + bale_out outer = unifyMisMatch outer + -- We report a mis-match in terms of the original arugments to + -- u_tys, even though 'go' has recursed inwards somewhat + -- + -- Note [Unifying AppTy] + -- A case in point is unifying (m Int) ~ (IO Int) + -- where m is a unification variable that is now bound to (say) (Bool ->) + -- Then we want to report "Can't unify (Bool -> Int) with (IO Int) + -- and not "Can't unify ((->) Bool) with IO" + + go :: Outer -> TcType -> TcType -> TcType -> TcType -> TcM CoercionI -- Always expand synonyms: see Note [Unification and synonyms] -- (this also throws away FTVs) - go1 outer ty1 ty2 - | Just ty1' <- tcView ty1 = go False ty1' ty2 - | Just ty2' <- tcView ty2 = go False ty1 ty2' + go outer sty1 ty1 sty2 ty2 + | Just ty1' <- tcView ty1 = go (Unify False ty1' ty2 ) sty1 ty1' sty2 ty2 + | Just ty2' <- tcView ty2 = go (Unify False ty1 ty2') sty1 ty1 sty2 ty2' -- Variables; go for uVar - go1 outer (TyVarTy tyvar1) ty2 = uVar outer False tyvar1 nb2 orig_ty2 ty2 - go1 outer ty1 (TyVarTy tyvar2) = uVar outer True tyvar2 nb1 orig_ty1 ty1 + go outer sty1 (TyVarTy tyvar1) sty2 ty2 = uVar outer False tyvar1 nb2 sty2 ty2 + go outer sty1 ty1 sty2 (TyVarTy tyvar2) = uVar outer True tyvar2 nb1 sty1 ty1 -- "True" means args swapped -- The case for sigma-types must *follow* the variable cases -- because a boxy variable can be filed with a polytype; -- but must precede FunTy, because ((?x::Int) => ty) look -- like a FunTy; there isn't necy a forall at the top - go1 _ ty1 ty2 + go _ _ ty1 _ ty2 | isSigmaTy ty1 || isSigmaTy ty2 = do { traceTc (text "We have sigma types: equalLength" <+> ppr tvs1 <+> ppr tvs2) - ; unless (equalLength tvs1 tvs2) - (unifyMisMatch outer False orig_ty1 orig_ty2) + ; unless (equalLength tvs1 tvs2) (bale_out outer) ; traceTc (text "We're past the first length test") ; tvs <- tcInstSkolTyVars UnkSkol tvs1 -- Not a helpful SkolemInfo -- Get location from monad, not from tvs1 @@ -1127,10 +1149,8 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 (theta2,tau2) = tcSplitPhiTy phi2 ; addErrCtxtM (unifyForAllCtxt tvs phi1 phi2) $ do - { unless (equalLength theta1 theta2) - (unifyMisMatch outer False orig_ty1 orig_ty2) - - ; cois <- uPreds False nb1 theta1 nb2 theta2 -- TOMDO: do something with these pred_cois + { unless (equalLength theta1 theta2) (bale_out outer) + ; cois <- uPreds outer nb1 theta1 nb2 theta2 -- TOMDO: do something with these pred_cois ; traceTc (text "TOMDO!") ; coi <- uTys nb1 tau1 nb2 tau2 @@ -1153,11 +1173,11 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 (tvs2, body2) = tcSplitForAllTys ty2 -- Predicates - go1 outer (PredTy p1) (PredTy p2) - = uPred False nb1 p1 nb2 p2 + go outer _ (PredTy p1) _ (PredTy p2) + = uPred outer nb1 p1 nb2 p2 -- Type constructors must match - go1 _ (TyConApp con1 tys1) (TyConApp con2 tys2) + go _ _ (TyConApp con1 tys1) _ (TyConApp con2 tys2) | con1 == con2 && not (isOpenSynTyCon con1) = do { cois <- uTys_s nb1 tys1 nb2 tys2 ; return $ mkTyConAppCoI con1 tys1 cois @@ -1175,7 +1195,7 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 -- See Note [OpenSynTyCon app] -- Functions; just check the two parts - go1 _ (FunTy fun1 arg1) (FunTy fun2 arg2) + go _ _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) = do { coi_l <- uTys nb1 fun1 nb2 fun2 ; coi_r <- uTys nb1 arg1 nb2 arg2 ; return $ mkFunTyCoI fun1 coi_l arg1 coi_r @@ -1185,22 +1205,24 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 -- They can match FunTy and TyConApp, so use splitAppTy_maybe -- NB: we've already dealt with type variables and Notes, -- so if one type is an App the other one jolly well better be too - go1 outer (AppTy s1 t1) ty2 + go outer _ (AppTy s1 t1) _ ty2 | Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = do { coi_s <- uTys nb1 s1 nb2 s2; coi_t <- uTys nb1 t1 nb2 t2 + = do { coi_s <- go outer s1 s1 s2 s2 -- NB recurse into go + ; coi_t <- uTys nb1 t1 nb2 t2 -- See Note [Unifying AppTy] ; return $ mkAppTyCoI s1 coi_s t1 coi_t } -- Now the same, but the other way round -- Don't swap the types, because the error messages get worse - go1 outer ty1 (AppTy s2 t2) + go outer _ ty1 _ (AppTy s2 t2) | Just (s1,t1) <- tcSplitAppTy_maybe ty1 - = do { coi_s <- uTys nb1 s1 nb2 s2; coi_t <- uTys nb1 t1 nb2 t2 + = do { coi_s <- go outer s1 s1 s2 s2 + ; coi_t <- uTys nb1 t1 nb2 t2 ; return $ mkAppTyCoI s1 coi_s t1 coi_t } -- One or both outermost constructors are type family applications. -- If we can normalise them away, proceed as usual; otherwise, we -- need to defer unification by generating a wanted equality constraint. - go1 outer ty1 ty2 + go outer sty1 ty1 sty2 ty2 | ty1_is_fun || ty2_is_fun = do { (coi1, ty1') <- if ty1_is_fun then tcNormaliseFamInst ty1 else return (IdCo, ty1) @@ -1217,7 +1239,7 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 defer_unification outer False orig_ty1 orig_ty2 } else -- unification can proceed - go outer ty1' ty2' + go outer sty1 ty1' sty2 ty2' ; return $ coi1 `mkTransCoI` coi `mkTransCoI` (mkSymCoI coi2) } where @@ -1225,8 +1247,7 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 ty2_is_fun = isOpenSynTyConApp ty2 -- Anything else fails - go1 outer _ _ = unifyMisMatch outer False orig_ty1 orig_ty2 - + go outer _ _ _ _ = bale_out outer ---------- uPred outer nb1 (IParam n1 t1) nb2 (IParam n2 t2) @@ -1239,15 +1260,15 @@ uPred outer nb1 (ClassP c1 tys1) nb2 (ClassP c2 tys2) do { cois <- uTys_s nb1 tys1 nb2 tys2 -- Guaranteed equal lengths because the kinds check ; return $ mkClassPPredCoI c1 tys1 cois } -uPred outer _ p1 _ p2 = unifyMisMatch outer False (mkPredTy p1) (mkPredTy p2) +uPred outer _ p1 _ p2 = unifyMisMatch outer uPreds outer nb1 [] nb2 [] = return [] uPreds outer nb1 (p1:ps1) nb2 (p2:ps2) = - do { coi <- uPred outer nb1 p1 nb2 p2 + do { coi <- uPred outer nb1 p1 nb2 p2 ; cois <- uPreds outer nb1 ps1 nb2 ps2 ; return (coi:cois) } -uPreds outer nb1 ps1 nb2 ps2 = panic "uPreds" +uPreds outer nb1 ps1 nb2 ps2 = panic "uPreds" \end{code} Note [TyCon app] @@ -1347,9 +1368,9 @@ uVar :: Outer uVar outer swapped tv1 nb2 ps_ty2 ty2 = do { let expansion | showSDoc (ppr ty2) == showSDoc (ppr ps_ty2) = empty | otherwise = brackets (equals <+> ppr ty2) - ; traceTc (text "uVar" <+> ppr swapped <+> + ; traceTc (text "uVar" <+> ppr outer <+> ppr swapped <+> sep [ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1 ), - nest 2 (ptext SLIT(" <-> ")), + nest 2 (ptext (sLit " <-> ")), ppr ps_ty2 <+> dcolon <+> ppr (typeKind ty2) <+> expansion]) ; details <- lookupTcTyVar tv1 ; case details of @@ -1371,7 +1392,9 @@ uUnfilledVar :: Outer uUnfilledVar outer swapped tv1 details1 ps_ty2 ty2 | Just ty2' <- tcView ty2 = -- Expand synonyms; ignore FTVs - uUnfilledVar False swapped tv1 details1 ps_ty2 ty2' + let outer' | swapped = Unify False ty2' (mkTyVarTy tv1) + | otherwise = Unify False (mkTyVarTy tv1) ty2' + in uUnfilledVar outer' swapped tv1 details1 ps_ty2 ty2' uUnfilledVar outer swapped tv1 details1 ps_ty2 (TyVarTy tv2) | tv1 == tv2 -- Same type variable => no-op (but watch out for the boxy case) @@ -1395,8 +1418,7 @@ uUnfilledVar outer swapped tv1 details1 ps_ty2 non_var_ty2 = -- ty2 is not a type variable case details1 of MetaTv (SigTv _) _ -> rigid_variable - MetaTv info ref1 -> - uMetaVar outer swapped tv1 info ref1 ps_ty2 non_var_ty2 + MetaTv info ref1 -> uMetaVar outer swapped tv1 info ref1 ps_ty2 non_var_ty2 SkolemTv _ -> rigid_variable where rigid_variable @@ -1418,7 +1440,7 @@ uUnfilledVar outer swapped tv1 details1 ps_ty2 non_var_ty2 } | SkolemTv RuntimeUnkSkol <- details1 -- runtime unknown will never match - = unifyMisMatch outer swapped (TyVarTy tv1) ps_ty2 + = unifyMisMatch outer | otherwise -- defer as a given equality may still resolve this = defer_unification outer swapped (TyVarTy tv1) ps_ty2 \end{code} @@ -1453,7 +1475,7 @@ type. We need to zonk as the types go into the kind of the coercion variable to zonk in zonInst instead. Would that be sufficient?) \begin{code} -defer_unification :: Bool -- pop innermost context? +defer_unification :: Outer -> SwapFlag -> TcType -> TcType @@ -1467,13 +1489,13 @@ defer_unification outer False ty1 ty2 ; cotv <- newMetaCoVar ty1' ty2' -- put ty1 ~ ty2 in LIE -- Left means "wanted" - ; inst <- (if outer then popErrCtxt else id) $ + ; inst <- popUnifyCtxt outer $ mkEqInst (EqPred ty1' ty2') (Left cotv) ; extendLIE inst ; return $ ACo $ TyVarTy cotv } ---------------- -uMetaVar :: Bool -- pop innermost context? +uMetaVar :: Outer -> SwapFlag -> TcTyVar -> BoxInfo -> IORef MetaDetails -> TcType -> TcType @@ -1487,17 +1509,17 @@ uMetaVar outer swapped tv1 BoxTv ref1 ps_ty2 non_var_ty2 -- -- It should not be the case that tv1 occurs in ty2 -- (i.e. no occurs check should be needed), but if perchance - -- it does, the unbox operation will fill it, and the DEBUG + -- it does, the unbox operation will fill it, and the debug code -- checks for that. - do { final_ty <- unBox ps_ty2 -#ifdef DEBUG - ; meta_details <- readMutVar ref1 - ; case meta_details of - Indirect ty -> WARN( True, ppr tv1 <+> ppr ty ) - return () -- This really should *not* happen - Flexi -> return () -#endif - ; checkUpdateMeta swapped tv1 ref1 final_ty + do { final_ty <- unBox ps_ty2 + ; when debugIsOn $ do + { meta_details <- readMutVar ref1 + ; case meta_details of + Indirect ty -> WARN( True, ppr tv1 <+> ppr ty ) + return () -- This really should *not* happen + Flexi -> return () + } + ; checkUpdateMeta swapped tv1 ref1 final_ty ; return IdCo } @@ -1637,7 +1659,6 @@ unBox :: BoxyType -> TcM TcType -- -- For once, it's safe to treat synonyms as opaque! -unBox (NoteTy n ty) = do { ty' <- unBox ty; return (NoteTy n ty') } unBox (TyConApp tc tys) = do { tys' <- mapM unBox tys; return (TyConApp tc tys') } unBox (AppTy f a) = do { f' <- unBox f; a' <- unBox a; return (mkAppTy f' a') } unBox (FunTy f a) = do { f' <- unBox f; a' <- unBox a; return (FunTy f' a') } @@ -1667,14 +1688,21 @@ unBoxPred (EqPred ty1 ty2) = do { ty1' <- unBox ty1; ty2' <- unBox ty2; return ( %************************************************************************ %* * -\subsection[Unify-context]{Errors and contexts} + Errors and contexts %* * %************************************************************************ -Errors -~~~~~~ - \begin{code} +unifyMisMatch :: Outer -> TcM a +unifyMisMatch (Unify is_outer ty1 ty2) + | is_outer = popErrCtxt $ failWithMisMatch ty1 ty2 -- This is the whole point of the 'outer' stuff + | otherwise = failWithMisMatch ty1 ty2 + +popUnifyCtxt :: Outer -> TcM a -> TcM a +popUnifyCtxt (Unify True _ _) thing = popErrCtxt thing +popUnifyCtxt (Unify False _ _) thing = thing + +----------------------- unifyCtxt act_ty exp_ty tidy_env = do { act_ty' <- zonkTcType act_ty ; exp_ty' <- zonkTcType exp_ty @@ -1712,9 +1740,9 @@ addSubCtxt orig actual_res_ty expected_res_ty thing_inside ; return (env2, message) } wrongArgsCtxt too_many_or_few fun - = ptext SLIT("Probable cause:") <+> quotes (ppr fun) - <+> ptext SLIT("is applied to") <+> text too_many_or_few - <+> ptext SLIT("arguments") + = ptext (sLit "Probable cause:") <+> quotes (ppr fun) + <+> ptext (sLit "is applied to") <+> text too_many_or_few + <+> ptext (sLit "arguments") ------------------ unifyForAllCtxt tvs phi1 phi2 env @@ -1723,17 +1751,12 @@ unifyForAllCtxt tvs phi1 phi2 env (env', tvs') = tidyOpenTyVars env tvs -- NB: not tidyTyVarBndrs (env1, phi1') = tidyOpenType env' phi1 (env2, phi2') = tidyOpenType env1 phi2 - msg = vcat [ptext SLIT("When matching") <+> quotes (ppr (mkForAllTys tvs' phi1')), - ptext SLIT(" and") <+> quotes (ppr (mkForAllTys tvs' phi2'))] - ------------------------ -unifyMisMatch outer swapped ty1 ty2 - | swapped = unifyMisMatch outer False ty2 ty1 - | outer = popErrCtxt $ unifyMisMatch False swapped ty1 ty2 -- This is the whole point of the 'outer' stuff - | otherwise = failWithMisMatch ty1 ty2 + msg = vcat [ptext (sLit "When matching") <+> quotes (ppr (mkForAllTys tvs' phi1')), + ptext (sLit " and") <+> quotes (ppr (mkForAllTys tvs' phi2'))] \end{code} + %************************************************************************ %* * Kind unification @@ -1819,7 +1842,7 @@ kindSimpleKind orig_swapped orig_kind | isLiftedTypeKind k = return liftedTypeKind | isUnliftedTypeKind k = return unliftedTypeKind go sw k@(TyVarTy _) = return k -- KindVars are always simple - go swapped kind = failWithTc (ptext SLIT("Unexpected kind unification failure:") + go swapped kind = failWithTc (ptext (sLit "Unexpected kind unification failure:") <+> ppr orig_swapped <+> ppr orig_kind) -- I think this can't actually happen @@ -1828,7 +1851,7 @@ kindSimpleKind orig_swapped orig_kind ---------------- kindOccurCheckErr tyvar ty - = hang (ptext SLIT("Occurs check: cannot construct the infinite kind:")) + = hang (ptext (sLit "Occurs check: cannot construct the infinite kind:")) 2 (sep [ppr tyvar, char '=', ppr ty]) \end{code} @@ -1896,25 +1919,25 @@ checkExpectedKind ty act_kind exp_kind (env2, tidy_act_kind) = tidyKind env1 act_kind err | n_exp_as < n_act_as -- E.g. [Maybe] - = quotes (ppr ty) <+> ptext SLIT("is not applied to enough type arguments") + = quotes (ppr ty) <+> ptext (sLit "is not applied to enough type arguments") -- Now n_exp_as >= n_act_as. In the next two cases, -- n_exp_as == 0, and hence so is n_act_as | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind - = ptext SLIT("Expecting a lifted type, but") <+> quotes (ppr ty) - <+> ptext SLIT("is unlifted") + = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty) + <+> ptext (sLit "is unlifted") | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind - = ptext SLIT("Expecting an unlifted type, but") <+> quotes (ppr ty) - <+> ptext SLIT("is lifted") + = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty) + <+> ptext (sLit "is lifted") | otherwise -- E.g. Monad [Int] - = ptext SLIT("Kind mis-match") + = ptext (sLit "Kind mis-match") - more_info = sep [ ptext SLIT("Expected kind") <+> + more_info = sep [ ptext (sLit "Expected kind") <+> quotes (pprKind tidy_exp_kind) <> comma, - ptext SLIT("but") <+> quotes (ppr ty) <+> - ptext SLIT("has kind") <+> quotes (pprKind tidy_act_kind)] + ptext (sLit "but") <+> quotes (ppr ty) <+> + ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)] failWithTcM (env2, err $$ more_info) \end{code} @@ -1999,7 +2022,7 @@ bleatEscapedTvs globals sig_tvs zonked_tvs ; (env3, msgs) <- foldlM check (env2, []) (tidy_tvs `zip` tidy_zonked_tvs) ; failWithTcM (env3, main_msg $$ nest 2 (vcat msgs)) } where - main_msg = ptext SLIT("Inferred type is less polymorphic than expected") + main_msg = ptext (sLit "Inferred type is less polymorphic than expected") check (tidy_env, msgs) (sig_tv, zonked_tv) | not (zonked_tv `elemVarSet` globals) = return (tidy_env, msgs) @@ -2010,18 +2033,18 @@ bleatEscapedTvs globals sig_tvs zonked_tvs ----------------------- escape_msg sig_tv zonked_tv globs | notNull globs - = vcat [sep [msg, ptext SLIT("is mentioned in the environment:")], + = vcat [sep [msg, ptext (sLit "is mentioned in the environment:")], nest 2 (vcat globs)] | otherwise - = msg <+> ptext SLIT("escapes") + = msg <+> ptext (sLit "escapes") -- Sigh. It's really hard to give a good error message -- all the time. One bad case is an existential pattern match. -- We rely on the "When..." context to help. where - msg = ptext SLIT("Quantified type variable") <+> quotes (ppr sig_tv) <+> is_bound_to + msg = ptext (sLit "Quantified type variable") <+> quotes (ppr sig_tv) <+> is_bound_to is_bound_to | sig_tv == zonked_tv = empty - | otherwise = ptext SLIT("is unified with") <+> quotes (ppr zonked_tv) <+> ptext SLIT("which") + | otherwise = ptext (sLit "is unified with") <+> quotes (ppr zonked_tv) <+> ptext (sLit "which") \end{code} These two context are used with checkSigTyVars @@ -2035,10 +2058,10 @@ sigCtxt id sig_tvs sig_theta sig_tau tidy_env = do (env1, tidy_sig_tvs) = tidyOpenTyVars tidy_env sig_tvs (env2, tidy_sig_rho) = tidyOpenType env1 (mkPhiTy sig_theta sig_tau) (env3, tidy_actual_tau) = tidyOpenType env2 actual_tau - sub_msg = vcat [ptext SLIT("Signature type: ") <+> pprType (mkForAllTys tidy_sig_tvs tidy_sig_rho), - ptext SLIT("Type to generalise:") <+> pprType tidy_actual_tau + sub_msg = vcat [ptext (sLit "Signature type: ") <+> pprType (mkForAllTys tidy_sig_tvs tidy_sig_rho), + ptext (sLit "Type to generalise:") <+> pprType tidy_actual_tau ] - msg = vcat [ptext SLIT("When trying to generalise the type inferred for") <+> quotes (ppr id), + msg = vcat [ptext (sLit "When trying to generalise the type inferred for") <+> quotes (ppr id), nest 2 sub_msg] return (env3, msg)