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, 9 insertions, 118 deletions

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 6945cf38e0..3a8815a603 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/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}
 
@@ -827,103 +815,6 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
 
 %************************************************************************
 %*                                                                      *
-                 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}
 %*                                                                      *
 %************************************************************************