-%************************************************************************
-%* *
-\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
-%* *
-%************************************************************************
-
-\begin{code}
-tcDoStmts PArrComp stmts method_names src_loc res_ty
- = unifyPArrTy res_ty `thenTc` \elt_ty ->
- tcStmts (DoCtxt PArrComp)
- (mkPArrTy, elt_ty) stmts `thenTc` \(stmts', stmts_lie) ->
- returnTc (HsDo PArrComp stmts'
- [] -- Unused
- res_ty src_loc,
- stmts_lie)
-
-tcDoStmts ListComp stmts method_names src_loc res_ty
- = unifyListTy res_ty `thenTc` \ elt_ty ->
- tcStmts (DoCtxt ListComp)
- (mkListTy, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) ->
- returnTc (HsDo ListComp stmts'
- [] -- Unused
- res_ty src_loc,
- stmts_lie)
-
-tcDoStmts DoExpr stmts method_names src_loc res_ty
- = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty ->
- newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty ->
- unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_`
-
- tcStmts (DoCtxt DoExpr) (mkAppTy m_ty, elt_ty) stmts `thenTc` \ (stmts', stmts_lie) ->
-
- -- Build the then and zero methods in case we need them
- -- It's important that "then" and "return" appear just once in the final LIE,
- -- not only for typechecker efficiency, but also because otherwise during
- -- simplification we end up with silly stuff like
- -- then = case d of (t,r) -> t
- -- then = then
- -- where the second "then" sees that it already exists in the "available" stuff.
- --
- mapNF_Tc (tc_syn_name m_ty)
- (zipEqual "tcDoStmts" monadNames method_names) `thenNF_Tc` \ stuff ->
- let
- (binds, ids, lies) = unzip3 stuff
- in
-
- returnTc (mkHsLet (andMonoBindList binds) $
- HsDo DoExpr stmts' ids
- res_ty src_loc,
- stmts_lie `plusLIE` plusLIEs lies)
-
- where
- tc_syn_name :: TcType -> (Name,Name) -> TcM (TypecheckedMonoBinds, Id, LIE)
- tc_syn_name m_ty (std_nm, usr_nm)
- = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenTc` \ (expr, lie, expr_ty) ->
- case expr of
- HsVar v -> returnTc (EmptyMonoBinds, v, lie)
- other -> tcGetUnique `thenTc` \ uniq ->
- let
- id = mkSysLocal FSLIT("syn") uniq expr_ty
- in
- returnTc (VarMonoBind id expr, id, lie)