+tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
+ -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args
+
+tcApp (L _ (HsPar e)) args res_ty
+ = tcApp e args res_ty
+
+tcApp (L _ (HsApp e1 e2)) args res_ty
+ = tcApp e1 (e2:args) res_ty -- Accumulate the arguments
+
+tcApp (L loc (HsVar fun)) args res_ty
+ | fun `hasKey` tagToEnumKey
+ , [arg] <- args
+ = tcTagToEnum loc fun arg res_ty
+
+tcApp fun args res_ty
+ = do { -- Type-check the function
+ ; (fun1, fun_tau) <- tcInferFun fun
+
+ -- Extract its argument types
+ ; (co_fun, expected_arg_tys, actual_res_ty)
+ <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
+
+ -- Typecheck the result, thereby propagating
+ -- info (if any) from result into the argument types
+ -- Both actual_res_ty and res_ty are deeply skolemised
+ ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $
+ unifyType actual_res_ty res_ty
+
+ -- Typecheck the arguments
+ ; args1 <- tcArgs fun args expected_arg_tys
+
+ -- Assemble the result
+ ; let fun2 = mkLHsWrapCo co_fun fun1
+ app = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1)
+
+ ; return (unLoc app) }
+
+
+mk_app_msg :: LHsExpr Name -> SDoc
+mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
+ , ptext (sLit "is applied to")]
+
+----------------
+tcInferApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
+ -> TcM (HsExpr TcId, TcRhoType) -- Translated fun and args
+
+tcInferApp (L _ (HsPar e)) args = tcInferApp e args
+tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args)
+tcInferApp fun args
+ = -- Very like the tcApp version, except that there is
+ -- no expected result type passed in
+ do { (fun1, fun_tau) <- tcInferFun fun
+ ; (co_fun, expected_arg_tys, actual_res_ty)
+ <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
+ ; args1 <- tcArgs fun args expected_arg_tys
+ ; let fun2 = mkLHsWrapCo co_fun fun1
+ app = foldl mkHsApp fun2 args1
+ ; return (unLoc app, actual_res_ty) }
+
+----------------
+tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
+-- Infer and instantiate the type of a function
+tcInferFun (L loc (HsVar name))
+ = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
+ -- Don't wrap a context around a plain Id
+ ; return (L loc fun, ty) }
+
+tcInferFun fun
+ = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
+
+ -- Zonk the function type carefully, to expose any polymorphism
+ -- E.g. (( \(x::forall a. a->a). blah ) e)
+ -- We can see the rank-2 type of the lambda in time to genrealise e
+ ; fun_ty' <- zonkTcTypeCarefully fun_ty
+
+ ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty'
+ ; return (mkLHsWrap wrap fun, rho) }
+
+----------------
+tcArgs :: LHsExpr Name -- The function (for error messages)
+ -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
+ -> TcM [LHsExpr TcId] -- Resulting args
+
+tcArgs fun args expected_arg_tys
+ = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
+
+----------------
+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)
+ (tcPolyExprNC arg ty)
+
+----------------
+tcTupArgs :: [HsTupArg Name] -> [TcSigmaType] -> TcM [HsTupArg TcId]
+tcTupArgs args tys
+ = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
+ where
+ go (Missing {}, arg_ty) = return (Missing arg_ty)
+ go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+ ; return (Present expr') }
+
+----------------
+unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType
+ -> TcM (Coercion, [TcSigmaType], TcRhoType)
+-- A wrapper for matchExpectedFunTys
+unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty
+ where
+ herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes")
+
projects / ghc-hetmet.git / blobdiff