diff options
| -rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Match/Literal.hs | 82 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T18172.hs | 13 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T18172.script | 22 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T18172.stderr | 47 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/T18172.stdout | 14 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_run/all.T | 1 |
7 files changed, 162 insertions, 27 deletions
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index ff23a9c168..6b55926af3 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -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 diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index cb38aef33a..ed4ceafa05 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -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`. +-} + {- ************************************************************************ * * diff --git a/testsuite/tests/deSugar/should_run/T18172.hs b/testsuite/tests/deSugar/should_run/T18172.hs new file mode 100644 index 0000000000..afd21fc9f0 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T18172.hs @@ -0,0 +1,13 @@ +{-# 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 diff --git a/testsuite/tests/deSugar/should_run/T18172.script b/testsuite/tests/deSugar/should_run/T18172.script new file mode 100644 index 0000000000..f0226e85c4 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T18172.script @@ -0,0 +1,22 @@ +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] diff --git a/testsuite/tests/deSugar/should_run/T18172.stderr b/testsuite/tests/deSugar/should_run/T18172.stderr new file mode 100644 index 0000000000..f5771d8121 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T18172.stderr @@ -0,0 +1,47 @@ +<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 diff --git a/testsuite/tests/deSugar/should_run/T18172.stdout b/testsuite/tests/deSugar/should_run/T18172.stdout new file mode 100644 index 0000000000..8f30df2597 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T18172.stdout @@ -0,0 +1,14 @@ +[255] +[0] +[254] +[1] +253 :| [] +2 :| [] +ZipList {getZipList = [252]} +ZipList {getZipList = [3]} +[Just 4] +[Just [Just 5]] +[(6,0)] +[] +[] +Wombat [4,8,10] diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T index 214f088aea..6245f9caf5 100644 --- a/testsuite/tests/deSugar/should_run/all.T +++ b/testsuite/tests/deSugar/should_run/all.T @@ -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']) |