+tcStmts do_or_lc m_ty stmts
+ = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
+
+tcStmtsAndThen
+ :: (TcStmt -> thing -> thing) -- Combiner
+ -> RenamedMatchContext
+ -> (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, LIE)
+ -> TcM (thing, LIE)
+
+ -- 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
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
+ newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
+ tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
+ tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ [pat'] _ ->
+ tcPopErrCtxt $
+ thing_inside `thenTc` \ (thing, lie) ->
+ returnTc ((BindStmt pat' exp' src_loc, thing), lie)
+ ) `thenTc` \ ((stmt', thing), lie, dict_binds) ->
+ returnTc (combine stmt' (glue_binds combine Recursive dict_binds thing),
+ lie `plusLIE` exp_lie)
+
+
+ -- ParStmt
+tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
+ = loop bndr_stmts_s `thenTc` \ ((pairs', thing), lie) ->
+ returnTc (combine (ParStmtOut pairs') thing, lie)
+ where
+ loop []
+ = thing_inside `thenTc` \ (thing, stmts_lie) ->
+ returnTc (([], thing), stmts_lie)
+
+ loop ((bndrs,stmts) : pairs)
+ = tcStmtsAndThen
+ combine_par (DoCtxt 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 `thenNF_Tc` \ bndrs' ->
+ loop pairs `thenTc` \ ((pairs', thing), lie) ->
+ returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
+
+ returnTc ( ((bndrs',stmts') : pairs', thing), lie)
+
+ combine_par stmt (stmts, thing) = (stmt:stmts, thing)
+
+ -- ExprStmt
+tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp locn) thing_inside
+ = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ if isDoExpr do_or_lc then
+ newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
+ tcExpr exp (m any_ty)
+ else
+ tcExpr exp boolTy
+ ) `thenTc` \ (exp', stmt_lie) ->
+
+ thing_inside `thenTc` \ (thing, stmts_lie) ->
+
+ returnTc (combine (ExprStmt exp' locn) thing,
+ stmt_lie `plusLIE` stmts_lie)
+
+
+ -- Result statements
+tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
+ = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ if isDoExpr do_or_lc then
+ tcExpr exp (m res_elt_ty)
+ else
+ tcExpr exp res_elt_ty
+ ) `thenTc` \ (exp', stmt_lie) ->
+
+ thing_inside `thenTc` \ (thing, stmts_lie) ->
+
+ returnTc (combine (ResultStmt exp' locn) thing,
+ stmt_lie `plusLIE` stmts_lie)
+
+
+------------------------------
+glue_binds combine is_rec binds thing
+ | nullMonoBinds binds = thing
+ | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing