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`.

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'])