-tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
- = tcBindsAndThen glue_on binds (tc_grhss grhss)
- where
- m_ty = (\ty -> ty, expected_ty)
-
- tc_grhss grhss
- = mappM tc_grhs grhss `thenM` \ grhss' ->
- returnM (GRHSs grhss' EmptyBinds expected_ty)
-
- tc_grhs (GRHS guarded locn)
- = addSrcLoc locn $
- tcStmts (PatGuard ctxt) m_ty guarded `thenM` \ guarded' ->
+ -- Special case when there is just one equation with a degenerate
+ -- guard; then we pass in the full Expected type, so that we get
+ -- good inference from simple things like
+ -- f = \(x::forall a.a->a) -> <stuff>
+ -- This is a consequence of the fact that tcStmts takes a TcType,
+ -- not a Expected TcType, a decision we could revisit if necessary
+tcGRHSs ctxt (GRHSs [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty
+ = tcBindsAndThen glueBindsOnGRHSs binds $
+ mc_body ctxt rhs exp_ty `thenM` \ rhs' ->
+ readExpectedType exp_ty `thenM` \ exp_ty' ->
+ returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty')
+
+tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
+ = tcBindsAndThen glueBindsOnGRHSs binds $
+ zapExpectedType exp_ty `thenM` \ exp_ty' ->
+ -- Even if there is only one guard, we zap the RHS type to
+ -- a monotype. Reason: it makes tcStmts much easier,
+ -- and even a one-armed guard has a notional second arm
+ let
+ stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt),
+ sc_rhs = tcCheckRho,
+ sc_body = sc_body,
+ sc_ty = exp_ty' }
+ sc_body body = mc_body ctxt body (Check exp_ty')
+
+ tc_grhs (GRHS guarded locn)
+ = addSrcLoc locn $
+ tcStmts stmt_ctxt guarded `thenM` \ guarded' ->