+tcStmts do_or_lc m_ty stmts
+ = ASSERT( notNull stmts )
+ tcStmtsAndThen (:) do_or_lc m_ty stmts (returnM [])
+
+tcStmtsAndThen
+ :: (TcStmt -> thing -> thing) -- Combiner
+ -> HsStmtContext Name
+ -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
+ -- elt_ty, where type of the comprehension is (m elt_ty)
+ -> [RenamedStmt]
+ -> TcM thing
+ -> TcM thing
+
+ -- Base case
+tcStmtsAndThen combine do_or_lc m_ty [] do_next
+ = do_next
+
+tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
+ = tcStmtAndThen combine do_or_lc m_ty stmt
+ (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
+
+ -- LetStmt
+tcStmtAndThen combine do_or_lc m_ty (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
+
+tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
+ = addSrcLoc src_loc $
+ addErrCtxt (stmtCtxt do_or_lc stmt) $
+ newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
+ tcMonoExpr exp (m pat_ty) `thenM` \ exp' ->
+ tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ _ ->
+ popErrCtxt thing_inside
+ ) `thenM` \ ([pat'], thing, dict_binds) ->
+ returnM (combine (BindStmt pat' exp' src_loc)
+ (glue_binds combine dict_binds thing))
+
+ -- ParStmt
+tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
+ = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
+ returnM (combine (ParStmtOut pairs') thing)
+ where
+ loop []
+ = thing_inside `thenM` \ thing ->
+ returnM ([], thing)
+
+ loop ((bndrs,stmts) : pairs)
+ = tcStmtsAndThen
+ combine_par ListComp m_ty stmts
+ -- Notice we pass on m_ty; 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))) `thenM` \ (stmts', (bndrs', pairs', thing)) ->
+
+ returnM ((bndrs',stmts') : pairs', thing)
+
+ combine_par stmt (stmts, thing) = (stmt:stmts, thing)
+
+ -- RecStmt
+tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts _) thing_inside
+ = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
+ let
+ mono_ids = zipWith mkLocalId recNames recTys
+ in
+ tcExtendLocalValEnv mono_ids $
+ tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
+ mappM tc_ret (recNames `zip` recTys) `thenM` \ rets ->
+ returnM ([], rets)
+ ) `thenM` \ (stmts', rets) ->
+
+ -- NB: it's the mono_ids that scope over this part
+ thing_inside `thenM` \ thing ->
+
+ returnM (combine (RecStmt mono_ids stmts' 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 mono_ty (idType poly_id) `thenM` \ co_fn ->
+ returnM (co_fn <$> HsVar poly_id)
+
+ -- ExprStmt
+tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
+ = addErrCtxt (stmtCtxt do_or_lc stmt) (
+ if isDoExpr do_or_lc then
+ newTyVarTy openTypeKind `thenM` \ any_ty ->
+ tcMonoExpr exp (m any_ty) `thenM` \ exp' ->
+ returnM (ExprStmt exp' any_ty locn)
+ else
+ tcMonoExpr exp boolTy `thenM` \ exp' ->
+ returnM (ExprStmt exp' boolTy locn)
+ ) `thenM` \ stmt' ->
+
+ thing_inside `thenM` \ thing ->
+ returnM (combine stmt' thing)
+
+
+ -- Result statements
+tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
+ = addErrCtxt (resCtxt do_or_lc stmt) (
+ if isDoExpr do_or_lc then
+ tcMonoExpr exp (m res_elt_ty)
+ else
+ tcMonoExpr exp res_elt_ty
+ ) `thenM` \ exp' ->
+
+ thing_inside `thenM` \ thing ->
+
+ returnM (combine (ResultStmt exp' locn) thing)
+
+
+------------------------------
+glue_binds combine EmptyBinds thing = thing
+glue_binds combine other_binds thing = combine (LetStmt other_binds) thing