diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2019-11-19 16:52:35 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2019-12-10 11:45:00 +0000 |
| commit | 7fd3cd95f2b99edc02db0f56c8952a342801876f (patch) | |
| tree | c93b5dff0643ba30dc3fff222b1f0e5b7b10ae77 | |
| parent | 247258022d2ec2bffcd414e9fe02d82d4bb6e6c7 (diff) | |
| download | haskell-7fd3cd95f2b99edc02db0f56c8952a342801876f.tar.gz | |
Remove an unnecessary zonk from tcInferApps
Removing zonking is good!
To do this it turned out to be convenient to make
matchExpectedFunKind return the result kind as well as
the coercion
| -rw-r--r-- | compiler/typecheck/TcHsType.hs | 11 | ||||
| -rw-r--r-- | compiler/typecheck/TcUnify.hs | 18 |
2 files changed, 16 insertions, 13 deletions
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 008eb2b896..6ae7a4c444 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -1154,19 +1154,18 @@ tcInferApps_nosat mode orig_hs_ty fun orig_hs_args (HsValArg _ : _, Nothing) -> try_again_after_substing_or $ do { let arrows_needed = n_initial_val_args all_args - ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki + ; (co, co_res_kind) <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki - ; fun' <- zonkTcType (fun `mkTcCastTy` co) - -- This zonk is essential, to expose the fruits - -- of matchExpectedFunKind to the 'go' loop + ; let fun' = fun `mkTcCastTy` co + -- NB: typeKind fun' = co_res_kind ; traceTc "tcInferApps (no binder)" $ vcat [ ppr fun <+> dcolon <+> ppr fun_ki , ppr arrows_needed , ppr co , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')] - ; go_init n fun' all_args } - -- Use go_init to establish go's INVARIANT + ; go n fun' subst co_res_kind all_args } + -- NB: subst is empty but we need its in-scope set where instantiate ki_binder inner_ki = do { traceTc "tcInferApps (need to instantiate)" diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 9f9e69850d..d5842806d4 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -1685,7 +1685,7 @@ uUnfilledVar2 :: CtOrigin -> SwapFlag -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2, zonked + -> TcTauType -- Type 2, zonked, to make occurs check easy -> TcM Coercion uUnfilledVar2 origin t_or_k swapped tv1 ty2 = do { dflags <- getDynFlags @@ -2082,11 +2082,13 @@ matchExpectedFunKind => fun -- ^ type, only for errors -> Arity -- ^ n: number of desired arrows -> TcKind -- ^ fun_ kind - -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) + -> TcM (Coercion, TcKind) + -- ^ co :: fun_kind ~ fun_kind' + -- ^ fun_kind' = arg1 -> ... -> argn -> res matchExpectedFunKind hs_ty n k = go n k where - go 0 k = return (mkNomReflCo k) + go 0 k = return (mkNomReflCo k, k) go n k | Just k' <- tcView k = go n k' @@ -2097,9 +2099,10 @@ matchExpectedFunKind hs_ty n k = go n k Indirect fun_kind -> go n fun_kind Flexi -> defer n k } - go n (FunTy _ arg res) - = do { co <- go (n-1) res - ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) } + go n (FunTy af arg res) + = do { (co, k') <- go (n-1) res + ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co + , mkFunTy af arg k') } go n other = defer n other @@ -2113,7 +2116,8 @@ matchExpectedFunKind hs_ty n k = go n k , uo_thing = Just (ppr hs_ty) , uo_visible = True } - ; uType KindLevel origin k new_fun } + ; co <- uType KindLevel origin k new_fun + ; return (co, new_fun) } {- ********************************************************************* * * |