+
+tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
+ -> Expected TcRhoType -- Expected result type of application
+ -> TcM (HsExpr TcId) -- Translated fun and args
+
+tcApp (L _ (HsApp e1 e2)) args res_ty
+ = tcApp e1 (e2:args) res_ty -- Accumulate the arguments
+
+tcApp fun args res_ty
+ = do { let n_args = length args
+ ; (fun', fun_tvs, fun_tau) <- tcFun fun -- Type-check the function
+
+ -- Extract its argument types
+ ; (expected_arg_tys, actual_res_ty)
+ <- do { traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_tau))
+ ; let msg = sep [ptext SLIT("The function") <+> quotes (ppr fun),
+ ptext SLIT("is applied to")
+ <+> speakN n_args <+> ptext SLIT("arguments")]
+ ; unifyFunTys msg n_args fun_tau }
+
+ ; case res_ty of
+ Check _ -> do -- Connect to result type first
+ -- See Note [Push result type in]
+ { co_fn <- tcResult fun args res_ty actual_res_ty
+ ; the_app' <- tcArgs fun fun' args expected_arg_tys
+ ; traceTc (text "tcApp: check" <+> vcat [ppr fun <+> ppr args,
+ ppr the_app', ppr actual_res_ty])
+ ; returnM (co_fn <$> the_app') }
+
+ Infer _ -> do -- Type check args first, then
+ -- refine result type, then do tcResult
+ { the_app' <- tcArgs fun fun' args expected_arg_tys
+ ; subst <- refineTyVars fun_tvs
+ ; let actual_res_ty' = substTy subst actual_res_ty
+ ; co_fn <- tcResult fun args res_ty actual_res_ty'
+ ; traceTc (text "tcApp: infer" <+> vcat [ppr fun <+> ppr args, ppr the_app',
+ ppr actual_res_ty, ppr actual_res_ty'])
+ ; returnM (co_fn <$> the_app') }
+ }
+
+-- Note [Push result type in]
+--
+-- Unify with expected result before (was: after) type-checking the args
+-- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
+-- This is when we might detect a too-few args situation.
+-- (One can think of cases when the opposite order would give
+-- a better error message.)
+-- [March 2003: I'm experimenting with putting this first. Here's an
+-- example where it actually makes a real difference
+-- class C t a b | t a -> b
+-- instance C Char a Bool
+--
+-- data P t a = forall b. (C t a b) => MkP b
+-- data Q t = MkQ (forall a. P t a)
+
+-- f1, f2 :: Q Char;
+-- f1 = MkQ (MkP True)
+-- f2 = MkQ (MkP True :: forall a. P Char a)
+--
+-- With the change, f1 will type-check, because the 'Char' info from
+-- the signature is propagated into MkQ's argument. With the check
+-- in the other order, the extra signature in f2 is reqd.]
+
+----------------
+tcFun :: LHsExpr Name -> TcM (LHsExpr TcId, [TcTyVar], TcRhoType)
+-- Instantiate the function, returning the type variables used
+-- If the function isn't simple, infer its type, and return no
+-- type variables
+tcFun (L loc (HsVar f)) = setSrcSpan loc $ do
+ { (fun', tvs, fun_tau) <- tcId (OccurrenceOf f) f
+ ; return (L loc fun', tvs, fun_tau) }
+tcFun fun = do { (fun', fun_tau) <- tcInfer (tcMonoExpr fun)
+ ; return (fun', [], fun_tau) }
+
+----------------
+tcArgs :: LHsExpr Name -- The function (for error messages)
+ -> LHsExpr TcId -- The function (to build into result)
+ -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
+ -> TcM (HsExpr TcId) -- Resulting application
+
+tcArgs fun fun' args expected_arg_tys
+ = do { args' <- mappM (tcArg fun) (zip3 args expected_arg_tys [1..])
+ ; return (unLoc (foldl mkHsApp fun' args')) }
+
+tcArg :: LHsExpr Name -- The function (for error messages)
+ -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type
+ -> TcM (LHsExpr TcId) -- Resulting argument
+tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
+ (tcCheckSigma arg ty)
+
+----------------
+tcResult fun args res_ty actual_res_ty
+ = addErrCtxtM (checkArgsCtxt fun args res_ty actual_res_ty)
+ (tcSubExp res_ty actual_res_ty)
+
+----------------
+-- If an error happens we try to figure out whether the
+-- function has been given too many or too few arguments,
+-- and say so.
+-- The ~(Check...) is because in the Infer case the tcSubExp
+-- definitely won't fail, so we can be certain we're in the Check branch
+checkArgsCtxt fun args (Infer _) actual_res_ty tidy_env
+ = return (tidy_env, ptext SLIT("Urk infer"))
+
+checkArgsCtxt fun args (Check expected_res_ty) actual_res_ty tidy_env
+ = zonkTcType expected_res_ty `thenM` \ exp_ty' ->
+ zonkTcType actual_res_ty `thenM` \ act_ty' ->
+ let
+ (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
+ (env2, act_ty'') = tidyOpenType env1 act_ty'
+ (exp_args, _) = tcSplitFunTys exp_ty''
+ (act_args, _) = tcSplitFunTys act_ty''
+
+ len_act_args = length act_args
+ len_exp_args = length exp_args
+
+ message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
+ | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
+ | otherwise = appCtxt fun args
+ in
+ returnM (env2, message)
+
+----------------
+unifyInfixTy :: LHsExpr Name -> HsExpr Name -> TcType
+ -> TcM ([TcType], TcType)
+-- This wrapper just prepares the error message for unifyFunTys
+unifyInfixTy op expr op_ty
+ = unifyFunTys msg 2 op_ty
+ where
+ msg = sep [herald <+> quotes (ppr expr),
+ ptext SLIT("requires") <+> quotes (ppr op)
+ <+> ptext SLIT("to take two arguments")]
+ herald = case expr of
+ OpApp _ _ _ _ -> ptext SLIT("The infix expression")
+ other -> ptext SLIT("The operator section")