import Util
import SrcLoc
-import Control.Monad( liftM )
+import Control.Monad
\end{code}
%************************************************************************
tcGRHSs ctxt (GRHSs grhss binds) res_ty
= do { (binds', grhss') <- tcLocalBinds binds $
- mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
+ mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
- ; returnM (GRHSs grhss' binds') }
+ ; return (GRHSs grhss' binds') }
-------------
tcGRHS :: TcMatchCtxt -> (Refinement, BoxyRhoType) -> GRHS Name -> TcM (GRHS TcId)
tcDoStmt :: TcStmtChecker
-tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside
+tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) (reft,res_ty) thing_inside
= do { (rhs', rhs_ty) <- tcInferRho rhs
-- We should use type *inference* for the RHS computations, becuase of GADTs.
-- do { pat <- rhs; <rest> }
-- We do inference on rhs, so that information about its type can be refined
-- when type-checking the pattern.
- -- Deal with rebindable syntax; (>>=) :: rhs_ty -> (a -> res_ty) -> res_ty
- ; (bind_op', pat_ty) <-
+ -- Deal with rebindable syntax:
+ -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
+ -- This level of generality is needed for using do-notation
+ -- in full generality; see Trac #1537
+ ; ((bind_op', new_res_ty), pat_ty) <-
withBox liftedTypeKind $ \ pat_ty ->
+ withBox liftedTypeKind $ \ new_res_ty ->
tcSyntaxOp DoOrigin bind_op
- (mkFunTys [rhs_ty, mkFunTy pat_ty res_ty] res_ty)
+ (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
-- If (but only if) the pattern can fail,
-- typecheck the 'fail' operator
; fail_op' <- if isIrrefutableHsPat pat
then return noSyntaxExpr
- else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
+ else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
- ; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside
+ ; (pat', thing) <- tcLamPat pat pat_ty (reft, new_res_ty) thing_inside
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
-tcDoStmt ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside
+tcDoStmt ctxt (ExprStmt rhs then_op _) (reft,res_ty) thing_inside
= do { (rhs', rhs_ty) <- tcInferRho rhs
- -- Deal with rebindable syntax; (>>) :: rhs_ty -> res_ty -> res_ty
- ; then_op' <- tcSyntaxOp DoOrigin then_op
- (mkFunTys [rhs_ty, res_ty] res_ty)
+ -- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
+ ; (then_op', new_res_ty) <-
+ withBox liftedTypeKind $ \ new_res_ty ->
+ tcSyntaxOp DoOrigin then_op
+ (mkFunTys [rhs_ty, new_res_ty] res_ty)
- ; thing <- thing_inside reft_res_ty
+ ; thing <- thing_inside (reft, new_res_ty)
; return (ExprStmt rhs' then_op' rhs_ty, thing) }
+tcDoStmt ctxt (RecStmt {}) res_ty thing_inside
+ = failWithTc (ptext SLIT("Illegal 'rec' stmt in") <+> pprStmtContext ctxt)
+ -- This case can't be caught in the renamer
+ -- see RnExpr.checkRecStmt
+
tcDoStmt ctxt stmt res_ty thing_inside
= pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)