[commit: ghc] master: Add a warning for overflowing literals; fixes #7895 (4e7eb3a)

[Ian Lynagh]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/4e7eb3a0e32080acada355eae657e4e27465bc7e

>---------------------------------------------------------------

commit 4e7eb3a0e32080acada355eae657e4e27465bc7e
Author: Ian Lynagh <ian at well-typed.com>
Date:   Wed Jul 31 16:49:49 2013 +0100

    Add a warning for overflowing literals; fixes #7895

>---------------------------------------------------------------

 compiler/deSugar/DsExpr.lhs |   39 +++++++++++++++++++++++++++++++++++++--
 compiler/main/DynFlags.hs   |    3 +++
 docs/users_guide/using.xml  |   13 +++++++++++++
 3 files changed, 53 insertions(+), 2 deletions(-)

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 136fc8c..e2dd798 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 975ffec..eeb48ba 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,
diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index e882f8e..9e17bfb 100644
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -966,6 +966,7 @@ test.hs:(5,4)-(6,7):
     <option>-fwarn-pointless-pragmas</option>,
     <option>-fwarn-duplicate-constraints</option>,
     <option>-fwarn-duplicate-exports</option>,
+    <option>-fwarn-overflowed-literals</option>,
     <option>-fwarn-missing-fields</option>,
     <option>-fwarn-missing-methods</option>,
     <option>-fwarn-lazy-unlifted-bindings</option>,
@@ -1213,6 +1214,18 @@ foreign import "&amp;f" f :: FunPtr t
       </varlistentry>
 
       <varlistentry>
+        <term><option>-fwarn-overflowed-literals</option>:</term>
+        <listitem>
+          <indexterm><primary><option>-fwarn-overflowed-literals</option></primary>
+          </indexterm>
+          <para>
+              Causes a warning to be emitted if a literal will overflow,
+              e.g. <literal>300 :: Word8</literal>.
+          </para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
         <term><option>-fwarn-lazy-unlifted-bindings</option>:</term>
         <listitem>
           <indexterm><primary><option>-fwarn-lazy-unlifted-bindings</option></primary>