+
+%************************************************************************
+%* *
+\subsection{tcStmts}
+%* *
+%************************************************************************
+
+
+\begin{code}
+tcStmts :: StmtCtxt
+ -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs
+ -> [RenamedStmt]
+ -> TcType -- elt_ty, where type of the comprehension is (m elt_ty)
+ -> TcM s ([TcStmt], LIE)
+
+tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
+ = ASSERT( null stmts )
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) ->
+ returnTc ([ReturnStmt exp'], exp_lie)
+
+ -- ExprStmt at the end
+tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
+ = tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ tcExpr exp (m elt_ty) `thenTc` \ (exp', exp_lie) ->
+ returnTc ([ExprStmt exp' src_loc], exp_lie)
+
+ -- ExprStmt not at the end
+tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
+ = ASSERT( isDoStmt do_or_lc )
+ tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ -- exp has type (m tau) for some tau (doesn't matter what)
+ newTyVarTy_OpenKind `thenNF_Tc` \ any_ty ->
+ tcExpr exp (m any_ty)
+ ) `thenTc` \ (exp', exp_lie) ->
+ tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
+ returnTc (ExprStmt exp' src_loc : stmts',
+ exp_lie `plusLIE` stmts_lie)
+
+tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
+ = ASSERT( not (isDoStmt do_or_lc) )
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ tcAddSrcLoc src_loc $
+ tcExpr exp boolTy
+ ) `thenTc` \ (exp', exp_lie) ->
+ tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
+ returnTc (GuardStmt exp' src_loc : stmts',
+ exp_lie `plusLIE` stmts_lie)
+
+tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
+ = tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
+ tcPat tcPatBndr_NoSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
+ tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
+ returnTc (pat', exp',
+ pat_lie `plusLIE` exp_lie,
+ pat_tvs, pat_ids, avail)
+ ) `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
+ let
+ new_val_env = bagToList pat_bndrs
+ pat_ids = map snd new_val_env
+ pat_tv_list = bagToList pat_tvs
+ in
+
+ -- Do the rest; we don't need to add the pat_tvs to the envt
+ -- because they all appear in the pat_ids's types
+ tcExtendLocalValEnv new_val_env (
+ tcStmts do_or_lc m stmts elt_ty
+ ) `thenTc` \ (stmts', stmts_lie) ->
+
+
+ -- Reinstate context for existential checks
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
+ tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $
+ tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids) $
+
+ checkSigTyVars pat_tv_list emptyVarSet `thenTc` \ zonked_pat_tvs ->
+
+ tcSimplifyAndCheck
+ (text ("the existential context of a data constructor"))
+ (mkVarSet zonked_pat_tvs)
+ lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
+
+ returnTc (BindStmt pat' exp' src_loc :
+ consLetStmt (mkMonoBind dict_binds [] Recursive) stmts',
+ lie_req `plusLIE` final_lie)
+
+tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
+ = tcBindsAndThen -- No error context, but a binding group is
+ combine -- rather a large thing for an error context anyway
+ binds
+ (tcStmts do_or_lc m stmts elt_ty)
+ where
+ combine is_rec binds' stmts' = consLetStmt (mkMonoBind binds' [] is_rec) stmts'
+
+
+isDoStmt DoStmt = True
+isDoStmt other = False