Commit fe281b27 authored by Roland Senn's avatar Roland Senn Committed by Marge Bot

Enable maxBound checks for OverloadedLists (Fixes #18172)

Consider the Literal `[256] :: [Data.Word.Word8]`

When the `OverloadedLists` extension is not active, then the `ol_ext` field
in the `OverLitTc` record that is passed to the function `getIntegralLit`
contains the type `Word8`. This is a simple type, and we can use its
type constructor immediately for the `warnAboutOverflowedLiterals` function.

When the `OverloadedLists` extension is active, then the `ol_ext` field
contains the type family `Item [Word8]`. The function `nomaliseType` is used
to convert it to the needed type `Word8`.
parent c50ef26e
......@@ -945,8 +945,9 @@ 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
= do fam_envs <- dsGetFamInstEnvs
dflags <- getDynFlags
warnAboutEmptyEnumerations fam_envs dflags from Nothing to
expr' <- dsExpr expr
from' <- dsLExprNoLP from
to' <- dsLExprNoLP to
......@@ -954,8 +955,9 @@ dsArithSeq expr (FromTo 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
= do fam_envs <- dsGetFamInstEnvs
dflags <- getDynFlags
warnAboutEmptyEnumerations fam_envs dflags from (Just thn) to
expr' <- dsExpr expr
from' <- dsLExprNoLP from
thn' <- dsLExprNoLP thn
......
......@@ -55,6 +55,7 @@ import GHC.Driver.Session
import GHC.Utils.Misc
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )
import Control.Monad
import Data.Int
......@@ -169,14 +170,17 @@ conversionNames
warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
warnAboutOverflowedOverLit hsOverLit = do
dflags <- getDynFlags
warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit)
fam_envs <- dsGetFamInstEnvs
warnAboutOverflowedLiterals dflags $
getIntegralLit hsOverLit >>= getNormalisedTyconName fam_envs
-- | Emit warnings on integral literals which overflow the bounds implied by
-- their type.
warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
warnAboutOverflowedLit hsLit = do
dflags <- getDynFlags
warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit)
warnAboutOverflowedLiterals dflags $
getSimpleIntegralLit hsLit >>= getTyconName
-- | Emit warnings on integral literals which overflow the bounds implied by
-- their type.
......@@ -254,15 +258,17 @@ We get an erroneous suggestion for
but perhaps that does not matter too much.
-}
warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
warnAboutEmptyEnumerations :: FamInstEnvs -> 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
warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr
| wopt Opt_WarnEmptyEnumerations dflags
, Just (from,tc) <- getLHsIntegralLit fromExpr
, Just mThn <- traverse getLHsIntegralLit mThnExpr
, Just (to,_) <- getLHsIntegralLit toExpr
, Just from_ty@(from,_) <- getLHsIntegralLit fromExpr
, Just (_, tc) <- getNormalisedTyconName fam_envs from_ty
, 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) $
......@@ -292,7 +298,7 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
| otherwise = return ()
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type)
-- ^ See if the expression is an 'Integral' literal.
-- Remember to look through automatically-added tick-boxes! (#8384)
getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e
......@@ -302,26 +308,56 @@ getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
getLHsIntegralLit (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)
-- | If 'Integral', extract the value and type of the overloaded literal.
-- See Note [Literals and the OverloadedLists extension]
getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)
getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
| Just tc <- tyConAppTyCon_maybe ty
= Just (il_value i, tyConName tc)
= Just (il_value i, ty)
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)
-- | If 'Integral', extract the value and type of the non-overloaded literal.
getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type)
getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy)
getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy)
getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy)
getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy)
getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy)
getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty)
getSimpleIntegralLit _ = Nothing
-- | Convert a pair (Integer, Type) to (Integer, Name) after eventually
-- normalising the type
getNormalisedTyconName :: FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)
getNormalisedTyconName fam_envs (i,ty)
| Just tc <- tyConAppTyCon_maybe (normaliseNominal fam_envs ty)
= Just (i, tyConName tc)
| otherwise = Nothing
where
normaliseNominal :: FamInstEnvs -> Type -> Type
normaliseNominal fam_envs ty = snd $ normaliseType fam_envs Nominal ty
-- | Convert a pair (Integer, Type) to (Integer, Name) without normalising
-- the type
getTyconName :: (Integer, Type) -> Maybe (Integer, Name)
getTyconName (i,ty)
| Just tc <- tyConAppTyCon_maybe ty = Just (i, tyConName tc)
| otherwise = Nothing
{-
Note [Literals and the OverloadedLists extension]
~~~~
Consider the Literal `[256] :: [Data.Word.Word8]`
When the `OverloadedLists` extension is not active, then the `ol_ext` field
in the `OverLitTc` record that is passed to the function `getIntegralLit`
contains the type `Word8`. This is a simple type, and we can use its
type constructor immediately for the `warnAboutOverflowedLiterals` function.
When the `OverloadedLists` extension is active, then the `ol_ext` field
contains the type family `Item [Word8]`. The function `nomaliseType` is used
to convert it to the needed type `Word8`.
-}
{-
************************************************************************
* *
......
{-# LANGUAGE TypeFamilies #-}
module T18172 where
import Data.Word
import GHC.Exts
data Wombat = Wombat [Word8]
deriving Show
instance IsList Wombat where
type Item Wombat = Word8
fromList xs = Wombat xs
toList (Wombat xs)= xs
import Data.Word
[-1] :: [Word8]
[256] :: [Word8]
:set -XOverloadedLists
[-2] :: [Word8]
[257] :: [Word8]
import Data.List.NonEmpty
[-3] :: NonEmpty Word8
[258] :: NonEmpty Word8
import Control.Applicative
ZipList [-4] :: ZipList Word8
ZipList [259] :: ZipList Word8
[Just 260] :: [Maybe Word8]
[Just [Just 261]] :: [Maybe ([Maybe Word8])]
[(262, 65536)] :: [(Word8, Word16)]
[-5..100]::[Word8]
[100..263]::[Word8]
:l T18172.hs
Wombat [4, 264, 10]
<interactive>:2:3: warning: [-Woverflowed-literals (in -Wdefault)]
Literal -1 is out of the Word8 range 0..255
<interactive>:3:2: warning: [-Woverflowed-literals (in -Wdefault)]
Literal 256 is out of the Word8 range 0..255
<interactive>:5:3: warning: [-Woverflowed-literals (in -Wdefault)]
Literal -2 is out of the Word8 range 0..255
<interactive>:6:2: warning: [-Woverflowed-literals (in -Wdefault)]
Literal 257 is out of the Word8 range 0..255
<interactive>:8:3: warning: [-Woverflowed-literals (in -Wdefault)]
Literal -3 is out of the Word8 range 0..255
<interactive>:9:2: warning: [-Woverflowed-literals (in -Wdefault)]
Literal 258 is out of the Word8 range 0..255
<interactive>:11:11: warning: [-Woverflowed-literals (in -Wdefault)]
Literal -4 is out of the Word8 range 0..255
<interactive>:12:10: warning: [-Woverflowed-literals (in -Wdefault)]
Literal 259 is out of the Word8 range 0..255
<interactive>:14:7: warning: [-Woverflowed-literals (in -Wdefault)]
Literal 260 is out of the Word8 range 0..255
<interactive>:15:13: warning: [-Woverflowed-literals (in -Wdefault)]
Literal 261 is out of the Word8 range 0..255
<interactive>:16:3: warning: [-Woverflowed-literals (in -Wdefault)]
Literal 262 is out of the Word8 range 0..255
<interactive>:16:8: warning: [-Woverflowed-literals (in -Wdefault)]
Literal 65536 is out of the Word16 range 0..65535
<interactive>:18:3: warning: [-Woverflowed-literals (in -Wdefault)]
Literal -5 is out of the Word8 range 0..255
<interactive>:19:1: warning: [-Wempty-enumerations (in -Wdefault)]
Enumeration is empty
<interactive>:19:7: warning: [-Woverflowed-literals (in -Wdefault)]
Literal 263 is out of the Word8 range 0..255
<interactive>:22:12: warning: [-Woverflowed-literals (in -Wdefault)]
Literal 264 is out of the Word8 range 0..255
[255]
[0]
[254]
[1]
253 :| []
2 :| []
ZipList {getZipList = [252]}
ZipList {getZipList = [3]}
[Just 4]
[Just [Just 5]]
[(6,0)]
[]
[]
Wombat [4,8,10]
......@@ -65,3 +65,4 @@ test('T11747', normal, compile_and_run, ['-dcore-lint'])
test('T12595', normal, compile_and_run, [''])
test('T13285', normal, compile_and_run, [''])
test('T18151', normal, compile_and_run, [''])
test('T18172', [], ghci_script, ['T18172.script'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment