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!

compiler/deSugar/DsExpr.lhs

@@ -48,21 +48,14 @@ import VarEnv
 import DataCon
 import TysWiredIn
 import BasicTypes
-import PrelNames
 import Maybes
 import SrcLoc
 import Util
 import Bag
 import Outputable
-import Literal
-import TyCon
 import FastString
 
 import Control.Monad
-import Data.Int
-import Data.Traversable (traverse)
-import Data.Typeable (typeOf)
-import Data.Word
 \end{code}
 
 
@@ -201,8 +194,8 @@ dsExpr (HsOverLit lit)        = dsOverLit lit
 dsExpr (HsWrap co_fn e)
   = do { e' <- dsExpr e
        ; wrapped_e <- dsHsWrapper co_fn e'
-       ; warn_id <- woptM Opt_WarnIdentities
-       ; when warn_id $ warnAboutIdentities e' wrapped_e
+       ; dflags <- getDynFlags
+       ; warnAboutIdentities dflags e' (exprType wrapped_e)
        ; return wrapped_e }
 
 dsExpr (NegApp expr neg_expr) 
@@ -217,10 +210,7 @@ dsExpr (HsLamCase arg matches)
        ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
 
 dsExpr (HsApp fun arg)
-  = do ds <- mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
-       warn_overflowed_literals <- woptM Opt_WarnOverflowedLiterals
-       when warn_overflowed_literals $ warnAboutOverflowedLiterals ds
-       return ds
+  = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
 
 dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
 \end{code}
@@ -719,23 +709,21 @@ dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
 dsArithSeq expr (From from)
   = App <$> dsExpr expr <*> dsLExpr from
 dsArithSeq expr (FromTo from to)
-  = do expr' <- dsExpr expr
+  = do dflags <- getDynFlags
+       warnAboutEmptyEnumerations dflags from Nothing to
+       expr' <- dsExpr expr
        from' <- dsLExpr from
        to'   <- dsLExpr to
-       warn_empty_enumerations <- woptM Opt_WarnEmptyEnumerations
-       when warn_empty_enumerations $
-           warnAboutEmptyEnumerations from' Nothing to'
        return $ mkApps expr' [from', to']
 dsArithSeq expr (FromThen from thn)
   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
 dsArithSeq expr (FromThenTo from thn to)
-  = do expr' <- dsExpr expr
+  = do dflags <- getDynFlags
+       warnAboutEmptyEnumerations dflags from (Just thn) to
+       expr' <- dsExpr expr
        from' <- dsLExpr from
        thn'  <- dsLExpr thn
        to'   <- dsLExpr to
-       warn_empty_enumerations <- woptM Opt_WarnEmptyEnumerations
-       when warn_empty_enumerations $
-           warnAboutEmptyEnumerations from' (Just thn') to'
        return $ mkApps expr' [from', thn', to']
 \end{code}
 
@@ -825,103 +813,6 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
 \end{code}
 
 
-%************************************************************************
-%*                                                                      *
-                 Warnings
-%*                                                                      *
-%************************************************************************
-
-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}
-warnAboutIdentities :: CoreExpr -> CoreExpr -> DsM ()
-warnAboutIdentities (Var v) wrapped_fun
-  | idName v `elem` conversionNames
-  , let fun_ty = exprType wrapped_fun
-  , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
-  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
-  = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
-                 , 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}
-
-\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}
-
-\begin{code}
-warnAboutEmptyEnumerations :: CoreExpr -> Maybe CoreExpr -> CoreExpr -> DsM ()
-warnAboutEmptyEnumerations fromExpr mThnExpr toExpr
- | Just from <- getVal fromExpr
- , Just mThn <- traverse getVal mThnExpr
- , Just to   <- getVal toExpr
- , Just t    <- getType fromExpr
-    = let check proxy
-              = let enumeration
-                        = case mThn of
-                          Nothing  -> [(fromInteger from `asTypeOf` proxy) .. fromInteger to]
-                          Just thn -> [fromInteger from, fromInteger thn   .. fromInteger to]
-                in when (null enumeration) $
-                       warnDs (ptext (sLit "Enumeration is empty"))
-
-      in if t == intTyConName    then check (undefined :: Int)
-    else if t == int8TyConName   then check (undefined :: Int8)
-    else if t == int16TyConName  then check (undefined :: Int16)
-    else if t == int32TyConName  then check (undefined :: Int32)
-    else if t == int64TyConName  then check (undefined :: Int64)
-    else if t == wordTyConName   then check (undefined :: Word)
-    else if t == word8TyConName  then check (undefined :: Word8)
-    else if t == word16TyConName then check (undefined :: Word16)
-    else if t == word32TyConName then check (undefined :: Word32)
-    else if t == word64TyConName then check (undefined :: Word64)
-    else return ()
-
-    where getVal (App (App (App (Var f) (Type _)) _) (Lit (LitInteger i _)))
-           | idName f == fromIntegerName = Just i
-          getVal _ = Nothing
-
-          getType (App (App (App (Var f) (Type t)) _) (Lit (LitInteger _ _)))
-           | idName f == fromIntegerName,
-             Just tc <- tyConAppTyCon_maybe t = Just (tyConName tc)
-          getType _ = Nothing
-
-warnAboutEmptyEnumerations _ _ _ = return ()
-\end{code}
-
 %************************************************************************
 %*                                                                      *
 \subsection{Errors and contexts}

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}
 
 %************************************************************************
 %*                                                                      *