path: root/compiler/typecheck/TcWarnings.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

-- | Warnings generated after or while type-checking.
module TcWarnings (
    -- * Warnings involving literals
    warnAboutIdentities,
    warnAboutOverflowedOverLit, warnAboutOverflowedLit,
    warnAboutEmptyEnumerations,

    -- * Discarded do bindings
    warnDiscardedDoBindings
  ) where

import GhcPrelude

import TcRnMonad
import HsSyn

import Id
import TyCon
import Name
import Type
import TcType
import FamInst (tcGetFamInstEnvs)
import FamInstEnv (topNormaliseType)
import Coercion
import TcEvidence
import PrelNames
import TysWiredIn
import TysPrim
import SrcLoc
import Outputable
import BasicTypes
import DynFlags
import FastString
import qualified GHC.LanguageExtensions as LangExt

import Control.Monad (when)
import Data.Bifunctor (first)
import Data.Int
import Data.Word
import Data.Proxy

-- | 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
warnAboutIdentities :: DynFlags -> HsExpr GhcTcId -> HsWrapper -> TcM ()
warnAboutIdentities dflags (HsVar _ (dL->L _ conv_fn)) wrap
  | wopt Opt_WarnIdentities dflags
  , idName conv_fn `elem` conversionNames
  , is_refl wrap
  = warnTc (Reason Opt_WarnIdentities)
           True
           (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr (idType conv_fn)
                 , nest 2 $ text "can probably be omitted"
           ])
  where
    is_refl wrap
      | isIdHsWrapper wrap                  = True
      | WpCast co <- wrap, isReflexiveCo co = True
      | otherwise                           = False
warnAboutIdentities _ _ _ = return ()

conversionNames :: [Name]
conversionNames
  = [ toIntegerName, toRationalName
    , fromIntegralName, realToFracName ]
 -- We can't easily add fromIntegerName, fromRationalName,
 -- because they are generated by literals


-- | Emit warnings on overloaded integral literals which overflow the bounds
-- implied by their type.
warnAboutOverflowedOverLit :: Bool -> HsOverLit GhcTc -> TcM ()
warnAboutOverflowedOverLit is_neg hsOverLit = do
  dflags <- getDynFlags
  let lit = first (if is_neg then negate else id) <$> getIntegralLit hsOverLit
  warnAboutOverflowedLiterals dflags lit

-- | Emit warnings on integral literals which overflow the boudns implied by
-- their type.
warnAboutOverflowedLit :: HsLit GhcTc -> TcM ()
warnAboutOverflowedLit hsLit = do
  dflags <- getDynFlags
  warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit)

-- | Emit warnings on integral literals which overflow the bounds implied by
-- their type.
warnAboutOverflowedLiterals
  :: DynFlags
  -> Maybe (Integer, Name)  -- ^ the literal value and name of its tycon
  -> TcM ()
warnAboutOverflowedLiterals dflags lit
 | wopt Opt_WarnOverflowedLiterals dflags
 , Just (i, tc) <- lit
 =  if      tc == intTyConName     then check i tc (Proxy :: Proxy Int)

    -- These only show up via the 'HsOverLit' route
    else if tc == int8TyConName    then check i tc (Proxy :: Proxy Int8)
    else if tc == int16TyConName   then check i tc (Proxy :: Proxy Int16)
    else if tc == int32TyConName   then check i tc (Proxy :: Proxy Int32)
    else if tc == int64TyConName   then check i tc (Proxy :: Proxy Int64)
    else if tc == wordTyConName    then check i tc (Proxy :: Proxy Word)
    else if tc == word8TyConName   then check i tc (Proxy :: Proxy Word8)
    else if tc == word16TyConName  then check i tc (Proxy :: Proxy Word16)
    else if tc == word32TyConName  then check i tc (Proxy :: Proxy Word32)
    else if tc == word64TyConName  then check i tc (Proxy :: Proxy Word64)
    else if tc == naturalTyConName then checkPositive i tc

    -- These only show up via the 'HsLit' route
    else if tc == intPrimTyConName    then check i tc (Proxy :: Proxy Int)
    else if tc == int8PrimTyConName   then check i tc (Proxy :: Proxy Int8)
    else if tc == int32PrimTyConName  then check i tc (Proxy :: Proxy Int32)
    else if tc == int64PrimTyConName  then check i tc (Proxy :: Proxy Int64)
    else if tc == wordPrimTyConName   then check i tc (Proxy :: Proxy Word)
    else if tc == word8PrimTyConName  then check i tc (Proxy :: Proxy Word8)
    else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32)
    else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64)

    else return ()

  | otherwise = return ()
  where

    checkPositive :: Integer -> Name -> TcM ()
    checkPositive i tc
      = when (i < 0) $ do
        warnTc (Reason Opt_WarnOverflowedLiterals)
               True
               (vcat [ text "Literal" <+> integer i
                       <+> text "is negative but" <+> ppr tc
                       <+> ptext (sLit "only supports positive numbers")
                     ])

    check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> TcM ()
    check i tc _proxy
      = when (i < minB || i > maxB) $ do
        warnTc (Reason Opt_WarnOverflowedLiterals)
               True
               (vcat [ text "Literal" <+> integer i
                       <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
                       <+> integer minB <> text ".." <> integer maxB
                     , sug ])
      where
        minB = toInteger (minBound :: a)
        maxB = toInteger (maxBound :: a)
        sug | minB == -i   -- Note [Suggest NegativeLiterals]
            , i > 0
            , not (xopt LangExt.NegativeLiterals dflags)
            = text "If you are trying to write a large negative literal, use NegativeLiterals"
            | otherwise = Outputable.empty

{-
Note [Suggest NegativeLiterals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you write
  x :: Int8
  x = -128
it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.
We get an erroneous suggestion for
  x = 128
but perhaps that does not matter too much.
-}

warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
                           -> LHsExpr GhcTc -> TcM ()
-- ^ 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) => Proxy a -> TcM ()
        check _proxy
          = when (null enumeration) $
            warnTc (Reason Opt_WarnEmptyEnumerations)
                   True
                   (text "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 (Proxy :: Proxy Int)
    else if tc == int8TyConName   then check (Proxy :: Proxy Int8)
    else if tc == int16TyConName  then check (Proxy :: Proxy Int16)
    else if tc == int32TyConName  then check (Proxy :: Proxy Int32)
    else if tc == int64TyConName  then check (Proxy :: Proxy Int64)
    else if tc == wordTyConName   then check (Proxy :: Proxy Word)
    else if tc == word8TyConName  then check (Proxy :: Proxy Word8)
    else if tc == word16TyConName then check (Proxy :: Proxy Word16)
    else if tc == word32TyConName then check (Proxy :: Proxy Word32)
    else if tc == word64TyConName then check (Proxy :: Proxy Word64)
    else if tc == integerTyConName then check (Proxy :: Proxy Integer)
    else if tc == naturalTyConName then check (Proxy :: Proxy Integer)
      -- We use 'Integer' because otherwise a negative 'Natural' literal
      -- could cause a compile time crash (instead of a runtime one).
      -- See the T10930b test case for an example of where this matters.
    else return ()

  | otherwise = return ()

getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
-- ^ See if the expression is an 'Integral' literal.
-- Remember to look through automatically-added tick-boxes! (#8384)
getLHsIntegralLit (dL->L _ (HsPar _ e))            = getLHsIntegralLit e
getLHsIntegralLit (dL->L _ (HsTick _ _ e))         = getLHsIntegralLit e
getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e))    = getLHsIntegralLit e
getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
getLHsIntegralLit (dL->L _ (HsLit _ lit))          = getSimpleIntegralLit lit
getLHsIntegralLit _ = Nothing

-- | If 'Integral', extract the value and type name of the overloaded literal.
getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
  | Just tc <- tyConAppTyCon_maybe ty
  = Just (il_value i, tyConName tc)
getIntegralLit _ = Nothing

-- | If 'Integral', extract the value and type name of the non-overloaded
-- literal.
getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)
getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName)
getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName)
getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName)
getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName)
getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName)
getSimpleIntegralLit (HsInteger _ i ty)
  | Just tc <- tyConAppTyCon_maybe ty
  = Just (i, tyConName tc)
getSimpleIntegralLit _ = Nothing

-- | Warn about certain types of values discarded in monadic bindings (#3263).
--
-- Called on the RHS of a 'BodyStmt'.
-- @rhs@ is instantiated to @'LHsExpr' 'GhcTc'@ or @'LHsCmd' 'GhcTc'@.
warnDiscardedDoBindings :: Outputable rhs => rhs -> Type -> TcM ()
warnDiscardedDoBindings rhs rhs_ty
  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
  = do { warn_unused <- woptM Opt_WarnUnusedDoBind
       ; warn_wrong <- woptM Opt_WarnWrongDoBind
       ; when (warn_unused || warn_wrong) $
    do { fam_inst_envs <- tcGetFamInstEnvs
       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty

           -- Warn about discarding non-() things in 'monadic' binding
       ; if warn_unused && not (isUnitTy norm_elt_ty)
         then warnTc (Reason Opt_WarnUnusedDoBind)
                     True
                     (badMonadBind rhs elt_ty)
         else

           -- Warn about discarding m a things in 'monadic' binding of the same type,
           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
           when warn_wrong $
                do { case tcSplitAppTy_maybe norm_elt_ty of
                         Just (elt_m_ty, _)
                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
                            -> warnTc (Reason Opt_WarnWrongDoBind)
                                      True
                                      (badMonadBind rhs elt_ty)
                         _ -> return () } } }

  | otherwise   -- RHS does have type of form (m ty), which is weird
  = return ()   -- but at lesat this warning is irrelevant

badMonadBind :: Outputable rhs => rhs -> Type -> SDoc
badMonadBind rhs elt_ty
  = vcat [ hang (text "A do-notation statement discarded a result of type")
              2 (quotes (ppr elt_ty))
         , hang (text "Suppress this warning by saying")
              2 (quotes $ text "_ <-" <+> ppr rhs)
         ]