go (BindStmt pat rhs bind_op fail_op : stmts)
=
- do { body <- go stmts
+ do { body <- go stmts
+ ; rhs' <- dsLExpr rhs
+ ; bind_op' <- dsExpr bind_op
; var <- selectSimpleMatchVarL pat
+ ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
+ res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
- result_ty (cantFailMatchResult body)
+ res1_ty (cantFailMatchResult body)
; match_code <- handle_failure pat match fail_op
- ; rhs' <- dsLExpr rhs
- ; bind_op' <- dsExpr bind_op
; return (mkApps bind_op' [rhs', Lam var match_code]) }
-- In a do expression, pattern-match failure just calls
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 stmt res_ty thing_inside