+\begin{code}
+tcStmts ctxt stmts
+ = ASSERT( notNull stmts )
+ tcStmtsAndThen (:) ctxt stmts (returnM [])
+
+data TcStmtCtxt
+ = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is
+ sc_rhs :: LHsExpr Name -> TcType -> TcM (LHsExpr TcId), -- Type checker for RHS computations
+ sc_body :: LHsExpr Name -> TcM (LHsExpr TcId), -- Type checker for return computation
+ sc_ty :: TcType } -- Return type; used *only* to check
+ -- for escape in existential patterns
+tcStmtsAndThen
+ :: (LStmt TcId -> thing -> thing) -- Combiner
+ -> TcStmtCtxt
+ -> [LStmt Name]
+ -> TcM thing
+ -> TcM thing
+
+ -- Base case
+tcStmtsAndThen combine ctxt [] thing_inside
+ = thing_inside
+
+tcStmtsAndThen combine ctxt (stmt:stmts) thing_inside
+ = tcStmtAndThen combine ctxt stmt $
+ tcStmtsAndThen combine ctxt stmts $
+ thing_inside
+
+ -- LetStmt
+tcStmtAndThen combine ctxt (L _ (LetStmt binds)) thing_inside
+ = tcBindsAndThen -- No error context, but a binding group is
+ (glue_binds combine) -- rather a large thing for an error context anyway
+ binds
+ thing_inside
+
+ -- BindStmt
+tcStmtAndThen combine ctxt (L src_loc stmt@(BindStmt pat exp)) thing_inside
+ = addSrcSpan src_loc $
+ addErrCtxt (stmtCtxt ctxt stmt) $
+ newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
+ sc_rhs ctxt exp pat_ty `thenM` \ exp' ->
+ tcMatchPats [(pat, Check pat_ty)] (Check (sc_ty ctxt)) (
+ popErrCtxt thing_inside
+ ) `thenM` \ ([pat'], thing, dict_binds) ->
+ returnM (combine (L src_loc (BindStmt pat' exp'))
+ (glue_binds combine dict_binds thing))
+
+ -- ExprStmt
+tcStmtAndThen combine ctxt (L src_loc stmt@(ExprStmt exp _)) thing_inside
+ = addSrcSpan src_loc (
+ addErrCtxt (stmtCtxt ctxt stmt) $
+ if isDoExpr (sc_what ctxt)
+ then -- do or mdo; the expression is a computation
+ newTyVarTy liftedTypeKind `thenM` \ any_ty ->
+ sc_rhs ctxt exp any_ty `thenM` \ exp' ->
+ returnM (L src_loc (ExprStmt exp' any_ty))
+ else -- List comprehensions, pattern guards; expression is a boolean
+ tcCheckRho exp boolTy `thenM` \ exp' ->
+ returnM (L src_loc (ExprStmt exp' boolTy))
+ ) `thenM` \ stmt' ->
+
+ thing_inside `thenM` \ thing ->
+ returnM (combine stmt' thing)
+
+
+ -- ParStmt
+tcStmtAndThen combine ctxt (L src_loc (ParStmt bndr_stmts_s)) thing_inside
+ = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
+ returnM (combine (L src_loc (ParStmt pairs')) thing)
+ where
+ loop [] = thing_inside `thenM` \ thing ->
+ returnM ([], thing)
+
+ loop ((stmts, bndrs) : pairs)
+ = tcStmtsAndThen combine_par ctxt stmts $
+ -- Notice we pass on ctxt; the result type is used only
+ -- to get escaping type variables for checkExistentialPat
+ tcLookupLocalIds bndrs `thenM` \ bndrs' ->
+ loop pairs `thenM` \ (pairs', thing) ->
+ returnM (([], bndrs') : pairs', thing)
+
+ combine_par stmt ((stmts, bndrs) : pairs , thing) = ((stmt:stmts, bndrs) : pairs, thing)
+
+ -- RecStmt
+tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thing_inside
+ = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
+ let
+ rec_ids = zipWith mkLocalId recNames recTys
+ in
+ tcExtendLocalValEnv rec_ids $
+ tcStmtsAndThen combine_rec ctxt stmts (
+ mappM tc_ret (recNames `zip` recTys) `thenM` \ rec_rets ->
+ tcLookupLocalIds laterNames `thenM` \ later_ids ->
+ returnM ([], (later_ids, rec_rets))
+ ) `thenM` \ (stmts', (later_ids, rec_rets)) ->
+
+ tcExtendLocalValEnv later_ids $
+ -- NB: The rec_ids for the recursive things
+ -- already scope over this part
+ thing_inside `thenM` \ thing ->
+
+ returnM (combine (L src_loc (RecStmt stmts' later_ids rec_ids rec_rets)) thing)
+ where
+ combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
+
+ -- Unify the types of the "final" Ids with those of "knot-tied" Ids
+ tc_ret (rec_name, mono_ty)
+ = tcLookupId rec_name `thenM` \ poly_id ->
+ -- poly_id may have a polymorphic type
+ -- but mono_ty is just a monomorphic type variable
+ tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
+ returnM (L src_loc (co_fn <$> HsVar poly_id))
+
+ -- Result statements
+tcStmtAndThen combine ctxt (L src_loc stmt@(ResultStmt exp)) thing_inside
+ = addErrCtxt (stmtCtxt ctxt stmt) (sc_body ctxt exp) `thenM` \ exp' ->
+ thing_inside `thenM` \ thing ->
+ returnM (combine (L src_loc (ResultStmt exp')) thing)
+
+
+------------------------------
+glue_binds combine binds thing = combine (noLoc (LetStmt [binds])) thing
+ -- ToDo: fix the noLoc