-tcApp :: (TypecheckedExpr -> [TypecheckedExpr] -> TypecheckedExpr) -- Result builder
- -> E
- -> RenamedExpr
- -> [RenamedExpr]
- -> TcM (TypecheckedExpr, LIE, UniType)
-
-tcApp build_result_expression e orig_fun arg_exprs
- = tcExpr' e orig_fun (length arg_exprs)
- `thenTc` \ (fun', lie_fun, fun_ty) ->
- unify_fun 1 fun' lie_fun arg_exprs fun_ty
- where
- -- Used only in the error message
- maybe_fun_id = case orig_fun of
- Var name -> Just (lookupE_Value e name)
- other -> Nothing
-
- unify_args :: Int -- Current argument number
- -> TypecheckedExpr -- Current rebuilt expression
- -> LIE -- Corresponding LIE
- -> [RenamedExpr] -- Remaining args
- -> [TauType] -- Remaining arg types
- -> TauType -- result type
- -> TcM (TypecheckedExpr, LIE, UniType)
-
- unify_args arg_no fun lie (arg:args) (arg_ty:arg_tys) fun_res_ty
- = tcExpr e arg `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
-
- -- These applyTcSubstToTy's are just to improve the error message...
- applyTcSubstToTy actual_arg_ty `thenNF_Tc` \ actual_arg_ty' ->
- applyTcSubstToTy arg_ty `thenNF_Tc` \ arg_ty' ->
- let
- err_ctxt = FunAppCtxt orig_fun maybe_fun_id arg arg_ty' actual_arg_ty' arg_no
- in
- matchArgTy e arg_ty' arg' lie_arg actual_arg_ty' err_ctxt
- `thenTc` \ (arg'', lie_arg') ->
+tcDoStmts :: Bool -- True => require a monad
+ -> TcType s -- m
+ -> [RenamedStmt]
+ -> TcM s (([TcStmt s],
+ Bool, -- True => Monad
+ Bool), -- True => MonadZero
+ LIE s,
+ TcType s)
+
+tcDoStmts monad m [stmt@(ExprStmt exp src_loc)]
+ = tcAddSrcLoc src_loc $
+ tcSetErrCtxt (stmtCtxt stmt) $
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ (if monad then
+ newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
+ unifyTauTy (mkAppTy m a) exp_ty
+ else
+ returnTc ()
+ ) `thenTc_`
+ returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty)
+
+tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts)
+ = tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
+ unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
+ returnTc (ExprStmt exp' src_loc, exp_lie)
+ )) `thenTc` \ (stmt', stmt_lie) ->
+ tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
+ returnTc ((stmt':stmts', True, mzero),
+ stmt_lie `plusLIE` stmts_lie,
+ stmts_ty)
+
+tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
+ = tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ newTyVarTy mkTypeKind `thenNF_Tc` \ a ->
+ unifyTauTy a pat_ty `thenTc_`
+ unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
+ returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat')
+ )) `thenTc` \ (stmt', stmt_lie, failure_free) ->
+ tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
+ returnTc ((stmt':stmts', True, mzero || not failure_free),
+ stmt_lie `plusLIE` stmts_lie,
+ stmts_ty)
+
+tcDoStmts monad m (LetStmt binds : stmts)
+ = tcBindsAndThen -- No error context, but a binding group is
+ combine -- rather a large thing for an error context anyway
+ binds
+ (tcDoStmts monad m stmts)
+ where
+ combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero)
+
+\end{code}
+
+Game plan for record bindings
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For each binding
+ field = value
+1. look up "field", to find its selector Id, which must have type
+ forall a1..an. T a1 .. an -> tau
+ where tau is the type of the field.