-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
+ -> [LStmt Name] -> ReboundNames Name
+ -> TcRhoType -- To keep it simple, we don't have an "expected" type here
+ -> TcM ([LStmt TcId], ReboundNames TcId)
+tcDoStmts PArrComp stmts method_names res_ty
+ = unifyPArrTy res_ty `thenM` \elt_ty ->
+ tcComprehension PArrComp mkPArrTy elt_ty stmts `thenM` \ stmts' ->
+ returnM (stmts', [{- unused -}])
+
+tcDoStmts ListComp stmts method_names res_ty
+ = unifyListTy res_ty ` thenM` \ elt_ty ->
+ tcComprehension ListComp mkListTy elt_ty stmts `thenM` \ stmts' ->
+ returnM (stmts', [{- unused -}])
+
+tcDoStmts do_or_mdo 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_`
+ let
+ ctxt = SC { sc_what = do_or_mdo,
+ sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mkAppTy m_ty rhs_elt_ty),
+ sc_body = \ body -> tcCheckRho body res_ty,
+ sc_ty = res_ty }
+ in
+ tcStmts ctxt 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.
+ mapM (tcSyntaxName DoOrigin m_ty) method_names `thenM` \ methods ->
+
+ returnM (stmts', methods)
+
+tcComprehension do_or_lc mk_mty elt_ty stmts
+ = tcStmts ctxt stmts
+ where
+ ctxt = SC { sc_what = do_or_lc,
+ sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mk_mty rhs_elt_ty),
+ sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no mk_mty!
+ sc_ty = mk_mty elt_ty }