[Git][ghc/ghc][wip/move-warnDs] Move warnAbout* variants from MatchLit to TcWarnings, call from TcHsSyn,...
Sebastian Graf
gitlab at gitlab.haskell.org
Sat Jun 15 15:24:30 UTC 2019
Sebastian Graf pushed to branch wip/move-warnDs at Glasgow Haskell Compiler / GHC
Commits:
9cdbc2ab by Sebastian Graf at 2019-06-15T15:24:14Z
Move warnAbout* variants from MatchLit to TcWarnings, call from TcHsSyn, remove from DsWarn and descendents
- - - - -
6 changed files:
- compiler/deSugar/DsExpr.hs
- compiler/deSugar/Match.hs
- compiler/deSugar/MatchLit.hs
- compiler/ghc.cabal.in
- compiler/typecheck/TcHsSyn.hs
- + compiler/typecheck/TcWarnings.hs
Changes:
=====================================
compiler/deSugar/DsExpr.hs
=====================================
@@ -266,34 +266,18 @@ ds_expr w (HsConLikeOut _ con) = dsConLike w con
ds_expr _ (HsIPVar {}) = panic "dsExpr: HsIPVar"
ds_expr _ (HsOverLabel{}) = panic "dsExpr: HsOverLabel"
-ds_expr _ (HsLit _ lit)
- = do { warnAboutOverflowedLit lit
- ; dsLit (convertLit lit) }
-
-ds_expr _ (HsOverLit _ lit)
- = do { warnAboutOverflowedOverLit lit
- ; dsOverLit lit }
+ds_expr _ (HsLit _ lit) = dsLit (convertLit lit)
+ds_expr _ (HsOverLit _ lit) = dsOverLit lit
ds_expr _ (HsWrap _ co_fn e)
= do { e' <- ds_expr True e -- This is the one place where we recurse to
-- ds_expr (passing True), rather than dsExpr
; wrap' <- dsHsWrapper co_fn
- ; dflags <- getDynFlags
; let wrapped_e = wrap' e'
wrapped_ty = exprType wrapped_e
; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion]
- ; warnAboutIdentities dflags e' wrapped_ty
; return wrapped_e }
-ds_expr _ (NegApp _ (dL->L loc
- (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
- neg_expr)
- = do { expr' <- putSrcSpanDs loc $ do
- { warnAboutOverflowedOverLit
- (lit { ol_val = HsIntegral (negateIntegralLit i) })
- ; dsOverLit lit }
- ; dsSyntaxExpr neg_expr [expr'] }
-
ds_expr _ (NegApp _ expr neg_expr)
= do { expr' <- dsLExpr expr
; dsSyntaxExpr neg_expr [expr'] }
@@ -865,18 +849,14 @@ dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
dsArithSeq expr (From from)
= App <$> dsExpr expr <*> dsLExprNoLP from
dsArithSeq expr (FromTo from to)
- = do dflags <- getDynFlags
- warnAboutEmptyEnumerations dflags from Nothing to
- expr' <- dsExpr expr
+ = do expr' <- dsExpr expr
from' <- dsLExprNoLP from
to' <- dsLExprNoLP to
return $ mkApps expr' [from', to']
dsArithSeq expr (FromThen from thn)
= mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]
dsArithSeq expr (FromThenTo from thn to)
- = do dflags <- getDynFlags
- warnAboutEmptyEnumerations dflags from (Just thn) to
- expr' <- dsExpr expr
+ = do expr' <- dsExpr expr
from' <- dsLExprNoLP from
thn' <- dsLExprNoLP thn
to' <- dsLExprNoLP to
=====================================
compiler/deSugar/Match.hs
=====================================
@@ -466,25 +466,11 @@ tidy1 _ _ (SumPat tys pat alt arity)
sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
-- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (LitPat _ lit)
- = do { unless (isGenerated o) $
- warnAboutOverflowedLit lit
- ; return (idDsWrapper, tidyLitPat lit) }
+tidy1 _ _ (LitPat _ lit) = return (idDsWrapper, tidyLitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 _ o (NPat ty (dL->L _ lit at OverLit { ol_val = v }) mb_neg eq)
- = do { unless (isGenerated o) $
- let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
- | otherwise = lit
- in warnAboutOverflowedOverLit lit'
- ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
-
--- NPlusKPat: we may want to warn about the literals
-tidy1 _ o n@(NPlusKPat _ _ (dL->L _ lit1) lit2 _ _)
- = do { unless (isGenerated o) $ do
- warnAboutOverflowedOverLit lit1
- warnAboutOverflowedOverLit lit2
- ; return (idDsWrapper, n) }
+ = return (idDsWrapper, tidyNPat lit mb_neg eq ty)
-- Everything else goes through unchanged...
tidy1 _ _ non_interesting_pat
=====================================
compiler/deSugar/MatchLit.hs
=====================================
@@ -12,9 +12,6 @@ Pattern-matching literal patterns
module MatchLit ( dsLit, dsOverLit, hsLitKey
, tidyLitPat, tidyNPat
, matchLiterals, matchNPlusKPats, matchNPats
- , warnAboutIdentities
- , warnAboutOverflowedOverLit, warnAboutOverflowedLit
- , warnAboutEmptyEnumerations
) where
#include "HsVersions.h"
@@ -124,197 +121,8 @@ The type checker tries to do this short-cutting as early as possible, but
because of unification etc, more information is available to the desugarer.
And where it's possible to generate the correct literal right away, it's
much better to do so.
-
-
-************************************************************************
-* *
- Warnings about overflowed literals
-* *
-************************************************************************
-
-Warn about functions like toInteger, fromIntegral, that convert
-between one type and another when the to- and from- types are the
-same. Then it's probably (albeit not definitely) the identity
--}
-
-warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
-warnAboutIdentities dflags (Var conv_fn) type_of_conv
- | wopt Opt_WarnIdentities dflags
- , idName conv_fn `elem` conversionNames
- , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
- , arg_ty `eqType` res_ty -- So we are converting ty -> ty
- = warnDs (Reason Opt_WarnIdentities)
- (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
- , nest 2 $ text "can probably be omitted"
- ])
-warnAboutIdentities _ _ _ = return ()
-
-conversionNames :: [Name]
-conversionNames
- = [ toIntegerName, toRationalName
- , fromIntegralName, realToFracName ]
- -- We can't easily add fromIntegerName, fromRationalName,
- -- because they are generated by literals
-
-
--- | Emit warnings on overloaded integral literals which overflow the bounds
--- implied by their type.
-warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
-warnAboutOverflowedOverLit hsOverLit = do
- dflags <- getDynFlags
- warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit)
-
--- | Emit warnings on integral literals which overflow the boudns implied by
--- their type.
-warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
-warnAboutOverflowedLit hsLit = do
- dflags <- getDynFlags
- warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit)
-
--- | Emit warnings on integral literals which overflow the bounds implied by
--- their type.
-warnAboutOverflowedLiterals
- :: DynFlags
- -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon
- -> DsM ()
-warnAboutOverflowedLiterals dflags lit
- | wopt Opt_WarnOverflowedLiterals dflags
- , Just (i, tc) <- lit
- = if tc == intTyConName then check i tc (Proxy :: Proxy Int)
-
- -- These only show up via the 'HsOverLit' route
- else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8)
- else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16)
- else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32)
- else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64)
- else if tc == wordTyConName then check i tc (Proxy :: Proxy Word)
- else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8)
- else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
- else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32)
- else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64)
- else if tc == naturalTyConName then checkPositive i tc
-
- -- These only show up via the 'HsLit' route
- else if tc == intPrimTyConName then check i tc (Proxy :: Proxy Int)
- else if tc == int8PrimTyConName then check i tc (Proxy :: Proxy Int8)
- else if tc == int32PrimTyConName then check i tc (Proxy :: Proxy Int32)
- else if tc == int64PrimTyConName then check i tc (Proxy :: Proxy Int64)
- else if tc == wordPrimTyConName then check i tc (Proxy :: Proxy Word)
- else if tc == word8PrimTyConName then check i tc (Proxy :: Proxy Word8)
- else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32)
- else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64)
-
- else return ()
-
- | otherwise = return ()
- where
-
- checkPositive :: Integer -> Name -> DsM ()
- checkPositive i tc
- = when (i < 0) $ do
- warnDs (Reason Opt_WarnOverflowedLiterals)
- (vcat [ text "Literal" <+> integer i
- <+> text "is negative but" <+> ppr tc
- <+> ptext (sLit "only supports positive numbers")
- ])
-
- check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
- check i tc _proxy
- = when (i < minB || i > maxB) $ do
- warnDs (Reason Opt_WarnOverflowedLiterals)
- (vcat [ text "Literal" <+> integer i
- <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
- <+> integer minB <> text ".." <> integer maxB
- , sug ])
- where
- minB = toInteger (minBound :: a)
- maxB = toInteger (maxBound :: a)
- sug | minB == -i -- Note [Suggest NegativeLiterals]
- , i > 0
- , not (xopt LangExt.NegativeLiterals dflags)
- = text "If you are trying to write a large negative literal, use NegativeLiterals"
- | otherwise = Outputable.empty
-
-{-
-Note [Suggest NegativeLiterals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If you write
- x :: Int8
- x = -128
-it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals.
-We get an erroneous suggestion for
- x = 128
-but perhaps that does not matter too much.
-}
-warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
- -> LHsExpr GhcTc -> DsM ()
--- ^ Warns about @[2,3 .. 1]@ which returns the empty list.
--- Only works for integral types, not floating point.
-warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
- | wopt Opt_WarnEmptyEnumerations dflags
- , Just (from,tc) <- getLHsIntegralLit fromExpr
- , Just mThn <- traverse getLHsIntegralLit mThnExpr
- , Just (to,_) <- getLHsIntegralLit toExpr
- , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM ()
- check _proxy
- = when (null enumeration) $
- warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
- where
- enumeration :: [a]
- enumeration = case mThn of
- Nothing -> [fromInteger from .. fromInteger to]
- Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to]
-
- = if tc == intTyConName then check (Proxy :: Proxy Int)
- else if tc == int8TyConName then check (Proxy :: Proxy Int8)
- else if tc == int16TyConName then check (Proxy :: Proxy Int16)
- else if tc == int32TyConName then check (Proxy :: Proxy Int32)
- else if tc == int64TyConName then check (Proxy :: Proxy Int64)
- else if tc == wordTyConName then check (Proxy :: Proxy Word)
- else if tc == word8TyConName then check (Proxy :: Proxy Word8)
- else if tc == word16TyConName then check (Proxy :: Proxy Word16)
- else if tc == word32TyConName then check (Proxy :: Proxy Word32)
- else if tc == word64TyConName then check (Proxy :: Proxy Word64)
- else if tc == integerTyConName then check (Proxy :: Proxy Integer)
- else if tc == naturalTyConName then check (Proxy :: Proxy Integer)
- -- We use 'Integer' because otherwise a negative 'Natural' literal
- -- could cause a compile time crash (instead of a runtime one).
- -- See the T10930b test case for an example of where this matters.
- else return ()
-
- | otherwise = return ()
-
-getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
--- ^ See if the expression is an 'Integral' literal.
--- Remember to look through automatically-added tick-boxes! (#8384)
-getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
-getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
-getLHsIntegralLit (dL->L _ (HsLit _ lit)) = getSimpleIntegralLit lit
-getLHsIntegralLit _ = Nothing
-
--- | If 'Integral', extract the value and type name of the overloaded literal.
-getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
- | Just tc <- tyConAppTyCon_maybe ty
- = Just (il_value i, tyConName tc)
-getIntegralLit _ = Nothing
-
--- | If 'Integral', extract the value and type name of the non-overloaded
--- literal.
-getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)
-getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName)
-getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName)
-getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName)
-getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName)
-getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName)
-getSimpleIntegralLit (HsInteger _ i ty)
- | Just tc <- tyConAppTyCon_maybe ty
- = Just (i, tyConName tc)
-getSimpleIntegralLit _ = Nothing
-
{-
************************************************************************
* *
=====================================
compiler/ghc.cabal.in
=====================================
@@ -522,6 +522,7 @@ Library
TcSimplify
TcHoleErrors
TcErrors
+ TcWarnings
TcTyClsDecls
TcTyDecls
TcTypeable
=====================================
compiler/typecheck/TcHsSyn.hs
=====================================
@@ -58,6 +58,7 @@ import TcType
import TcMType
import TcEnv ( tcLookupGlobalOnly )
import TcEvidence
+import TcWarnings
import TysPrim
import TyCon
import TysWiredIn
@@ -771,7 +772,7 @@ zonkExpr _ (HsLit x lit)
= return (HsLit x lit)
zonkExpr env (HsOverLit x lit)
- = do { lit' <- zonkOverLit env lit
+ = do { lit' <- zonkOverLit env False lit
; return (HsOverLit x lit') }
zonkExpr env (HsLam x matches)
@@ -817,6 +818,9 @@ zonkExpr env (OpApp fixity e1 op e2)
zonkExpr env (NegApp x expr op)
= do (env', new_op) <- zonkSyntaxExpr env op
new_expr <- zonkLExpr env' expr
+ case dL new_expr of
+ L _ (HsOverLit _ lit) -> warnAboutOverflowedOverLit True lit
+ _ -> return ()
return (NegApp x new_expr new_op)
zonkExpr env (HsPar x e)
@@ -957,7 +961,10 @@ zonkExpr env (HsStatic fvs expr)
zonkExpr env (HsWrap x co_fn expr)
= do (env1, new_co_fn) <- zonkCoFn env co_fn
new_expr <- zonkExpr env1 expr
- return (HsWrap x new_co_fn new_expr)
+ let wrap = HsWrap x new_co_fn new_expr
+ dflags <- getDynFlags
+ warnAboutIdentities dflags new_expr new_co_fn
+ return wrap
zonkExpr _ e@(HsUnboundVar {}) = return e
@@ -1104,13 +1111,15 @@ zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
; return (env1, WpLet bs') }
-------------------------------------------------------------------------
-zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc)
-zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })
+zonkOverLit :: ZonkEnv -> Bool -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc)
+zonkOverLit env is_neg lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })
= do { ty' <- zonkTcTypeToTypeX env ty
; e' <- zonkExpr env e
- ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }
+ ; let lit' = (lit { ol_witness = e', ol_ext = OverLitTc r ty' })
+ ; warnAboutOverflowedOverLit is_neg lit'
+ ; return lit' }
-zonkOverLit _ XOverLit{} = panic "zonkOverLit"
+zonkOverLit _ _ XOverLit{} = panic "zonkOverLit"
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)
@@ -1127,12 +1136,16 @@ zonkArithSeq env (FromThen e1 e2)
zonkArithSeq env (FromTo e1 e2)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
+ dflags <- getDynFlags
+ warnAboutEmptyEnumerations dflags new_e1 Nothing new_e2
return (FromTo new_e1 new_e2)
zonkArithSeq env (FromThenTo e1 e2 e3)
= do new_e1 <- zonkLExpr env e1
new_e2 <- zonkLExpr env e2
new_e3 <- zonkLExpr env e3
+ dflags <- getDynFlags
+ warnAboutEmptyEnumerations dflags new_e1 (Just new_e2) new_e3
return (FromThenTo new_e1 new_e2 new_e3)
@@ -1432,7 +1445,9 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys
where
doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
-zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
+zonk_pat env (LitPat x lit)
+ = do { warnAboutOverflowedLit lit
+ ; return (env, LitPat x lit) }
zonk_pat env (SigPat ty pat hs_ty)
= do { ty' <- zonkTcTypeToTypeX env ty
@@ -1445,7 +1460,7 @@ zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr)
Nothing -> return (env1, Nothing)
Just n -> second Just <$> zonkSyntaxExpr env1 n
- ; lit' <- zonkOverLit env2 lit
+ ; lit' <- zonkOverLit env2 (isJust mb_neg) lit
; ty' <- zonkTcTypeToTypeX env2 ty
; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') }
@@ -1453,8 +1468,8 @@ zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2)
= do { (env1, e1') <- zonkSyntaxExpr env e1
; (env2, e2') <- zonkSyntaxExpr env1 e2
; n' <- zonkIdBndr env2 n
- ; lit1' <- zonkOverLit env2 lit1
- ; lit2' <- zonkOverLit env2 lit2
+ ; lit1' <- zonkOverLit env2 False lit1
+ ; lit2' <- zonkOverLit env2 False lit2
; ty' <- zonkTcTypeToTypeX env2 ty
; return (extendIdZonkEnv1 env2 n',
NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') }
=====================================
compiler/typecheck/TcWarnings.hs
=====================================
@@ -0,0 +1,228 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Warnings generated after or while type-checking.
+module TcWarnings (
+ -- * Warnings about overflowed literals
+ warnAboutIdentities,
+ warnAboutOverflowedOverLit, warnAboutOverflowedLit,
+ warnAboutEmptyEnumerations
+ ) where
+
+import GhcPrelude
+
+import TcRnMonad
+import HsSyn
+
+import Id
+import TyCon
+import Name
+import Type
+import Coercion
+import TcEvidence
+import PrelNames
+import TysWiredIn
+import TysPrim
+import SrcLoc
+import Outputable
+import BasicTypes
+import DynFlags
+import FastString
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad (when)
+import Data.Bifunctor (first)
+import Data.Int
+import Data.Word
+import Data.Proxy
+
+-- | Warn about functions like toInteger, fromIntegral, that convert
+-- between one type and another when the to- and from- types are the
+-- same. Then it's probably (albeit not definitely) the identity
+warnAboutIdentities :: DynFlags -> HsExpr GhcTcId -> HsWrapper -> TcM ()
+warnAboutIdentities dflags (HsVar _ (dL->L _ conv_fn)) wrap
+ | wopt Opt_WarnIdentities dflags
+ , idName conv_fn `elem` conversionNames
+ , is_refl wrap
+ = warnTc (Reason Opt_WarnIdentities)
+ True
+ (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr (idType conv_fn)
+ , nest 2 $ text "can probably be omitted"
+ ])
+ where
+ is_refl wrap
+ | isIdHsWrapper wrap = True
+ | WpCast co <- wrap, isReflexiveCo co = True
+ | otherwise = False
+warnAboutIdentities _ _ _ = return ()
+
+conversionNames :: [Name]
+conversionNames
+ = [ toIntegerName, toRationalName
+ , fromIntegralName, realToFracName ]
+ -- We can't easily add fromIntegerName, fromRationalName,
+ -- because they are generated by literals
+
+
+-- | Emit warnings on overloaded integral literals which overflow the bounds
+-- implied by their type.
+warnAboutOverflowedOverLit :: Bool -> HsOverLit GhcTc -> TcM ()
+warnAboutOverflowedOverLit is_neg hsOverLit = do
+ dflags <- getDynFlags
+ let lit = first (if is_neg then negate else id) <$> getIntegralLit hsOverLit
+ warnAboutOverflowedLiterals dflags lit
+
+-- | Emit warnings on integral literals which overflow the boudns implied by
+-- their type.
+warnAboutOverflowedLit :: HsLit GhcTc -> TcM ()
+warnAboutOverflowedLit hsLit = do
+ dflags <- getDynFlags
+ warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit)
+
+-- | Emit warnings on integral literals which overflow the bounds implied by
+-- their type.
+warnAboutOverflowedLiterals
+ :: DynFlags
+ -> Maybe (Integer, Name) -- ^ the literal value and name of its tycon
+ -> TcM ()
+warnAboutOverflowedLiterals dflags lit
+ | wopt Opt_WarnOverflowedLiterals dflags
+ , Just (i, tc) <- lit
+ = if tc == intTyConName then check i tc (Proxy :: Proxy Int)
+
+ -- These only show up via the 'HsOverLit' route
+ else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8)
+ else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16)
+ else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32)
+ else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64)
+ else if tc == wordTyConName then check i tc (Proxy :: Proxy Word)
+ else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8)
+ else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
+ else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32)
+ else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64)
+ else if tc == naturalTyConName then checkPositive i tc
+
+ -- These only show up via the 'HsLit' route
+ else if tc == intPrimTyConName then check i tc (Proxy :: Proxy Int)
+ else if tc == int8PrimTyConName then check i tc (Proxy :: Proxy Int8)
+ else if tc == int32PrimTyConName then check i tc (Proxy :: Proxy Int32)
+ else if tc == int64PrimTyConName then check i tc (Proxy :: Proxy Int64)
+ else if tc == wordPrimTyConName then check i tc (Proxy :: Proxy Word)
+ else if tc == word8PrimTyConName then check i tc (Proxy :: Proxy Word8)
+ else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32)
+ else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64)
+
+ else return ()
+
+ | otherwise = return ()
+ where
+
+ checkPositive :: Integer -> Name -> TcM ()
+ checkPositive i tc
+ = when (i < 0) $ do
+ warnTc (Reason Opt_WarnOverflowedLiterals)
+ True
+ (vcat [ text "Literal" <+> integer i
+ <+> text "is negative but" <+> ppr tc
+ <+> ptext (sLit "only supports positive numbers")
+ ])
+
+ check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> TcM ()
+ check i tc _proxy
+ = when (i < minB || i > maxB) $ do
+ warnTc (Reason Opt_WarnOverflowedLiterals)
+ True
+ (vcat [ text "Literal" <+> integer i
+ <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
+ <+> integer minB <> text ".." <> integer maxB
+ , sug ])
+ where
+ minB = toInteger (minBound :: a)
+ maxB = toInteger (maxBound :: a)
+ sug | minB == -i -- Note [Suggest NegativeLiterals]
+ , i > 0
+ , not (xopt LangExt.NegativeLiterals dflags)
+ = text "If you are trying to write a large negative literal, use NegativeLiterals"
+ | otherwise = Outputable.empty
+
+{-
+Note [Suggest NegativeLiterals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you write
+ x :: Int8
+ x = -128
+it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals.
+We get an erroneous suggestion for
+ x = 128
+but perhaps that does not matter too much.
+-}
+
+warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
+ -> LHsExpr GhcTc -> TcM ()
+-- ^ Warns about @[2,3 .. 1]@ which returns the empty list.
+-- Only works for integral types, not floating point.
+warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
+ | wopt Opt_WarnEmptyEnumerations dflags
+ , Just (from,tc) <- getLHsIntegralLit fromExpr
+ , Just mThn <- traverse getLHsIntegralLit mThnExpr
+ , Just (to,_) <- getLHsIntegralLit toExpr
+ , let check :: forall a. (Enum a, Num a) => Proxy a -> TcM ()
+ check _proxy
+ = when (null enumeration) $
+ warnTc (Reason Opt_WarnEmptyEnumerations)
+ True
+ (text "Enumeration is empty")
+ where
+ enumeration :: [a]
+ enumeration = case mThn of
+ Nothing -> [fromInteger from .. fromInteger to]
+ Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to]
+
+ = if tc == intTyConName then check (Proxy :: Proxy Int)
+ else if tc == int8TyConName then check (Proxy :: Proxy Int8)
+ else if tc == int16TyConName then check (Proxy :: Proxy Int16)
+ else if tc == int32TyConName then check (Proxy :: Proxy Int32)
+ else if tc == int64TyConName then check (Proxy :: Proxy Int64)
+ else if tc == wordTyConName then check (Proxy :: Proxy Word)
+ else if tc == word8TyConName then check (Proxy :: Proxy Word8)
+ else if tc == word16TyConName then check (Proxy :: Proxy Word16)
+ else if tc == word32TyConName then check (Proxy :: Proxy Word32)
+ else if tc == word64TyConName then check (Proxy :: Proxy Word64)
+ else if tc == integerTyConName then check (Proxy :: Proxy Integer)
+ else if tc == naturalTyConName then check (Proxy :: Proxy Integer)
+ -- We use 'Integer' because otherwise a negative 'Natural' literal
+ -- could cause a compile time crash (instead of a runtime one).
+ -- See the T10930b test case for an example of where this matters.
+ else return ()
+
+ | otherwise = return ()
+
+getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
+-- ^ See if the expression is an 'Integral' literal.
+-- Remember to look through automatically-added tick-boxes! (#8384)
+getLHsIntegralLit (dL->L _ (HsPar _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsTick _ _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit (dL->L _ (HsLit _ lit)) = getSimpleIntegralLit lit
+getLHsIntegralLit _ = Nothing
+
+-- | If 'Integral', extract the value and type name of the overloaded literal.
+getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
+ | Just tc <- tyConAppTyCon_maybe ty
+ = Just (il_value i, tyConName tc)
+getIntegralLit _ = Nothing
+
+-- | If 'Integral', extract the value and type name of the non-overloaded
+-- literal.
+getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)
+getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName)
+getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName)
+getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName)
+getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName)
+getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName)
+getSimpleIntegralLit (HsInteger _ i ty)
+ | Just tc <- tyConAppTyCon_maybe ty
+ = Just (i, tyConName tc)
+getSimpleIntegralLit _ = Nothing
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/9cdbc2ab0849ff4cbff044dab4e7dab8d27551d1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/9cdbc2ab0849ff4cbff044dab4e7dab8d27551d1
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/20190615/6d28e34a/attachment-0001.html>
More information about the ghc-commits
mailing list