-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)
+tcDoStmts stmts src_loc
+ = -- get the Monad and MonadZero classes
+ -- create type consisting of a fresh monad tyvar
+ tcAddSrcLoc src_loc $
+ newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m ->
+
+
+ -- Build the then and zero methods in case we need them
+ tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id ->
+ tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id ->
+ newMethod DoOrigin
+ (RealId then_sel_id) [m] `thenNF_Tc` \ (m_lie, then_id) ->
+ newMethod DoOrigin
+ (RealId zero_sel_id) [m] `thenNF_Tc` \ (mz_lie, zero_id) ->
+
+ let
+ get_m_arg ty
+ = newTyVarTy mkTypeKind `thenNF_Tc` \ arg_ty ->
+ unifyTauTy (mkAppTy m arg_ty) ty `thenTc_`
+ returnTc arg_ty
+
+ go [stmt@(ExprStmt exp src_loc)]
+ = tcAddSrcLoc src_loc $
+ tcSetErrCtxt (stmtCtxt stmt) $
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty)
+
+ go (stmt@(ExprStmt exp src_loc) : stmts)
+ = tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ get_m_arg exp_ty `thenTc` \ a ->
+ returnTc (a, exp', exp_lie)
+ )) `thenTc` \ (a, exp', exp_lie) ->
+ go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
+ get_m_arg stmts_ty `thenTc` \ b ->
+ returnTc (ExprStmtOut exp' src_loc a b : stmts',
+ exp_lie `plusLIE` stmts_lie `plusLIE` m_lie,
+ stmts_ty)
+
+ go (stmt@(BindStmt pat exp src_loc) : stmts)
+ = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
+ tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt stmt) (
+ tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
+ tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) ->
+ -- See comments with tcListComp on GeneratorQual
+
+ get_m_arg exp_ty `thenTc` \ a ->
+ unifyTauTy a pat_ty `thenTc_`
+ returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie)
+ )) `thenTc` \ (a, pat', exp', stmt_lie) ->
+ go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) ->
+ get_m_arg stmts_ty `thenTc` \ b ->
+ returnTc (BindStmtOut pat' exp' src_loc a b : stmts',
+ stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE`
+ (if failureFreePat pat' then emptyLIE else mz_lie),
+ stmts_ty)
+
+ go (LetStmt binds : stmts)
+ = tcBindsAndThen -- No error context, but a binding group is
+ combine -- rather a large thing for an error context anyway
+ binds
+ (go stmts)
+ where
+ combine binds' stmts' = LetStmt binds' : stmts'
+ in