diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index ace3e5313ec3e5d0ae40a9e8ea3828dc5f1ce2a8..2a17d7694dec27035ffd754221c19b36207ec8db 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -178,7 +178,7 @@ topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-- if topInstantiate ty = (wrap, rho)
-- and e :: ty
-- then wrap e :: rho (that is, wrap :: ty "->" rho)
-topInstantiate = top_instantiate True (Just 0)
+topInstantiate = top_instantiate True (Just 0) False
-- | Instantiate all outer 'Inferred' binders
-- and any context. Never looks through arrows or specified type variables.
@@ -188,26 +188,27 @@ topInstantiateInferred :: CtOrigin -> TcSigmaType
-- if topInstantiate ty = (wrap, rho)
-- and e :: ty
-- then wrap e :: rho
-topInstantiateInferred = top_instantiate False (Just 0)
+topInstantiateInferred = top_instantiate False (Just 0) False
-- | Instantiate all outer type variables
-- and any context. Never looks through arrows.
-- Takes guardedness of variables into account,
-topInstantiateGuarded :: Arity -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-topInstantiateGuarded n = top_instantiate True (Just n)
+topInstantiateGuarded :: Arity -> Bool -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+topInstantiateGuarded n ret_is_guarded = top_instantiate True (Just n) ret_is_guarded
-- | Instantiate all outer type variables
-- and any context. All unification variables become sigma's.
topInstantiateSigma :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-topInstantiateSigma = top_instantiate True Nothing
+topInstantiateSigma = top_instantiate True Nothing True
top_instantiate :: Bool -- True <=> instantiate *all* variables
-- False <=> instantiate only the inferred ones
-> Maybe Arity -- number of provided arguments
- -- Just n <=> n arguments where provided
+ -- Just n <=> n arguments were provided
-- Nothing <=> instantiate everything as sigmas
+ -> Bool -- True <=> consider vars in the return type as guarded
-> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-top_instantiate inst_all prov_args orig ty
+top_instantiate inst_all prov_args ret_is_guarded orig ty
| not (null binders && null theta)
= do { let (inst_bndrs, leave_bndrs) = span should_inst binders
(inst_theta, leave_theta)
@@ -240,7 +241,7 @@ top_instantiate inst_all prov_args orig ty
if null leave_bndrs
-- account for types like forall a. Num a => forall b. Ord b => ...
- then top_instantiate inst_all prov_args orig sigma'
+ then top_instantiate inst_all prov_args ret_is_guarded orig sigma'
-- but don't loop if there were any un-inst'able tyvars
else return (idHsWrapper, sigma')
@@ -259,7 +260,11 @@ top_instantiate inst_all prov_args orig ty
-- look at the prov_args first arguments for guardedness
vars_which_are_guarded
= let Just prov_args' = prov_args
- args_to_look = take prov_args' (fst (splitFunTys rho))
+ (all_args, ret_type) = tcSplitFunTys rho
+ first_n_args = take prov_args' all_args
+ rest_of_args = drop prov_args' all_args ++ [ret_type]
+ should_take_ret = ret_is_guarded && length all_args >= prov_args'
+ args_to_look = first_n_args ++ if should_take_ret then rest_of_args else []
in mapUnionVarSet guarded_vars args_to_look
choice v
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 77fe2ed7c05db0c9e112d68bd373550a56e06296..625fa453d57c69beea4f8bcdabf5ed9a4ec8d209 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1294,7 +1294,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args res_ty herald
go _ _ fun_ty [] deferred_args
| Check res_ty' <- res_ty
- , isEmptyVarSet (unif_vars res_ty')
+ , res_ty_is_fully_known
= do { wrap <- tcSubTypeO fun_orig GenSigCtxt fun_ty res_ty
; args' <- handle_args deferred_args
; return (wrap, args', res_ty')
@@ -1303,9 +1303,6 @@ tcArgs fun orig_fun_ty fun_orig orig_args res_ty herald
= do { args' <- handle_args deferred_args
; return (idHsWrapper, args', fun_ty)
}
- where
- unif_vars ty = filterVarSet (\tv -> isTcTyVar tv && not (isSkolemTyVar tv))
- (exactTyCoVarsOfType ty)
go acc_args n fun_ty (HsArgPar sp : args) deferred_args
= do { let deferred_args' = deferred_args ++ [(HsArgPar sp, Nothing)]
@@ -1355,6 +1352,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args res_ty herald
; (wrap, [arg_ty], res_ty)
<- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty
acc_args orig_expr_args_arity next_val_args
+ res_ty_is_fully_known
-- wrap :: fun_ty "->" arg_ty -> res_ty
-- ; arg' <- tcArg fun arg arg_ty n -- defer it until the end
; let defer_this_arg = (HsValArg arg, Just (arg_ty, n))
@@ -1368,6 +1366,15 @@ tcArgs fun orig_fun_ty fun_orig orig_args res_ty herald
doc = text "When checking the" <+> speakNth n <+>
text "argument to" <+> quotes (ppr fun)
+ res_ty_is_fully_known
+ | Check res_ty' <- res_ty
+ , isEmptyVarSet (unif_vars res_ty')
+ = True
+ | otherwise
+ = False
+ where unif_vars ty = filterVarSet (\tv -> isTcTyVar tv && not (isSkolemTyVar tv))
+ (exactTyCoVarsOfType ty)
+
count_guarding_args [] = 0
count_guarding_args (HsValArg _ : args) = 1 + count_guarding_args args
count_guarding_args (HsArgPar _ : args) = count_guarding_args args
@@ -1391,7 +1398,8 @@ tcArgs fun orig_fun_ty fun_orig orig_args res_ty herald
}
| otherwise
= do { args' <- handle_args args
- ; arg' <- tcArg fun arg arg_ty n
+ ; z_arg_ty <- zonkTcType arg_ty
+ ; arg' <- tcArg fun arg z_arg_ty n
; return (HsValArg arg' : args')
}
handle_args (_ : _) = panic "tcArg/handle_arg"
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index 29dea953f949fd05120d4d4f4bca0165905833c7..3ee5bfc21bd5d31c999f52f132b6ccef662044f1 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -226,8 +226,8 @@ matchActualFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys]
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
-- If matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r)
-- then wrap : ty ~> (t1 -> ... -> tn -> ty_r)
-matchActualFunTys herald ct_orig mb_thing arity ty
- = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity
+matchActualFunTys herald ct_orig mb_thing arity ty provided_args
+ = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity provided_args False
-- | Variant of 'matchActualFunTys' that works when supplied only part
-- (that is, to the right of some arrows) of the full function type
@@ -239,9 +239,10 @@ matchActualFunTysPart :: SDoc -- See Note [Herald for matchExpectedFunTys]
-> [TcSigmaType] -- reversed args. See (*) below.
-> Arity -- overall arity of the function, for errs
-> Arity -- how many arguments are provided explicitly
+ -> Bool -- whether the result type is fully known
-> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
matchActualFunTysPart herald ct_orig mb_thing arity orig_ty
- orig_old_args full_arity provided_args
+ orig_old_args full_arity provided_args ret_is_known
= go arity orig_old_args orig_ty provided_args
-- Does not allocate unnecessary meta variables: if the input already is
-- a function, we just take it apart. Not only is this efficient,
@@ -278,7 +279,7 @@ matchActualFunTysPart herald ct_orig mb_thing arity orig_ty
go n acc_args ty prov_args
| not (null tvs && null theta)
- = do { (wrap1, rho) <- topInstantiateGuarded prov_args ct_orig ty
+ = do { (wrap1, rho) <- topInstantiateGuarded prov_args ret_is_known ct_orig ty
; (wrap2, arg_tys, res_ty) <- go n acc_args rho prov_args
; return (wrap2 <.> wrap1, arg_tys, res_ty) }
where