Move warnDiscardedDoBindings into TcWarnings

3 files changed, 55 insertions, 51 deletions

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index a2bcef31b3..20d402b7af 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -28,7 +28,6 @@ import DsMonad
 import Check ( checkGuardMatches )
 import Name
 import NameEnv
-import FamInstEnv( topNormaliseType )
 import DsMeta
 import HsSyn
 
@@ -881,7 +880,6 @@ dsDo stmts
 
     go _ (BodyStmt _ rhs then_expr _) stmts
       = do { rhs2 <- dsLExpr rhs
-           ; warnDiscardedDoBindings rhs (exprType rhs2)
            ; rest <- goL stmts
            ; dsSyntaxExpr then_expr [rhs2, rest] }
 
@@ -1018,51 +1016,6 @@ dsConLike _ (PatSynCon ps)   = return $ case patSynBuilder ps of
 {-
 ************************************************************************
 *                                                                      *
-\subsection{Errors and contexts}
-*                                                                      *
-************************************************************************
--}
-
--- Warn about certain types of values discarded in monadic bindings (#3263)
-warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
-warnDiscardedDoBindings rhs rhs_ty
-  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
-  = do { warn_unused <- woptM Opt_WarnUnusedDoBind
-       ; warn_wrong <- woptM Opt_WarnWrongDoBind
-       ; when (warn_unused || warn_wrong) $
-    do { fam_inst_envs <- dsGetFamInstEnvs
-       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
-
-           -- Warn about discarding non-() things in 'monadic' binding
-       ; if warn_unused && not (isUnitTy norm_elt_ty)
-         then warnDs (Reason Opt_WarnUnusedDoBind)
-                     (badMonadBind 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
-           when warn_wrong $
-                do { case tcSplitAppTy_maybe norm_elt_ty of
-                         Just (elt_m_ty, _)
-                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
-                            -> warnDs (Reason Opt_WarnWrongDoBind)
-                                      (badMonadBind rhs elt_ty)
-                         _ -> return () } } }
-
-  | otherwise   -- RHS does have type of form (m ty), which is weird
-  = return ()   -- but at lesat this warning is irrelevant
-
-badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
-badMonadBind rhs elt_ty
-  = vcat [ hang (text "A do-notation statement discarded a result of type")
-              2 (quotes (ppr elt_ty))
-         , hang (text "Suppress this warning by saying")
-              2 (quotes $ text "_ <-" <+> ppr rhs)
-         ]
-
-{-
-************************************************************************
-*                                                                      *
    Forced eta expansion and levity polymorphism
 *                                                                      *
 ************************************************************************
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 558916b5cc..ded91a6b78 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -1150,7 +1150,8 @@ zonkArithSeq env (FromThenTo e1 e2 e3)
 
 
 -------------------------------------------------------------------------
-zonkStmts :: ZonkEnv
+zonkStmts :: Outputable (body GhcTc)
+          => ZonkEnv
           -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
           -> [LStmt GhcTcId (Located (body GhcTcId))]
           -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))])
@@ -1159,7 +1160,8 @@ zonkStmts env zBody (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env zBody
                                 ; (env2, ss') <- zonkStmts env1 zBody ss
                                 ; return (env2, s' : ss') }
 
-zonkStmt :: ZonkEnv
+zonkStmt :: Outputable (body GhcTc) -- for warnings
+         => ZonkEnv
          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
          -> Stmt GhcTcId (Located (body GhcTcId))
          -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc)))
@@ -1217,6 +1219,7 @@ zonkStmt env zBody (BodyStmt ty body then_op guard_op)
        (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
        new_body <- zBody env2 body
        new_ty   <- zonkTcTypeToTypeX env2 ty
+       warnDiscardedDoBindings new_body new_ty
        return (env2, BodyStmt new_ty new_body new_then_op new_guard_op)
 
 zonkStmt env zBody (LastStmt x body noret ret_op)
diff --git a/compiler/typecheck/TcWarnings.hs b/compiler/typecheck/TcWarnings.hs
index cfe1fda83d..f0d1a21acc 100644
--- a/compiler/typecheck/TcWarnings.hs
+++ b/compiler/typecheck/TcWarnings.hs
@@ -3,10 +3,13 @@
 
 -- | Warnings generated after or while type-checking.
 module TcWarnings (
-    -- * Warnings about overflowed literals
+    -- * Warnings involving literals
     warnAboutIdentities,
     warnAboutOverflowedOverLit, warnAboutOverflowedLit,
-    warnAboutEmptyEnumerations
+    warnAboutEmptyEnumerations,
+
+    -- * Discarded do bindings
+    warnDiscardedDoBindings
   ) where
 
 import GhcPrelude
@@ -18,6 +21,9 @@ import Id
 import TyCon
 import Name
 import Type
+import TcType
+import FamInst (tcGetFamInstEnvs)
+import FamInstEnv (topNormaliseType)
 import Coercion
 import TcEvidence
 import PrelNames
@@ -226,3 +232,45 @@ getSimpleIntegralLit (HsInteger _ i ty)
   | Just tc <- tyConAppTyCon_maybe ty
   = Just (i, tyConName tc)
 getSimpleIntegralLit _ = Nothing
+
+-- | Warn about certain types of values discarded in monadic bindings (#3263).
+--
+-- Called on the RHS of a 'BodyStmt'.
+-- @rhs@ is instantiated to @'LHsExpr' 'GhcTc'@ or @'LHsCmd' 'GhcTc'@.
+warnDiscardedDoBindings :: Outputable rhs => rhs -> Type -> TcM ()
+warnDiscardedDoBindings rhs rhs_ty
+  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
+  = do { warn_unused <- woptM Opt_WarnUnusedDoBind
+       ; warn_wrong <- woptM Opt_WarnWrongDoBind
+       ; when (warn_unused || warn_wrong) $
+    do { fam_inst_envs <- tcGetFamInstEnvs
+       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
+
+           -- Warn about discarding non-() things in 'monadic' binding
+       ; if warn_unused && not (isUnitTy norm_elt_ty)
+         then warnTc (Reason Opt_WarnUnusedDoBind)
+                     True
+                     (badMonadBind 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
+           when warn_wrong $
+                do { case tcSplitAppTy_maybe norm_elt_ty of
+                         Just (elt_m_ty, _)
+                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
+                            -> warnTc (Reason Opt_WarnWrongDoBind)
+                                      True
+                                      (badMonadBind rhs elt_ty)
+                         _ -> return () } } }
+
+  | otherwise   -- RHS does have type of form (m ty), which is weird
+  = return ()   -- but at lesat this warning is irrelevant
+
+badMonadBind :: Outputable rhs => rhs -> Type -> SDoc
+badMonadBind rhs elt_ty
+  = vcat [ hang (text "A do-notation statement discarded a result of type")
+              2 (quotes (ppr elt_ty))
+         , hang (text "Suppress this warning by saying")
+              2 (quotes $ text "_ <-" <+> ppr rhs)
+         ]