-tc_match_pats (pat:pats) expected_ty
- = subFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
- -- This is the unique place we call subFunTy
- -- The point is that if expected_y is a "hole", we want
- -- to make arg_ty and rest_ty as "holes" too.
- tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
- tc_match_pats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
- returnTc ( rhs_ty,
- pat':pats',
- lie_req `plusLIE` lie_reqs,
- pat_tvs `unionBags` pats_tvs,
- pat_ids `unionBags` pats_ids,
- lie_avail `plusLIE` lie_avails
- )
+%************************************************************************
+%* *
+\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
+%* *
+%************************************************************************
+
+\begin{code}
+tcDoStmts :: HsStmtContext Name -> [RenamedStmt] -> [Name] -> TcType
+ -> TcM (TcMonoBinds, [TcStmt], [Id])
+tcDoStmts PArrComp stmts method_names res_ty
+ = unifyPArrTy res_ty `thenM` \elt_ty ->
+ tcStmts PArrComp (mkPArrTy, elt_ty) stmts `thenM` \ stmts' ->
+ returnM (EmptyMonoBinds, stmts', [{- unused -}])
+
+tcDoStmts ListComp stmts method_names res_ty
+ = unifyListTy res_ty `thenM` \ elt_ty ->
+ tcStmts ListComp (mkListTy, elt_ty) stmts `thenM` \ stmts' ->
+ returnM (EmptyMonoBinds, stmts', [{- unused -}])
+
+tcDoStmts do_or_mdo_expr stmts method_names res_ty
+ = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty ->
+ newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
+ unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_`
+
+ tcStmts do_or_mdo_expr (mkAppTy m_ty, elt_ty) stmts `thenM` \ stmts' ->
+
+ -- 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.
+ --
+ mapAndUnzipM (tc_syn_name m_ty)
+ (zipEqual "tcDoStmts" currentMonadNames method_names) `thenM` \ (binds, ids) ->
+ returnM (andMonoBindList binds, stmts', ids)
+ where
+ currentMonadNames = case do_or_mdo_expr of
+ DoExpr -> monadNames
+ MDoExpr -> monadNames ++ [mfixName]
+ tc_syn_name :: TcType -> (Name,Name) -> TcM (TcMonoBinds, Id)
+ tc_syn_name m_ty (std_nm, usr_nm)
+ = tcSyntaxName DoOrigin m_ty std_nm usr_nm `thenM` \ (expr, expr_ty) ->
+ case expr of
+ HsVar v -> returnM (EmptyMonoBinds, v)
+ other -> newUnique `thenM` \ uniq ->
+ let
+ id = mkSysLocal FSLIT("syn") uniq expr_ty
+ in
+ returnM (VarMonoBind id expr, id)