X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcUnify.lhs;h=56652c7d8ce21aaf673930cd4853424665ef016d;hb=b5bb34f029d3f68d966c0b9ed79305e3d9aac98c;hp=367536babb20ae4b185b1ad0f259d7adf094a5ec;hpb=aaed05e88978688e37dc74177dd4eba51a6ab4d0;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 367536b..56652c7 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -611,7 +611,10 @@ 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 + go _ (TyVarTy tv) | isTcTyVar tv && isMetaTyVar tv + -- NB: A TyVar (not TcTyVar) is possible here, representing + -- a skolem, because in this pure boxy_match function + -- we don't instantiate foralls to TcTyVars; cf Trac #2714 = 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 @@ -1192,13 +1195,13 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 go outer _ (PredTy p1) _ (PredTy p2) = uPred outer nb1 p1 nb2 p2 - -- Type constructors must match + -- Non-synonym type constructors must match 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 } - -- See Note [TyCon app] + -- Family synonyms See Note [TyCon app] | con1 == con2 && identicalOpenSynTyConApp = do { cois <- uTys_s nb1 tys1' nb2 tys2' ; return $ mkTyConAppCoI con1 tys1 (replicate n IdCo ++ cois) @@ -1210,6 +1213,29 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 identicalOpenSynTyConApp = idxTys1 `tcEqTypes` idxTys2 -- See Note [OpenSynTyCon app] + -- If we can reduce a family app => proceed with reduct + -- NB: We use isOpenSynTyCon, not isOpenSynTyConApp as we also must + -- defer oversaturated applications! + go outer sty1 ty1@(TyConApp con1 _) sty2 ty2 + | isOpenSynTyCon con1 + = do { (coi1, ty1') <- tcNormaliseFamInst ty1 + ; case coi1 of + IdCo -> defer -- no reduction, see [Deferred Unification] + _ -> liftM (coi1 `mkTransCoI`) $ go outer sty1 ty1' sty2 ty2 + } + + -- If we can reduce a family app => proceed with reduct + -- NB: We use isOpenSynTyCon, not isOpenSynTyConApp as we also must + -- defer oversaturated applications! + go outer sty1 ty1 sty2 ty2@(TyConApp con2 _) + | isOpenSynTyCon con2 + = do { (coi2, ty2') <- tcNormaliseFamInst ty2 + ; case coi2 of + IdCo -> defer -- no reduction, see [Deferred Unification] + _ -> liftM (`mkTransCoI` mkSymCoI coi2) $ + go outer sty1 ty1 sty2 ty2' + } + -- Functions; just check the two parts go _ _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) = do { coi_l <- uTys nb1 fun1 nb2 fun2 @@ -1235,36 +1261,12 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 ; 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. - 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) - ; (coi2, ty2') <- if ty2_is_fun then tcNormaliseFamInst ty2 - else return (IdCo, ty2) - ; coi <- if isOpenSynTyConApp ty1' || isOpenSynTyConApp ty2' - then do { -- One type family app can't be reduced yet - -- => defer - ; ty1'' <- zonkTcType ty1' - ; ty2'' <- zonkTcType ty2' - ; if tcEqType ty1'' ty2'' - then return IdCo - else -- see [Deferred Unification] - defer_unification outer False orig_ty1 orig_ty2 - } - else -- unification can proceed - go outer sty1 ty1' sty2 ty2' - ; return $ coi1 `mkTransCoI` coi `mkTransCoI` (mkSymCoI coi2) - } - where - ty1_is_fun = isOpenSynTyConApp ty1 - ty2_is_fun = isOpenSynTyConApp ty2 - -- Anything else fails go outer _ _ _ _ = bale_out outer + defer = defer_unification outer False orig_ty1 orig_ty2 + + ---------- uPred :: Outer -> InBox -> PredType -> InBox -> PredType -> TcM CoercionI uPred _ nb1 (IParam n1 t1) nb2 (IParam n2 t2) @@ -1295,8 +1297,8 @@ Note [TyCon app] When we find two TyConApps, the argument lists are guaranteed equal length. Reason: intially the kinds of the two types to be unified is the same. The only way it can become not the same is when unifying two -AppTys (f1 a1):=:(f2 a2). In that case there can't be a TyConApp in -the f1,f2 (because it'd absorb the app). If we unify f1:=:f2 first, +AppTys (f1 a1)~(f2 a2). In that case there can't be a TyConApp in +the f1,f2 (because it'd absorb the app). If we unify f1~f2 first, which we do, that ensures that f1,f2 have the same kind; and that means a1,a2 have the same kind. And now the argument repeats. @@ -1871,7 +1873,7 @@ kindSimpleKind :: Bool -> Kind -> TcM SimpleKind -- (kindSimpleKind True k) returns a simple kind sk such that sk <: k -- If the flag is False, it requires k <: sk -- E.g. kindSimpleKind False ?? = * --- What about (kv -> *) :=: ?? -> * +-- What about (kv -> *) ~ ?? -> * kindSimpleKind orig_swapped orig_kind = go orig_swapped orig_kind where @@ -2039,7 +2041,7 @@ check_sig_tyvars check_sig_tyvars _ [] = return () check_sig_tyvars extra_tvs sig_tvs - = ASSERT( all isSkolemTyVar sig_tvs ) + = ASSERT( all isTcTyVar sig_tvs && all isSkolemTyVar sig_tvs ) do { gbl_tvs <- tcGetGlobalTyVars ; traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tvs, text "gbl_tvs" <+> ppr gbl_tvs,