Add a warning for overflowing literals; fixes #7895

2 files changed, 40 insertions, 2 deletions

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 136fc8c1c4..e2dd798928 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -54,9 +54,14 @@ import SrcLoc
 import Util
 import Bag
 import Outputable
+import Literal
+import TyCon
 import FastString
 
 import Control.Monad
+import Data.Int
+import Data.Typeable (typeOf)
+import Data.Word
 \end{code}
 
 
@@ -211,7 +216,10 @@ dsExpr (HsLamCase arg matches)
        ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
 
 dsExpr (HsApp fun arg)
-  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
+  = do ds <- mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
+       warn_overflowed_literals <- woptM Opt_WarnOverflowedLiterals
+       when warn_overflowed_literals $ warnAboutOverflowedLiterals ds
+       return ds
 
 dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
 \end{code}
@@ -805,7 +813,7 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
 
 %************************************************************************
 %*                                                                      *
-                 Warning about identities
+                 Warnings
 %*                                                                      *
 %************************************************************************
 
@@ -834,6 +842,33 @@ conversionNames
  -- because they are generated by literals
 \end{code}
 
+\begin{code}
+warnAboutOverflowedLiterals :: CoreExpr -> DsM ()
+warnAboutOverflowedLiterals (App (App (App (Var f) (Type t)) _) (Lit (LitInteger i _)))
+ | idName f == fromIntegerName,
+   Just tc <- tyConAppTyCon_maybe t,
+   let t = tyConName tc
+    = let checkOverflow proxy
+              = when (i < fromIntegral (minBound `asTypeOf` proxy) ||
+                      i > fromIntegral (maxBound `asTypeOf` proxy)) $
+                    warnDs (ptext (sLit "Literal") <+> integer i <+>
+                            ptext (sLit "of type") <+>
+                            text (show (typeOf proxy)) <+>
+                            ptext (sLit "overflows"))
+      in      if t == intTyConName    then checkOverflow (undefined :: Int)
+         else if t == int8TyConName   then checkOverflow (undefined :: Int8)
+         else if t == int16TyConName  then checkOverflow (undefined :: Int16)
+         else if t == int32TyConName  then checkOverflow (undefined :: Int32)
+         else if t == int64TyConName  then checkOverflow (undefined :: Int64)
+         else if t == wordTyConName   then checkOverflow (undefined :: Word)
+         else if t == word8TyConName  then checkOverflow (undefined :: Word8)
+         else if t == word16TyConName then checkOverflow (undefined :: Word16)
+         else if t == word32TyConName then checkOverflow (undefined :: Word32)
+         else if t == word64TyConName then checkOverflow (undefined :: Word64)
+         else return ()
+warnAboutOverflowedLiterals _ = return ()
+\end{code}
+
 %************************************************************************
 %*                                                                      *
 \subsection{Errors and contexts}
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 975ffecf05..eeb48bab8e 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -413,6 +413,7 @@ data WarningFlag =
    | Opt_WarnIncompletePatterns
    | Opt_WarnIncompleteUniPatterns
    | Opt_WarnIncompletePatternsRecUpd
+   | Opt_WarnOverflowedLiterals
    | Opt_WarnMissingFields
    | Opt_WarnMissingImportList
    | Opt_WarnMissingMethods
@@ -2432,6 +2433,7 @@ fWarningFlags = [
   ( "warn-dodgy-foreign-imports",       Opt_WarnDodgyForeignImports, nop ),
   ( "warn-dodgy-exports",               Opt_WarnDodgyExports, nop ),
   ( "warn-dodgy-imports",               Opt_WarnDodgyImports, nop ),
+  ( "warn-overflowed-literals",         Opt_WarnOverflowedLiterals, nop ),
   ( "warn-duplicate-exports",           Opt_WarnDuplicateExports, nop ),
   ( "warn-duplicate-constraints",       Opt_WarnDuplicateConstraints, nop ),
   ( "warn-hi-shadowing",                Opt_WarnHiShadows, nop ),
@@ -2861,6 +2863,7 @@ standardWarnings
         Opt_WarnPointlessPragmas,
         Opt_WarnDuplicateConstraints,
         Opt_WarnDuplicateExports,
+        Opt_WarnOverflowedLiterals,
         Opt_WarnMissingFields,
         Opt_WarnMissingMethods,
         Opt_WarnLazyUnliftedBindings,