Tidy up and refactor overflow checking for literals

It's much easier (and more efficient) to pattern match on
the HsOverLit than on the desugared version!

1 files changed, 144 insertions, 31 deletions

diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 23538bec82..d79cfcc30f 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -6,9 +6,11 @@
 Pattern-matching literal patterns
 
 \begin{code}
-module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey,
-                  tidyLitPat, tidyNPat,
-                  matchLiterals, matchNPlusKPats, matchNPats ) where
+module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey
+                , tidyLitPat, tidyNPat
+                , matchLiterals, matchNPlusKPats, matchNPats
+                , warnAboutIdentities, warnAboutEmptyEnumerations 
+                ) where
 
 #include "HsVersions.h"
 
@@ -27,6 +29,8 @@ import TyCon
 import DataCon
 import TcHsSyn ( shortCutLit )
 import TcType
+import Name
+import Type
 import PrelNames
 import TysWiredIn
 import Literal
@@ -38,6 +42,11 @@ import BasicTypes
 import DynFlags
 import Util
 import FastString
+import Control.Monad
+
+import Data.Int
+import Data.Traversable (traverse)
+import Data.Word
 \end{code}
 
 %************************************************************************
@@ -90,8 +99,9 @@ dsLit (HsRat r ty) = do
                 x -> pprPanic "dsLit" (ppr x)
 
 dsOverLit :: HsOverLit Id -> DsM CoreExpr
-dsOverLit lit = do dflags <- getDynFlags
-                   dsOverLit' dflags lit
+dsOverLit lit = do { dflags <- getDynFlags
+                   ; warnAboutOverflowedLiterals dflags lit
+                   ; dsOverLit' dflags lit }
 
 dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr
 -- Post-typechecker, the SyntaxExpr field of an OverLit contains
@@ -111,36 +121,109 @@ And where it's possible to generate the correct literal right away, it's
 much better to do so.
 
 
+%************************************************************************
+%*                                                                      *
+                 Warnings about overflowed literals
+%*                                                                      *
+%************************************************************************
+
+Warn about functions like toInteger, fromIntegral, that convert
+between one type and another when the to- and from- types are the
+same.  Then it's probably (albeit not definitely) the identity
+
 \begin{code}
-hsLitKey :: DynFlags -> HsLit -> Literal
--- Get a Core literal to use (only) a grouping key
--- Hence its type doesn't need to match the type of the original literal
---      (and doesn't for strings)
--- It only works for primitive types and strings;
--- others have been removed by tidy
-hsLitKey dflags (HsIntPrim     i) = mkMachInt  dflags i
-hsLitKey dflags (HsWordPrim    w) = mkMachWord dflags w
-hsLitKey _      (HsInt64Prim   i) = mkMachInt64  i
-hsLitKey _      (HsWord64Prim  w) = mkMachWord64 w
-hsLitKey _      (HsCharPrim    c) = MachChar   c
-hsLitKey _      (HsStringPrim  s) = MachStr    s
-hsLitKey _      (HsFloatPrim   f) = MachFloat  (fl_value f)
-hsLitKey _      (HsDoublePrim  d) = MachDouble (fl_value d)
-hsLitKey _      (HsString s)      = MachStr    (fastStringToByteString s)
-hsLitKey _      l                 = pprPanic "hsLitKey" (ppr l)
+warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
+warnAboutIdentities dflags (Var conv_fn) type_of_conv
+  | wopt Opt_WarnIdentities dflags
+  , idName conv_fn `elem` conversionNames
+  , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
+  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
+  = warnDs (vcat [ ptext (sLit "Call of") <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
+                 , nest 2 $ ptext (sLit "can probably be omitted")
+                 , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
+           ])
+warnAboutIdentities _ _ _ = return ()
+
+conversionNames :: [Name]
+conversionNames
+  = [ toIntegerName, toRationalName
+    , fromIntegralName, realToFracName ]
+ -- We can't easily add fromIntegerName, fromRationalName,
+ -- because they are generated by literals
+\end{code}
 
-hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
--- Ditto for HsOverLit; the boolean indicates to negate
-hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
+\begin{code}
+warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()
+warnAboutOverflowedLiterals dflags lit
+ | wopt Opt_WarnOverflowedLiterals dflags
+ , Just (i, tc) <- getIntegralLit lit
+ , let check :: forall a. (Bounded a, Integral a) => a -> DsM ()
+       check _proxy
+         = when (i < toInteger (minBound :: a) ||
+                 i > toInteger (maxBound :: a)) $
+           warnDs (ptext (sLit "Literal") <+> integer i <+>
+                   ptext (sLit "of type") <+> ppr tc <+>
+                   ptext (sLit "overflows"))
+  = if      tc == intTyConName    then check (undefined :: Int)
+    else if tc == int8TyConName   then check (undefined :: Int8)
+    else if tc == int16TyConName  then check (undefined :: Int16)
+    else if tc == int32TyConName  then check (undefined :: Int32)
+    else if tc == int64TyConName  then check (undefined :: Int64)
+    else if tc == wordTyConName   then check (undefined :: Word)
+    else if tc == word8TyConName  then check (undefined :: Word8)
+    else if tc == word16TyConName then check (undefined :: Word16)
+    else if tc == word32TyConName then check (undefined :: Word32)
+    else if tc == word64TyConName then check (undefined :: Word64)
+    else return ()
+
+  | otherwise = return ()
+\end{code}
 
-litValKey :: OverLitVal -> Bool -> Literal
-litValKey (HsIntegral i)   False = MachInt i
-litValKey (HsIntegral i)   True  = MachInt (-i)
-litValKey (HsFractional r) False = MachFloat (fl_value r)
-litValKey (HsFractional r) True  = MachFloat (negate (fl_value r))
-litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr (fastStringToByteString s)
+\begin{code}
+warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM ()
+-- Warns about [2,3 .. 1] which returns the empty list
+-- Only works for integral types, not floating point
+warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
+  | wopt Opt_WarnEmptyEnumerations dflags
+  , Just (from,tc) <- getLHsIntegralLit fromExpr
+  , Just mThn      <- traverse getLHsIntegralLit mThnExpr
+  , Just (to,_)    <- getLHsIntegralLit toExpr
+  , let check :: forall a. (Enum a, Num a) => a -> DsM ()
+        check _proxy
+          = when (null enumeration) $
+            warnDs (ptext (sLit "Enumeration is empty"))
+          where
+            enumeration :: [a]
+            enumeration = case mThn of
+                            Nothing      -> [fromInteger from                    .. fromInteger to]
+                            Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]
+
+  = if      tc == intTyConName    then check (undefined :: Int)
+    else if tc == int8TyConName   then check (undefined :: Int8)
+    else if tc == int16TyConName  then check (undefined :: Int16)
+    else if tc == int32TyConName  then check (undefined :: Int32)
+    else if tc == int64TyConName  then check (undefined :: Int64)
+    else if tc == wordTyConName   then check (undefined :: Word)
+    else if tc == word8TyConName  then check (undefined :: Word8)
+    else if tc == word16TyConName then check (undefined :: Word16)
+    else if tc == word32TyConName then check (undefined :: Word32)
+    else if tc == word64TyConName then check (undefined :: Word64)
+    else return ()
+
+  | otherwise = return ()
+
+getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name)
+getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit _ = Nothing
+
+getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name)
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty }) 
+  | Just tc <- tyConAppTyCon_maybe ty
+  = Just (i, tyConName tc)
+getIntegralLit _ = Nothing
 \end{code}
 
+
 %************************************************************************
 %*                                                                      *
         Tidying lit pats
@@ -263,8 +346,38 @@ matchLiterals (var:vars) ty sub_groups
     wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
 
 matchLiterals [] _ _ = panic "matchLiterals []"
-\end{code}
 
+---------------------------
+hsLitKey :: DynFlags -> HsLit -> Literal
+-- Get a Core literal to use (only) a grouping key
+-- Hence its type doesn't need to match the type of the original literal
+--      (and doesn't for strings)
+-- It only works for primitive types and strings;
+-- others have been removed by tidy
+hsLitKey dflags (HsIntPrim     i) = mkMachInt  dflags i
+hsLitKey dflags (HsWordPrim    w) = mkMachWord dflags w
+hsLitKey _      (HsInt64Prim   i) = mkMachInt64  i
+hsLitKey _      (HsWord64Prim  w) = mkMachWord64 w
+hsLitKey _      (HsCharPrim    c) = MachChar   c
+hsLitKey _      (HsStringPrim  s) = MachStr    s
+hsLitKey _      (HsFloatPrim   f) = MachFloat  (fl_value f)
+hsLitKey _      (HsDoublePrim  d) = MachDouble (fl_value d)
+hsLitKey _      (HsString s)      = MachStr    (fastStringToByteString s)
+hsLitKey _      l                 = pprPanic "hsLitKey" (ppr l)
+
+---------------------------
+hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal
+-- Ditto for HsOverLit; the boolean indicates to negate
+hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
+
+---------------------------
+litValKey :: OverLitVal -> Bool -> Literal
+litValKey (HsIntegral i)   False = MachInt i
+litValKey (HsIntegral i)   True  = MachInt (-i)
+litValKey (HsFractional r) False = MachFloat (fl_value r)
+litValKey (HsFractional r) True  = MachFloat (negate (fl_value r))
+litValKey (HsIsString s)   neg   = ASSERT( not neg) MachStr (fastStringToByteString s)
+\end{code}
 
 %************************************************************************
 %*                                                                      *