[Git][ghc/ghc][wip/move-warnDs] 2 commits: Remove unused imports in MatchLit
Sebastian Graf
gitlab at gitlab.haskell.org
Sun Jun 16 08:57:43 UTC 2019
Sebastian Graf pushed to branch wip/move-warnDs at Glasgow Haskell Compiler / GHC
Commits:
4b63a896 by Sebastian Graf at 2019-06-16T08:56:10Z
Remove unused imports in MatchLit
- - - - -
f8c1244d by Sebastian Graf at 2019-06-16T08:57:33Z
Move warnDiscardedDoBindings into TcWarnings
- - - - -
4 changed files:
- compiler/deSugar/DsExpr.hs
- compiler/deSugar/MatchLit.hs
- compiler/typecheck/TcHsSyn.hs
- compiler/typecheck/TcWarnings.hs
Changes:
=====================================
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] }
@@ -1015,51 +1013,6 @@ dsConLike _ (PatSynCon ps) = return $ case patSynBuilder ps of
| otherwise -> Var id
_ -> pprPanic "dsConLike" (ppr ps)
-{-
-************************************************************************
-* *
-\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)
- ]
-
{-
************************************************************************
* *
=====================================
compiler/deSugar/MatchLit.hs
=====================================
@@ -33,11 +33,8 @@ import TyCon
import DataCon
import TcHsSyn ( shortCutLit )
import TcType
-import Name
-import Type
import PrelNames
import TysWiredIn
-import TysPrim
import Literal
import SrcLoc
import Data.Ratio
@@ -46,12 +43,6 @@ import BasicTypes
import DynFlags
import Util
import FastString
-import qualified GHC.LanguageExtensions as LangExt
-
-import Control.Monad
-import Data.Int
-import Data.Word
-import Data.Proxy
{-
************************************************************************
=====================================
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)
=====================================
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)
+ ]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/9cdbc2ab0849ff4cbff044dab4e7dab8d27551d1...f8c1244d17543e2aec4089175b70f080d685e863
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/9cdbc2ab0849ff4cbff044dab4e7dab8d27551d1...f8c1244d17543e2aec4089175b70f080d685e863
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190616/b7311d67/attachment-0001.html>
More information about the ghc-commits
mailing list