- go (ExprStmt rhs _ rhs_ty : stmts)
- = do { rhs2 <- dsLExpr rhs
- ; rest <- go stmts
- ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
-
- go (BindStmt pat rhs _ _ : stmts)
- = do { body <- go stmts
- ; var <- selectSimpleMatchVarL pat
- ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
- result_ty (cantFailMatchResult body)
- ; fail_msg <- mkStringExpr (mk_fail_msg pat)
- ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
- ; match_code <- extractMatchResult match fail_expr
-
- ; rhs' <- dsLExpr rhs
- ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
- rhs', Lam var match_code]) }
-
- go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
- = ASSERT( length rec_ids > 0 )
- ASSERT( length rec_ids == length rec_rets )
- go (new_bind_stmt : let_stmt : stmts)
- where
- new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
- let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-
-
- -- Remove the later_ids that appear (without fancy coercions)
- -- in rec_rets, because there's no need to knot-tie them separately
- -- See Note [RecStmt] in HsExpr
- later_ids' = filter (`notElem` mono_rec_ids) later_ids
- mono_rec_ids = [ id | HsVar id <- rec_rets ]
-
- mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
- mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
- (mkFunTy tup_ty body_ty))
-
- -- The rec_tup_pat must bind the rec_ids only; remember that the
- -- trimmed_laters may share the same Names
- -- Meanwhile, the later_pats must bind the later_vars
- rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
- later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
- rets = map nlHsVar later_ids' ++ map noLoc rec_rets
-
- mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
- body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
- body_ty = mkAppTy m_ty tup_ty
- tup_ty = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
- -- mkCoreTupTy deals with singleton case
-
- return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
- (mk_ret_tup rets)
-
- mk_wild_pat :: Id -> LPat Id
- mk_wild_pat v = noLoc $ WildPat $ idType v
-
- mk_later_pat :: Id -> LPat Id
- mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
- | otherwise = nlVarPat v
-
- mk_tup_pat :: [LPat Id] -> LPat Id
- mk_tup_pat [p] = p
- mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
-
- mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
- mk_ret_tup [r] = r
- mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed
+%************************************************************************
+%* *
+\subsection{Errors and contexts}
+%* *
+%************************************************************************
+
+\begin{code}
+-- Warn about certain types of values discarded in monadic bindings (#3263)
+warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
+warnDiscardedDoBindings rhs rhs_ty
+ | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
+ = do { -- Warn about discarding non-() things in 'monadic' binding
+ ; warn_unused <- doptDs Opt_WarnUnusedDoBind
+ ; if warn_unused && not (isUnitTy elt_ty)
+ then warnDs (unusedMonadBind rhs elt_ty)
+ else
+ -- Warn about discarding m a things in 'monadic' binding of the same type,
+ -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
+ do { warn_wrong <- doptDs Opt_WarnWrongDoBind
+ ; case tcSplitAppTy_maybe elt_ty of
+ Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
+ -> warnDs (wrongMonadBind rhs elt_ty)
+ _ -> return () } }
+
+ | otherwise -- RHS does have type of form (m ty), which is wierd
+ = return () -- but at lesat this warning is irrelevant
+
+unusedMonadBind :: LHsExpr Id -> Type -> SDoc
+unusedMonadBind rhs elt_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
+ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
+ ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
+
+wrongMonadBind :: LHsExpr Id -> Type -> SDoc
+wrongMonadBind rhs elt_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
+ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
+ ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")