{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


Pattern-matching literal patterns
-}

module GHC.HsToCore.Match.Literal
   ( dsLit, dsOverLit, hsLitKey
   , tidyLitPat, tidyNPat
   , matchLiterals, matchNPlusKPats, matchNPats
   , warnAboutIdentities
   , warnAboutOverflowedOverLit, warnAboutOverflowedLit
   , warnAboutEmptyEnumerations
   )
where

import GHC.Prelude
import GHC.Platform

import {-# SOURCE #-} GHC.HsToCore.Match ( match )
import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsExpr, dsSyntaxExpr )

import GHC.HsToCore.Errors.Types
import GHC.HsToCore.Monad
import GHC.HsToCore.Utils

import GHC.Hs

import GHC.Tc.Utils.TcMType ( shortCutLit )
import GHC.Tc.Utils.TcType

import GHC.Core
import GHC.Core.Make
import GHC.Core.TyCon
import GHC.Core.Reduction ( Reduction(..) )
import GHC.Core.DataCon
import GHC.Core.Type
import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )

import GHC.Types.Name
import GHC.Types.Literal
import GHC.Types.SrcLoc

import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim

import GHC.Types.Id
import GHC.Types.SourceText

import GHC.Driver.DynFlags

import GHC.Utils.Outputable as Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Unique (sameUnique)

import GHC.Data.FastString

import Control.Monad
import Data.Int
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NEL
import Data.Word
import GHC.Real ( Ratio(..), numerator, denominator )

{-
************************************************************************
*                                                                      *
                Desugaring literals
 [used to be in GHC.HsToCore.Expr, but GHC.HsToCore.Quote needs it,
  and it's nice to avoid a loop]
*                                                                      *
************************************************************************

We give int/float literals type @Integer@ and @Rational@, respectively.
The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
around them.

ToDo: put in range checks for when converting ``@i@''
(or should that be in the typechecker?)

For numeric literals, we try to detect there use at a standard type
(@Int@, @Float@, etc.) are directly put in the right constructor.
[NB: down with the @App@ conversion.]

See also below where we look for @DictApps@ for \tr{plusInt}, etc.
-}

dsLit :: HsLit GhcRn -> DsM CoreExpr
dsLit :: HsLit GhcRn -> DsM CoreExpr
dsLit HsLit GhcRn
l = do
  DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
  case HsLit GhcRn
l of
    HsStringPrim XHsStringPrim GhcRn
_ ByteString
s -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString ByteString
s))
    HsCharPrim   XHsCharPrim GhcRn
_ Char
c -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Char -> Literal
LitChar Char
c))
    HsIntPrim    XHsIntPrim GhcRn
_ Integer
i -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitIntWrap Platform
platform Integer
i))
    HsWordPrim   XHsWordPrim GhcRn
_ Integer
w -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitWordWrap Platform
platform Integer
w))
    HsInt8Prim   XHsInt8Prim GhcRn
_ Integer
i -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInt8Wrap Integer
i))
    HsInt16Prim  XHsInt16Prim GhcRn
_ Integer
i -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInt16Wrap Integer
i))
    HsInt32Prim  XHsInt32Prim GhcRn
_ Integer
i -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInt32Wrap Integer
i))
    HsInt64Prim  XHsInt64Prim GhcRn
_ Integer
i -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInt64Wrap Integer
i))
    HsWord8Prim  XHsWord8Prim GhcRn
_ Integer
w -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitWord8Wrap Integer
w))
    HsWord16Prim XHsWord16Prim GhcRn
_ Integer
w -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitWord16Wrap Integer
w))
    HsWord32Prim XHsWord32Prim GhcRn
_ Integer
w -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitWord32Wrap Integer
w))
    HsWord64Prim XHsWord64Prim GhcRn
_ Integer
w -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitWord64Wrap Integer
w))

    -- This can be slow for very large literals. See Note [FractionalLit representation]
    -- and #15646
    HsFloatPrim  XHsFloatPrim GhcRn
_ FractionalLit
fl -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Rational -> Literal
LitFloat (FractionalLit -> Rational
rationalFromFractionalLit FractionalLit
fl)))
    HsDoublePrim XHsDoublePrim GhcRn
_ FractionalLit
fl -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Rational -> Literal
LitDouble (FractionalLit -> Rational
rationalFromFractionalLit FractionalLit
fl)))
    HsChar XHsChar GhcRn
_ Char
c       -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> CoreExpr
mkCharExpr Char
c)
    HsString XHsString GhcRn
_ FastString
str   -> FastString -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS FastString
str
    HsInteger XHsInteger GhcRn
_ Integer
i Type
_  -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform Integer
i)
    HsInt XHsInt GhcRn
_ IntegralLit
i        -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> Integer -> CoreExpr
mkIntExpr Platform
platform (IntegralLit -> Integer
il_value IntegralLit
i))
    HsRat XHsRat GhcRn
_ FractionalLit
fl Type
ty    -> FractionalLit -> Type -> DsM CoreExpr
dsFractionalLitToRational FractionalLit
fl Type
ty

{-
Note [FractionalLit representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There is a fun wrinkle to this, we used to simply compute the value
for these literals and store it as `Rational`. While this might seem
reasonable it meant typechecking literals of extremely large numbers
wasn't possible. This happened for example in #15646.

There a user would write in GHCi e.g. `:t 1e1234111111111111111111111`
which would trip up the compiler. The reason being we would parse it as
<Literal of value n>. Try to compute n, which would run out of memory
for truly large numbers, or take far too long for merely large ones.

To fix this we instead now store the significand and exponent of the
literal instead. Depending on the size of the exponent we then defer
the computation of the Rational value, potentially up to runtime of the
program! There are still cases left were we might compute large rationals
but it's a lot rarer then.

The current state of affairs for large literals is:
* Typechecking: Will produce a FractionalLit
* Desugaring a large overloaded literal to Float/Double *is* done
  at compile time. So can still fail. But this only matters for values too large
  to be represented as float anyway.
* Converting overloaded literals to a value of *Rational* is done at *runtime*.
  If such a value is then demanded at runtime the program might hang or run out of
  memory. But that is perhaps expected and acceptable.
* TH might also evaluate the literal even when overloaded.
  But there a user should be able to work around #15646 by
  generating a call to `mkRationalBase10/2` for large literals instead.


Note [FractionalLit representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For fractional literals, like 1.3 or 0.79e22, we do /not/ represent
them within the compiler as a Rational.  Doing so would force the
compiler to compute a huge Rational for 2.3e300000000000, at compile
time (#15646)!

So instead we represent fractional literals as a FractionalLit,
in which we record the significand and exponent separately.  Then
we can compute the huge Rational at /runtime/, by emitting code
for
       mkRationalBase10 2.3 300000000000

where mkRationalBase10 is defined in the library GHC.Real

The moving parts are here:

* Parsing, renaming, typechecking: use FractionalLit, in which the
  significand and exponent are represented separately.

* Desugaring.  Remember that a fractional literal like 54.4e20 has type
     Fractional a => a

  - For fractional literals whose type turns out to be Float/Double,
    we desugar to a Float/Double literal at /compile time/.
    This conversion can still fail. But this only matters for values
    too large to be represented as float anyway.  See dsLit in
    GHC.HsToCore.Match.Literal

  - For fractional literals whose type turns out to be Rational, we
    desugar the literal to a call of `mkRationalBase10` (etc for hex
    literals), so that we only compute the Rational at /run time/.  If
    this value is then demanded at runtime the program might hang or
    run out of memory. But that is perhaps expected and acceptable.
    See dsFractionalLitToRational in GHC.HsToCore.Match.Literal

  - For fractional literals whose type isn't one of the above, we just
    call the typeclass method `fromRational`.  But to do that we need
    the rational to give to it, and we compute that at runtime, as
    above.

* Template Haskell definitions are also problematic. While the TH code
  works as expected once it's spliced into a program it will compute the
  value of the large literal.
  But there a user should be able to work around #15646
  by having their TH code generating a call to `mkRationalBase[10/2]` for
  large literals  instead.

-}

-- | See Note [FractionalLit representation]
dsFractionalLitToRational :: FractionalLit -> Type -> DsM CoreExpr
dsFractionalLitToRational :: FractionalLit -> Type -> DsM CoreExpr
dsFractionalLitToRational fl :: FractionalLit
fl@FL{ fl_signi :: FractionalLit -> Rational
fl_signi = Rational
signi, fl_exp :: FractionalLit -> Integer
fl_exp = Integer
exp, fl_exp_base :: FractionalLit -> FractionalExponentBase
fl_exp_base = FractionalExponentBase
base } Type
ty
  -- We compute "small" rationals here and now
  | Integer -> Integer
forall a. Num a => a -> a
abs Integer
exp Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
100
  = do
    Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform)
-> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
-> IOEnv (Env DsGblEnv DsLclEnv) Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let !val :: Rational
val   = FractionalLit -> Rational
rationalFromFractionalLit FractionalLit
fl
        !num :: CoreExpr
num   = Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
val)
        !denom :: CoreExpr
denom = Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
val)
        (DataCon
ratio_data_con, Type
integer_ty)
            = case Type -> (TyCon, [Type])
tcSplitTyConApp Type
ty of
                    (TyCon
tycon, [Type
i_ty]) -> Bool -> (DataCon, Type) -> (DataCon, Type)
forall a. HasCallStack => Bool -> a -> a
assert (Type -> Bool
isIntegerTy Type
i_ty Bool -> Bool -> Bool
&& TyCon
tycon TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
ratioTyConKey)
                                       ([DataCon] -> DataCon
forall a. HasCallStack => [a] -> a
head (TyCon -> [DataCon]
tyConDataCons TyCon
tycon), Type
i_ty)
                    (TyCon, [Type])
x -> String -> SDoc -> (DataCon, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsLit" ((TyCon, [Type]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon, [Type])
x)
    CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$! (DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
ratio_data_con [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
integer_ty, CoreExpr
num, CoreExpr
denom])
  -- Large rationals will be computed at runtime.
  | Bool
otherwise
  = do
      let mkRationalName :: Name
mkRationalName = case FractionalExponentBase
base of
                             FractionalExponentBase
Base2 -> Name
mkRationalBase2Name
                             FractionalExponentBase
Base10 -> Name
mkRationalBase10Name
      Id
mkRational <- Name -> DsM Id
dsLookupGlobalId Name
mkRationalName
      CoreExpr
litR <- Rational -> DsM CoreExpr
dsRational Rational
signi
      Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform)
-> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
-> IOEnv (Env DsGblEnv DsLclEnv) Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      let litE :: CoreExpr
litE = Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform Integer
exp
      CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
mkRational) [CoreExpr
litR, CoreExpr
litE])

dsRational :: Rational -> DsM CoreExpr
dsRational :: Rational -> DsM CoreExpr
dsRational (Integer
n :% Integer
d) = do
  Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform)
-> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
-> IOEnv (Env DsGblEnv DsLclEnv) Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  DataCon
dcn <- Name -> DsM DataCon
dsLookupDataCon Name
ratioDataConName
  let cn :: CoreExpr
cn = Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform Integer
n
  let dn :: CoreExpr
dn = Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform Integer
d
  CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
dcn [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
integerTy, CoreExpr
cn, CoreExpr
dn]


dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
-- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
-- (an expression for) the literal value itself.
dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
dsOverLit (OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = OverLitVal
val, ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = OverLitTc Bool
rebindable HsExpr GhcTc
witness Type
ty }) = do
  DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
  case Platform -> OverLitVal -> Type -> Maybe (HsExpr GhcTc)
shortCutLit Platform
platform OverLitVal
val Type
ty of
    Just HsExpr GhcTc
expr | Bool -> Bool
not Bool
rebindable -> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr        -- Note [Literal short cut]
    Maybe (HsExpr GhcTc)
_                          -> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
witness

{-
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
The type checker tries to do this short-cutting as early as possible, but
because of unification etc, more information is available to the desugarer.
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
-}

warnAboutIdentities :: DynFlags -> Id -> Type -> DsM ()
warnAboutIdentities :: DynFlags -> Id -> Type -> DsM ()
warnAboutIdentities DynFlags
dflags Id
conv_fn Type
type_of_conv
  | WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnIdentities DynFlags
dflags
  , Id -> Name
idName Id
conv_fn Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
conversionNames
  , Just (FunTyFlag
_, Type
_, Type
arg_ty, Type
res_ty) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
type_of_conv
  , Type
arg_ty Type -> Type -> Bool
`eqType` Type
res_ty  -- So we are converting  ty -> ty
  = DsMessage -> DsM ()
diagnosticDs (Id -> Type -> DsMessage
DsIdentitiesFound Id
conv_fn Type
type_of_conv)
warnAboutIdentities DynFlags
_ Id
_ Type
_ = () -> DsM ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

conversionNames :: [Name]
conversionNames :: [Name]
conversionNames
  = [ Name
toIntegerName, Name
toRationalName
    , Name
fromIntegralName, Name
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 :: HsOverLit GhcTc -> DsM ()
warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
warnAboutOverflowedOverLit HsOverLit GhcTc
hsOverLit = do
  DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  FamInstEnvs
fam_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
  DynFlags -> Maybe (Integer, Name) -> DsM ()
warnAboutOverflowedLiterals DynFlags
dflags (Maybe (Integer, Name) -> DsM ())
-> Maybe (Integer, Name) -> DsM ()
forall a b. (a -> b) -> a -> b
$
      HsOverLit GhcTc -> Maybe (Integer, Type)
getIntegralLit HsOverLit GhcTc
hsOverLit Maybe (Integer, Type)
-> ((Integer, Type) -> Maybe (Integer, Name))
-> Maybe (Integer, Name)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)
getNormalisedTyconName FamInstEnvs
fam_envs

-- | Emit warnings on integral literals which overflow the bounds implied by
-- their type.
warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
warnAboutOverflowedLit HsLit GhcTc
hsLit = do
  DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  DynFlags -> Maybe (Integer, Name) -> DsM ()
warnAboutOverflowedLiterals DynFlags
dflags (Maybe (Integer, Name) -> DsM ())
-> Maybe (Integer, Name) -> DsM ()
forall a b. (a -> b) -> a -> b
$
      HsLit GhcTc -> Maybe (Integer, Type)
getSimpleIntegralLit HsLit GhcTc
hsLit Maybe (Integer, Type)
-> ((Integer, Type) -> Maybe (Integer, Name))
-> Maybe (Integer, Name)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Integer, Type) -> Maybe (Integer, Name)
getTyconName

-- | 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
  -> DsM ()
warnAboutOverflowedLiterals :: DynFlags -> Maybe (Integer, Name) -> DsM ()
warnAboutOverflowedLiterals DynFlags
dflags Maybe (Integer, Name)
lit
 | WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnOverflowedLiterals DynFlags
dflags
 , Just (Integer
i, Name
tc) <- Maybe (Integer, Name)
lit
 = if
    -- These only show up via the 'HsOverLit' route
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
intTyConName        -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc Integer
minInt         Integer
maxInt
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
wordTyConName       -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc Integer
minWord        Integer
maxWord
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int8TyConName       -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Int8)   (forall a. (Integral a, Bounded a) => Integer
max' @Int8)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int16TyConName      -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Int16)  (forall a. (Integral a, Bounded a) => Integer
max' @Int16)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int32TyConName      -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Int32)  (forall a. (Integral a, Bounded a) => Integer
max' @Int32)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int64TyConName      -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Int64)  (forall a. (Integral a, Bounded a) => Integer
max' @Int64)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word8TyConName      -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Word8)  (forall a. (Integral a, Bounded a) => Integer
max' @Word8)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word16TyConName     -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Word16) (forall a. (Integral a, Bounded a) => Integer
max' @Word16)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word32TyConName     -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Word32) (forall a. (Integral a, Bounded a) => Integer
max' @Word32)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word64TyConName     -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Word64) (forall a. (Integral a, Bounded a) => Integer
max' @Word64)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
naturalTyConName    -> Integer -> Name -> DsM ()
checkPositive Integer
i Name
tc

    -- These only show up via the 'HsLit' route
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
intPrimTyConName    -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc Integer
minInt         Integer
maxInt
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
wordPrimTyConName   -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc Integer
minWord        Integer
maxWord
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int8PrimTyConName   -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Int8)   (forall a. (Integral a, Bounded a) => Integer
max' @Int8)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int16PrimTyConName  -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Int16)  (forall a. (Integral a, Bounded a) => Integer
max' @Int16)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int32PrimTyConName  -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Int32)  (forall a. (Integral a, Bounded a) => Integer
max' @Int32)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int64PrimTyConName  -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Int64)  (forall a. (Integral a, Bounded a) => Integer
max' @Int64)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word8PrimTyConName  -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Word8)  (forall a. (Integral a, Bounded a) => Integer
max' @Word8)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word16PrimTyConName -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Word16) (forall a. (Integral a, Bounded a) => Integer
max' @Word16)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word32PrimTyConName -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Word32) (forall a. (Integral a, Bounded a) => Integer
max' @Word32)
    | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word64PrimTyConName -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc (forall a. (Integral a, Bounded a) => Integer
min' @Word64) (forall a. (Integral a, Bounded a) => Integer
max' @Word64)

    | Bool
otherwise -> () -> DsM ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  | Bool
otherwise = () -> DsM ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    -- use target Int/Word sizes! See #17336
    platform :: Platform
platform          = DynFlags -> Platform
targetPlatform DynFlags
dflags
    (Integer
minInt,Integer
maxInt)   = (Platform -> Integer
platformMinInt Platform
platform, Platform -> Integer
platformMaxInt Platform
platform)
    (Integer
minWord,Integer
maxWord) = (Integer
0,                       Platform -> Integer
platformMaxWord Platform
platform)

    min' :: forall a. (Integral a, Bounded a) => Integer
    min' :: forall a. (Integral a, Bounded a) => Integer
min' = a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
forall a. Bounded a => a
minBound :: a)

    max' :: forall a. (Integral a, Bounded a) => Integer
    max' :: forall a. (Integral a, Bounded a) => Integer
max' = a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
forall a. Bounded a => a
maxBound :: a)

    checkPositive :: Integer -> Name -> DsM ()
    checkPositive :: Integer -> Name -> DsM ()
checkPositive Integer
i Name
tc
      = Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (DsM () -> DsM ()) -> DsM () -> DsM ()
forall a b. (a -> b) -> a -> b
$
        DsMessage -> DsM ()
diagnosticDs (Integer
-> Name
-> Maybe (MinBound, MaxBound)
-> NegLiteralExtEnabled
-> DsMessage
DsOverflowedLiterals Integer
i Name
tc Maybe (MinBound, MaxBound)
forall a. Maybe a
Nothing (DynFlags -> NegLiteralExtEnabled
negLiteralExtEnabled DynFlags
dflags))

    check :: Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc Integer
minB Integer
maxB
      = Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
minB Bool -> Bool -> Bool
|| Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
maxB) (DsM () -> DsM ()) -> DsM () -> DsM ()
forall a b. (a -> b) -> a -> b
$
        DsMessage -> DsM ()
diagnosticDs (Integer
-> Name
-> Maybe (MinBound, MaxBound)
-> NegLiteralExtEnabled
-> DsMessage
DsOverflowedLiterals Integer
i Name
tc Maybe (MinBound, MaxBound)
bounds (DynFlags -> NegLiteralExtEnabled
negLiteralExtEnabled DynFlags
dflags))
      where
        bounds :: Maybe (MinBound, MaxBound)
bounds = (MinBound, MaxBound) -> Maybe (MinBound, MaxBound)
forall a. a -> Maybe a
Just (Integer -> MinBound
MinBound Integer
minB, Integer -> MaxBound
MaxBound Integer
maxB)

warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc
                           -> Maybe (LHsExpr GhcTc)
                           -> LHsExpr GhcTc -> DsM ()
-- ^ Warns about @[2,3 .. 1]@ or @['b' .. 'a']@ which return the empty list.
-- For numeric literals, only works for integral types, not floating point.
warnAboutEmptyEnumerations :: FamInstEnvs
-> DynFlags
-> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> DsM ()
warnAboutEmptyEnumerations FamInstEnvs
fam_envs DynFlags
dflags LHsExpr GhcTc
fromExpr Maybe (LHsExpr GhcTc)
mThnExpr LHsExpr GhcTc
toExpr
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnEmptyEnumerations DynFlags
dflags
  = () -> DsM ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  -- Numeric Literals
  | Just from_ty :: (Integer, Type)
from_ty@(Integer
from',Type
_) <- LHsExpr GhcTc -> Maybe (Integer, Type)
getLHsIntegralLit LHsExpr GhcTc
fromExpr
  , Just (Integer
_, Name
tc)           <- FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)
getNormalisedTyconName FamInstEnvs
fam_envs (Integer, Type)
from_ty
  , Just Maybe (Integer, Type)
mThn'             <- (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> Maybe (Integer, Type))
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> Maybe (Maybe (Integer, Type))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse LHsExpr GhcTc -> Maybe (Integer, Type)
GenLocated SrcSpanAnnA (HsExpr GhcTc) -> Maybe (Integer, Type)
getLHsIntegralLit Maybe (LHsExpr GhcTc)
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mThnExpr
  , Just (Integer
to',Type
_)           <- LHsExpr GhcTc -> Maybe (Integer, Type)
getLHsIntegralLit LHsExpr GhcTc
toExpr
  = do
      let
        check :: forall a. (Integral a, Num a) => DsM ()
        check :: forall a. (Integral a, Num a) => DsM ()
check = Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Integer] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Integer]
enumeration) DsM ()
raiseWarning
          where
            enumeration :: [Integer]
enumeration = case Maybe Integer
mThn of
              Maybe Integer
Nothing  -> [Integer
from      .. Integer
to]
              Just Integer
thn -> [Integer
from, Integer
thn .. Integer
to]
            wrap :: forall a. (Integral a, Num a) => Integer -> Integer
            wrap :: forall a. (Integral a, Num a) => Integer -> Integer
wrap Integer
i = a -> Integer
forall a. Integral a => a -> Integer
toInteger (Integer -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: a)
            from :: Integer
from = forall a. (Integral a, Num a) => Integer -> Integer
wrap @a Integer
from'
            to :: Integer
to   = forall a. (Integral a, Num a) => Integer -> Integer
wrap @a Integer
to'
            mThn :: Maybe Integer
mThn = ((Integer, Type) -> Integer)
-> Maybe (Integer, Type) -> Maybe Integer
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (Integral a, Num a) => Integer -> Integer
wrap @a (Integer -> Integer)
-> ((Integer, Type) -> Integer) -> (Integer, Type) -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, Type) -> Integer
forall a b. (a, b) -> a
fst) Maybe (Integer, Type)
mThn'

      Platform
platform <- DynFlags -> Platform
targetPlatform (DynFlags -> Platform)
-> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
-> IOEnv (Env DsGblEnv DsLclEnv) Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
         -- Be careful to use target Int/Word sizes! cf #17336
      if | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
intTyConName     -> case Platform -> PlatformWordSize
platformWordSize Platform
platform of
                                               PlatformWordSize
PW4 -> forall a. (Integral a, Num a) => DsM ()
check @Int32
                                               PlatformWordSize
PW8 -> forall a. (Integral a, Num a) => DsM ()
check @Int64
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
wordTyConName    -> case Platform -> PlatformWordSize
platformWordSize Platform
platform of
                                               PlatformWordSize
PW4 -> forall a. (Integral a, Num a) => DsM ()
check @Word32
                                               PlatformWordSize
PW8 -> forall a. (Integral a, Num a) => DsM ()
check @Word64
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int8TyConName    -> forall a. (Integral a, Num a) => DsM ()
check @Int8
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int16TyConName   -> forall a. (Integral a, Num a) => DsM ()
check @Int16
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int32TyConName   -> forall a. (Integral a, Num a) => DsM ()
check @Int32
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
int64TyConName   -> forall a. (Integral a, Num a) => DsM ()
check @Int64
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word8TyConName   -> forall a. (Integral a, Num a) => DsM ()
check @Word8
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word16TyConName  -> forall a. (Integral a, Num a) => DsM ()
check @Word16
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word32TyConName  -> forall a. (Integral a, Num a) => DsM ()
check @Word32
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
word64TyConName  -> forall a. (Integral a, Num a) => DsM ()
check @Word64
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
integerTyConName -> forall a. (Integral a, Num a) => DsM ()
check @Integer
         | Name -> Name -> Bool
forall a. Uniquable a => a -> a -> Bool
sameUnique Name
tc Name
naturalTyConName -> forall a. (Integral a, Num a) => DsM ()
check @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.
         | Bool
otherwise -> () -> DsM ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- Char literals (#18402)
  | Just Char
fromChar <- LHsExpr GhcTc -> Maybe Char
getLHsCharLit LHsExpr GhcTc
fromExpr
  , Just Maybe Char
mThnChar <- (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> Maybe Char)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> Maybe (Maybe Char)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse LHsExpr GhcTc -> Maybe Char
GenLocated SrcSpanAnnA (HsExpr GhcTc) -> Maybe Char
getLHsCharLit Maybe (LHsExpr GhcTc)
Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mThnExpr
  , Just Char
toChar   <- LHsExpr GhcTc -> Maybe Char
getLHsCharLit LHsExpr GhcTc
toExpr
  , let enumeration :: String
enumeration = case Maybe Char
mThnChar of
                        Maybe Char
Nothing      -> [Char
fromChar          .. Char
toChar]
                        Just Char
thnChar -> [Char
fromChar, Char
thnChar .. Char
toChar]
  = Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
enumeration) DsM ()
raiseWarning

  | Bool
otherwise = () -> DsM ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    raiseWarning :: DsM ()
raiseWarning =
      DsMessage -> DsM ()
diagnosticDs DsMessage
DsEmptyEnumeration

getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type)
-- ^ See if the expression is an 'Integral' literal.
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type)
getLHsIntegralLit (L SrcSpanAnnA
_ HsExpr GhcTc
e) = HsExpr GhcTc -> Maybe (Integer, Type)
go HsExpr GhcTc
e
  where
    go :: HsExpr GhcTc -> Maybe (Integer, Type)
go (HsPar XPar GhcTc
_ LHsToken "(" GhcTc
_ LHsExpr GhcTc
e LHsToken ")" GhcTc
_)        = LHsExpr GhcTc -> Maybe (Integer, Type)
getLHsIntegralLit LHsExpr GhcTc
e
    go (HsOverLit XOverLitE GhcTc
_ HsOverLit GhcTc
over_lit) = HsOverLit GhcTc -> Maybe (Integer, Type)
getIntegralLit HsOverLit GhcTc
over_lit
    go (HsLit XLitE GhcTc
_ HsLit GhcTc
lit)          = HsLit GhcTc -> Maybe (Integer, Type)
getSimpleIntegralLit HsLit GhcTc
lit

    -- Remember to look through automatically-added tick-boxes! (#8384)
    go (XExpr (HsTick CoreTickish
_ LHsExpr GhcTc
e))       = LHsExpr GhcTc -> Maybe (Integer, Type)
getLHsIntegralLit LHsExpr GhcTc
e
    go (XExpr (HsBinTick Int
_ Int
_ LHsExpr GhcTc
e))  = LHsExpr GhcTc -> Maybe (Integer, Type)
getLHsIntegralLit LHsExpr GhcTc
e

    -- The literal might be wrapped in a case with -XOverloadedLists
    go (XExpr (WrapExpr (HsWrap HsWrapper
_ HsExpr GhcTc
e))) = HsExpr GhcTc -> Maybe (Integer, Type)
go HsExpr GhcTc
e
    go HsExpr GhcTc
_ = Maybe (Integer, Type)
forall a. Maybe a
Nothing

-- | If 'Integral', extract the value and type of the overloaded literal.
-- See Note [Literals and the OverloadedLists extension]
getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)
getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)
getIntegralLit (OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = HsIntegral IntegralLit
i, ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = OverLitTc { ol_type :: OverLitTc -> Type
ol_type = Type
ty } })
  = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (IntegralLit -> Integer
il_value IntegralLit
i, Type
ty)
getIntegralLit HsOverLit GhcTc
_ = Maybe (Integer, Type)
forall a. Maybe a
Nothing

-- | If 'Integral', extract the value and type of the non-overloaded literal.
getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type)
getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type)
getSimpleIntegralLit (HsInt XHsInt GhcTc
_ IL{ il_value :: IntegralLit -> Integer
il_value = Integer
i }) = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
intTy)
getSimpleIntegralLit (HsIntPrim XHsIntPrim GhcTc
_ Integer
i)    = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
intPrimTy)
getSimpleIntegralLit (HsWordPrim XHsWordPrim GhcTc
_ Integer
i)   = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
wordPrimTy)
getSimpleIntegralLit (HsInt8Prim XHsInt8Prim GhcTc
_ Integer
i)   = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
int8PrimTy)
getSimpleIntegralLit (HsInt16Prim XHsInt16Prim GhcTc
_ Integer
i)  = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
int16PrimTy)
getSimpleIntegralLit (HsInt32Prim XHsInt32Prim GhcTc
_ Integer
i)  = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
int32PrimTy)
getSimpleIntegralLit (HsInt64Prim XHsInt64Prim GhcTc
_ Integer
i)  = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
int64PrimTy)
getSimpleIntegralLit (HsWord8Prim XHsWord8Prim GhcTc
_ Integer
i)  = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
word8PrimTy)
getSimpleIntegralLit (HsWord16Prim XHsWord16Prim GhcTc
_ Integer
i) = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
word16PrimTy)
getSimpleIntegralLit (HsWord32Prim XHsWord32Prim GhcTc
_ Integer
i) = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
word32PrimTy)
getSimpleIntegralLit (HsWord64Prim XHsWord64Prim GhcTc
_ Integer
i) = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
word64PrimTy)
getSimpleIntegralLit (HsInteger XHsInteger GhcTc
_ Integer
i Type
ty) = (Integer, Type) -> Maybe (Integer, Type)
forall a. a -> Maybe a
Just (Integer
i, Type
ty)

getSimpleIntegralLit HsChar{}           = Maybe (Integer, Type)
forall a. Maybe a
Nothing
getSimpleIntegralLit HsCharPrim{}       = Maybe (Integer, Type)
forall a. Maybe a
Nothing
getSimpleIntegralLit HsString{}         = Maybe (Integer, Type)
forall a. Maybe a
Nothing
getSimpleIntegralLit HsStringPrim{}     = Maybe (Integer, Type)
forall a. Maybe a
Nothing
getSimpleIntegralLit HsRat{}            = Maybe (Integer, Type)
forall a. Maybe a
Nothing
getSimpleIntegralLit HsFloatPrim{}      = Maybe (Integer, Type)
forall a. Maybe a
Nothing
getSimpleIntegralLit HsDoublePrim{}     = Maybe (Integer, Type)
forall a. Maybe a
Nothing

-- | Extract the Char if the expression is a Char literal.
getLHsCharLit :: LHsExpr GhcTc -> Maybe Char
getLHsCharLit :: LHsExpr GhcTc -> Maybe Char
getLHsCharLit (L SrcSpanAnnA
_ (HsPar XPar GhcTc
_ LHsToken "(" GhcTc
_ LHsExpr GhcTc
e LHsToken ")" GhcTc
_))        = LHsExpr GhcTc -> Maybe Char
getLHsCharLit LHsExpr GhcTc
e
getLHsCharLit (L SrcSpanAnnA
_ (HsLit XLitE GhcTc
_ (HsChar XHsChar GhcTc
_ Char
c))) = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c
getLHsCharLit (L SrcSpanAnnA
_ (XExpr (HsTick CoreTickish
_ LHsExpr GhcTc
e)))         = LHsExpr GhcTc -> Maybe Char
getLHsCharLit LHsExpr GhcTc
e
getLHsCharLit (L SrcSpanAnnA
_ (XExpr (HsBinTick Int
_ Int
_ LHsExpr GhcTc
e)))    = LHsExpr GhcTc -> Maybe Char
getLHsCharLit LHsExpr GhcTc
e
getLHsCharLit LHsExpr GhcTc
_ = Maybe Char
forall a. Maybe a
Nothing

-- | Convert a pair (Integer, Type) to (Integer, Name) after eventually
-- normalising the type
getNormalisedTyconName :: FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)
getNormalisedTyconName :: FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)
getNormalisedTyconName FamInstEnvs
fam_envs (Integer
i,Type
ty)
    | Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe (FamInstEnvs -> Type -> Type
normaliseNominal FamInstEnvs
fam_envs Type
ty)
    = (Integer, Name) -> Maybe (Integer, Name)
forall a. a -> Maybe a
Just (Integer
i, TyCon -> Name
tyConName TyCon
tc)
    | Bool
otherwise = Maybe (Integer, Name)
forall a. Maybe a
Nothing
  where
    normaliseNominal :: FamInstEnvs -> Type -> Type
    normaliseNominal :: FamInstEnvs -> Type -> Type
normaliseNominal FamInstEnvs
fam_envs Type
ty
      = Reduction -> Type
reductionReducedType
      (Reduction -> Type) -> Reduction -> Type
forall a b. (a -> b) -> a -> b
$ FamInstEnvs -> Role -> Type -> Reduction
normaliseType FamInstEnvs
fam_envs Role
Nominal Type
ty

-- | Convert a pair (Integer, Type) to (Integer, Name) without normalising
-- the type
getTyconName :: (Integer, Type) -> Maybe (Integer, Name)
getTyconName :: (Integer, Type) -> Maybe (Integer, Name)
getTyconName (Integer
i,Type
ty)
  | Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty = (Integer, Name) -> Maybe (Integer, Name)
forall a. a -> Maybe a
Just (Integer
i, TyCon -> Name
tyConName TyCon
tc)
  | Bool
otherwise = Maybe (Integer, Name)
forall a. Maybe a
Nothing

{-
Note [Literals and the OverloadedLists extension]
~~~~
Consider the Literal `[256] :: [Data.Word.Word8]`

When the `OverloadedLists` extension is not active, then the `ol_ext` field
in the `OverLitTc` record that is passed to the function `getIntegralLit`
contains the type `Word8`. This is a simple type, and we can use its
type constructor immediately for the `warnAboutOverflowedLiterals` function.

When the `OverloadedLists` extension is active, then the `ol_ext` field
contains the type family `Item [Word8]`. The function `nomaliseType` is used
to convert it to the needed type `Word8`.
-}

{-
************************************************************************
*                                                                      *
        Tidying lit pats
*                                                                      *
************************************************************************
-}

tidyLitPat :: HsLit GhcTc -> Pat GhcTc
-- Result has only the following HsLits:
--      HsIntPrim, HsWordPrim, HsCharPrim, HsString
--  * HsInteger, HsRat, HsInt, as well as HsStringPrim,
--    HsFloatPrim and HsDoublePrim can't show up in LitPats
--  * We get rid of HsChar right here
tidyLitPat :: HsLit GhcTc -> Pat GhcTc
tidyLitPat (HsChar XHsChar GhcTc
src Char
c) = GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc (SourceText -> Char -> LPat GhcTc
mkCharLitPat XHsChar GhcTc
SourceText
src Char
c)
tidyLitPat (HsString XHsString GhcTc
src FastString
s)
  | FastString -> Int
lengthFS FastString
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1     -- Short string literals only
  = GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc)
-> GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall a b. (a -> b) -> a -> b
$ (Char
 -> GenLocated SrcSpanAnnA (Pat GhcTc)
 -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> GenLocated SrcSpanAnnA (Pat GhcTc)
-> String
-> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
c GenLocated SrcSpanAnnA (Pat GhcTc)
pat -> DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc
mkPrefixConPat DataCon
consDataCon
                                             [SourceText -> Char -> LPat GhcTc
mkCharLitPat XHsString GhcTc
SourceText
src Char
c, LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat] [Type
charTy])
                  (Type -> LPat GhcTc
mkNilPat Type
charTy) (FastString -> String
unpackFS FastString
s)
        -- The stringTy is the type of the whole pattern, not
        -- the type to instantiate (:) or [] with!
tidyLitPat HsLit GhcTc
lit = XLitPat GhcTc -> HsLit GhcTc -> Pat GhcTc
forall p. XLitPat p -> HsLit p -> Pat p
LitPat XLitPat GhcTc
NoExtField
noExtField HsLit GhcTc
lit

----------------
tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
         -> Type
         -> Pat GhcTc
tidyNPat :: HsOverLit GhcTc
-> Maybe (SyntaxExpr GhcTc)
-> SyntaxExpr GhcTc
-> Type
-> Pat GhcTc
tidyNPat (OverLit (OverLitTc Bool
False HsExpr GhcTc
_ Type
ty) OverLitVal
val) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
_eq Type
outer_ty
        -- False: Take short cuts only if the literal is not using rebindable syntax
        --
        -- Once that is settled, look for cases where the type of the
        -- entire overloaded literal matches the type of the underlying literal,
        -- and in that case take the short cut
        -- NB: Watch out for weird cases like #3382
        --        f :: Int -> Int
        --        f "blah" = 4
        --     which might be ok if we have 'instance IsString Int'
        --
  | Bool -> Bool
not Bool
type_change, Type -> Bool
isIntTy Type
ty,    Just Integer
int_lit <- Maybe Integer
mb_int_lit
                 = DataCon -> HsLit GhcTc -> Pat GhcTc
mk_con_pat DataCon
intDataCon    (XHsIntPrim GhcTc -> Integer -> HsLit GhcTc
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim    XHsIntPrim GhcTc
SourceText
NoSourceText Integer
int_lit)
  | Bool -> Bool
not Bool
type_change, Type -> Bool
isWordTy Type
ty,   Just Integer
int_lit <- Maybe Integer
mb_int_lit
                 = DataCon -> HsLit GhcTc -> Pat GhcTc
mk_con_pat DataCon
wordDataCon   (XHsWordPrim GhcTc -> Integer -> HsLit GhcTc
forall x. XHsWordPrim x -> Integer -> HsLit x
HsWordPrim   XHsWordPrim GhcTc
SourceText
NoSourceText Integer
int_lit)
  | Bool -> Bool
not Bool
type_change, Type -> Bool
isStringTy Type
ty, Just FastString
str_lit <- Maybe FastString
mb_str_lit
                 = HsLit GhcTc -> Pat GhcTc
tidyLitPat (XHsString GhcTc -> FastString -> HsLit GhcTc
forall x. XHsString x -> FastString -> HsLit x
HsString XHsString GhcTc
SourceText
NoSourceText FastString
str_lit)
     -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
     -- If we do convert to the constructor form, we'll generate a case
     -- expression on a Float# or Double# and that's not allowed in Core; see
     -- #9238 and Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold
  where
    -- Sometimes (like in test case
    -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
    -- type-changing wrappers (for example, from Id Int to Int, for the identity
    -- type family Id). In these cases, we can't do the short-cut.
    type_change :: Bool
type_change = Bool -> Bool
not (Type
outer_ty Type -> Type -> Bool
`eqType` Type
ty)

    mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
    mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
mk_con_pat DataCon
con HsLit GhcTc
lit
      = GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc (DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc
mkPrefixConPat DataCon
con [Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a an. a -> LocatedAn an a
noLocA (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ XLitPat GhcTc -> HsLit GhcTc -> Pat GhcTc
forall p. XLitPat p -> HsLit p -> Pat p
LitPat XLitPat GhcTc
NoExtField
noExtField HsLit GhcTc
lit] [])

    mb_int_lit :: Maybe Integer
    mb_int_lit :: Maybe Integer
mb_int_lit = case (Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
mb_neg, OverLitVal
val) of
                   (Maybe SyntaxExprTc
Nothing, HsIntegral IntegralLit
i) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (IntegralLit -> Integer
il_value IntegralLit
i)
                   (Just SyntaxExprTc
_,  HsIntegral IntegralLit
i) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (-(IntegralLit -> Integer
il_value IntegralLit
i))
                   (Maybe SyntaxExprTc, OverLitVal)
_ -> Maybe Integer
forall a. Maybe a
Nothing

    mb_str_lit :: Maybe FastString
    mb_str_lit :: Maybe FastString
mb_str_lit = case (Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
mb_neg, OverLitVal
val) of
                   (Maybe SyntaxExprTc
Nothing, HsIsString SourceText
_ FastString
s) -> FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
s
                   (Maybe SyntaxExprTc, OverLitVal)
_ -> Maybe FastString
forall a. Maybe a
Nothing

tidyNPat HsOverLit GhcTc
over_lit Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq Type
outer_ty
  = XNPat GhcTc
-> XRec GhcTc (HsOverLit GhcTc)
-> Maybe (SyntaxExpr GhcTc)
-> SyntaxExpr GhcTc
-> Pat GhcTc
forall p.
XNPat p
-> XRec p (HsOverLit p)
-> Maybe (SyntaxExpr p)
-> SyntaxExpr p
-> Pat p
NPat XNPat GhcTc
Type
outer_ty (HsOverLit GhcTc -> LocatedAn NoEpAnns (HsOverLit GhcTc)
forall a an. a -> LocatedAn an a
noLocA HsOverLit GhcTc
over_lit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq

{-
************************************************************************
*                                                                      *
                Pattern matching on LitPat
*                                                                      *
************************************************************************
-}

matchLiterals :: NonEmpty Id
              -> Type -- ^ Type of the whole case expression
              -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
              -> DsM (MatchResult CoreExpr)

matchLiterals :: NonEmpty Id
-> Type
-> NonEmpty (NonEmpty EquationInfo)
-> DsM (MatchResult CoreExpr)
matchLiterals (Id
var :| [Id]
vars) Type
ty NonEmpty (NonEmpty EquationInfo)
sub_groups
  = do  {       -- Deal with each group
        ; NonEmpty (Literal, MatchResult CoreExpr)
alts <- (NonEmpty EquationInfo
 -> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult CoreExpr))
-> NonEmpty (NonEmpty EquationInfo)
-> IOEnv
     (Env DsGblEnv DsLclEnv) (NonEmpty (Literal, MatchResult CoreExpr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM NonEmpty EquationInfo
-> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult CoreExpr)
match_group NonEmpty (NonEmpty EquationInfo)
sub_groups

                -- Combine results.  For everything except String
                -- we can use a case expression; for String we need
                -- a chain of if-then-else
        ; if Type -> Bool
isStringTy (Id -> Type
idType Id
var) then
            do  { Id
eq_str <- Name -> DsM Id
dsLookupGlobalId Name
eqStringName
                ; NonEmpty (MatchResult CoreExpr)
mrs <- ((Literal, MatchResult CoreExpr) -> DsM (MatchResult CoreExpr))
-> NonEmpty (Literal, MatchResult CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (NonEmpty (MatchResult CoreExpr))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Id -> (Literal, MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
wrap_str_guard Id
eq_str) NonEmpty (Literal, MatchResult CoreExpr)
alts
                ; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((MatchResult CoreExpr
 -> MatchResult CoreExpr -> MatchResult CoreExpr)
-> NonEmpty (MatchResult CoreExpr) -> MatchResult CoreExpr
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 MatchResult CoreExpr
-> MatchResult CoreExpr -> MatchResult CoreExpr
combineMatchResults NonEmpty (MatchResult CoreExpr)
mrs) }
          else
            MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
-> Type
-> [(Literal, MatchResult CoreExpr)]
-> MatchResult CoreExpr
mkCoPrimCaseMatchResult Id
var Type
ty ([(Literal, MatchResult CoreExpr)] -> MatchResult CoreExpr)
-> [(Literal, MatchResult CoreExpr)] -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$ NonEmpty (Literal, MatchResult CoreExpr)
-> [(Literal, MatchResult CoreExpr)]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Literal, MatchResult CoreExpr)
alts)
        }
  where
    match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
    match_group :: NonEmpty EquationInfo
-> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult CoreExpr)
match_group eqns :: NonEmpty EquationInfo
eqns@(EquationInfo
firstEqn :| [EquationInfo]
_)
        = do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
             ; let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
             ; let LitPat XLitPat GhcTc
_ HsLit GhcTc
hs_lit = EquationInfo -> Pat GhcTc
firstPat EquationInfo
firstEqn
             ; MatchResult CoreExpr
match_result <- [Id] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [Id]
vars Type
ty (NonEmpty EquationInfo -> [EquationInfo]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty EquationInfo -> [EquationInfo])
-> NonEmpty EquationInfo -> [EquationInfo]
forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfo -> NonEmpty EquationInfo
forall (f :: * -> *). Functor f => f EquationInfo -> f EquationInfo
shiftEqns NonEmpty EquationInfo
eqns)
             ; (Literal, MatchResult CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> HsLit GhcTc -> Literal
hsLitKey Platform
platform HsLit GhcTc
hs_lit, MatchResult CoreExpr
match_result) }

    wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
        -- Equality check for string literals
    wrap_str_guard :: Id -> (Literal, MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
wrap_str_guard Id
eq_str (LitString ByteString
s, MatchResult CoreExpr
mr)
        = do { -- We now have to convert back to FastString. Perhaps there
               -- should be separate LitBytes and LitString constructors?
               let s' :: FastString
s'  = ByteString -> FastString
mkFastStringByteString ByteString
s
             ; CoreExpr
lit    <- FastString -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS FastString
s'
             ; let pred :: CoreExpr
pred = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
eq_str) [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var, CoreExpr
lit]
             ; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkGuardedMatchResult CoreExpr
pred MatchResult CoreExpr
mr) }
    wrap_str_guard Id
_ (Literal
l, MatchResult CoreExpr
_) = String -> SDoc -> DsM (MatchResult CoreExpr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchLiterals/wrap_str_guard" (Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
l)


---------------------------
hsLitKey :: Platform -> HsLit GhcTc -> Literal
-- Get the Core literal corresponding to a HsLit.
-- It only works for primitive types and strings;
-- others have been removed by tidy
-- For HsString, it produces a LitString, which really represents an _unboxed_
-- string literal; and we deal with it in matchLiterals above. Otherwise, it
-- produces a primitive Literal of type matching the original HsLit.
-- In the case of the fixed-width numeric types, we need to wrap here
-- because Literal has an invariant that the literal is in range, while
-- HsLit does not.
hsLitKey :: Platform -> HsLit GhcTc -> Literal
hsLitKey Platform
platform (HsIntPrim    XHsIntPrim GhcTc
_ Integer
i)  = Platform -> Integer -> Literal
mkLitIntWrap  Platform
platform Integer
i
hsLitKey Platform
platform (HsWordPrim   XHsWordPrim GhcTc
_ Integer
w)  = Platform -> Integer -> Literal
mkLitWordWrap Platform
platform Integer
w
hsLitKey Platform
_        (HsInt8Prim   XHsInt8Prim GhcTc
_ Integer
i)  = Integer -> Literal
mkLitInt8Wrap   Integer
i
hsLitKey Platform
_        (HsInt16Prim  XHsInt16Prim GhcTc
_ Integer
i)  = Integer -> Literal
mkLitInt16Wrap  Integer
i
hsLitKey Platform
_        (HsInt32Prim  XHsInt32Prim GhcTc
_ Integer
i)  = Integer -> Literal
mkLitInt32Wrap  Integer
i
hsLitKey Platform
_        (HsInt64Prim  XHsInt64Prim GhcTc
_ Integer
i)  = Integer -> Literal
mkLitInt64Wrap  Integer
i
hsLitKey Platform
_        (HsWord8Prim  XHsWord8Prim GhcTc
_ Integer
w)  = Integer -> Literal
mkLitWord8Wrap  Integer
w
hsLitKey Platform
_        (HsWord16Prim XHsWord16Prim GhcTc
_ Integer
w)  = Integer -> Literal
mkLitWord16Wrap Integer
w
hsLitKey Platform
_        (HsWord32Prim XHsWord32Prim GhcTc
_ Integer
w)  = Integer -> Literal
mkLitWord32Wrap Integer
w
hsLitKey Platform
_        (HsWord64Prim XHsWord64Prim GhcTc
_ Integer
w)  = Integer -> Literal
mkLitWord64Wrap Integer
w
hsLitKey Platform
_        (HsCharPrim   XHsCharPrim GhcTc
_ Char
c)  = Char -> Literal
mkLitChar            Char
c
-- This following two can be slow. See Note [FractionalLit representation]
hsLitKey Platform
_        (HsFloatPrim  XHsFloatPrim GhcTc
_ FractionalLit
fl) = Rational -> Literal
mkLitFloat (FractionalLit -> Rational
rationalFromFractionalLit FractionalLit
fl)
hsLitKey Platform
_        (HsDoublePrim XHsDoublePrim GhcTc
_ FractionalLit
fl) = Rational -> Literal
mkLitDouble (FractionalLit -> Rational
rationalFromFractionalLit FractionalLit
fl)

hsLitKey Platform
_        (HsString XHsString GhcTc
_ FastString
s)      = ByteString -> Literal
LitString (FastString -> ByteString
bytesFS FastString
s)
hsLitKey Platform
_        HsLit GhcTc
l                   = String -> SDoc -> Literal
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"hsLitKey" (HsLit GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsLit GhcTc
l)

{-
************************************************************************
*                                                                      *
                Pattern matching on NPat
*                                                                      *
************************************************************************
-}

matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPats :: NonEmpty Id
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPats (Id
var :| [Id]
vars) Type
ty (EquationInfo
eqn1 :| [EquationInfo]
eqns)    -- All for the same literal
  = do  { let NPat XNPat GhcTc
_ (L SrcAnn NoEpAnns
_ HsOverLit GhcTc
lit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq_chk = EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn1
        ; CoreExpr
lit_expr <- HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit
        ; CoreExpr
neg_lit <- case Maybe (SyntaxExpr GhcTc)
mb_neg of
                            Maybe (SyntaxExpr GhcTc)
Nothing  -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
lit_expr
                            Just SyntaxExpr GhcTc
neg -> SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
neg [CoreExpr
lit_expr]
        ; CoreExpr
pred_expr <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
eq_chk [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var, CoreExpr
neg_lit]
        ; MatchResult CoreExpr
match_result <- [Id] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [Id]
vars Type
ty ([EquationInfo] -> [EquationInfo]
forall (f :: * -> *). Functor f => f EquationInfo -> f EquationInfo
shiftEqns (EquationInfo
eqn1EquationInfo -> [EquationInfo] -> [EquationInfo]
forall a. a -> [a] -> [a]
:[EquationInfo]
eqns))
        ; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkGuardedMatchResult CoreExpr
pred_expr MatchResult CoreExpr
match_result) }

{-
************************************************************************
*                                                                      *
                Pattern matching on n+k patterns
*                                                                      *
************************************************************************

For an n+k pattern, we use the various magic expressions we've been given.
We generate:
\begin{verbatim}
    if ge var lit then
        let n = sub var lit
        in  <expr-for-a-successful-match>
    else
        <try-next-pattern-or-whatever>
\end{verbatim}
-}

matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-- All NPlusKPats, for the *same* literal k
matchNPlusKPats :: NonEmpty Id
-> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
matchNPlusKPats (Id
var :| [Id]
vars) Type
ty (EquationInfo
eqn1 :| [EquationInfo]
eqns)
  = do  { let NPlusKPat XNPlusKPat GhcTc
_ (L SrcSpanAnnN
_ Id
n1) (L SrcAnn NoEpAnns
_ HsOverLit GhcTc
lit1) HsOverLit GhcTc
lit2 SyntaxExpr GhcTc
ge SyntaxExpr GhcTc
minus
                = EquationInfo -> Pat GhcTc
firstPat EquationInfo
eqn1
        ; CoreExpr
lit1_expr   <- HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit1
        ; CoreExpr
lit2_expr   <- HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit2
        ; CoreExpr
pred_expr   <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
ge    [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var, CoreExpr
lit1_expr]
        ; CoreExpr
minusk_expr <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
minus [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var, CoreExpr
lit2_expr]
        ; let ([CoreExpr -> CoreExpr]
wraps, [EquationInfo]
eqns') = (EquationInfo -> (CoreExpr -> CoreExpr, EquationInfo))
-> [EquationInfo] -> ([CoreExpr -> CoreExpr], [EquationInfo])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip (Id -> EquationInfo -> (CoreExpr -> CoreExpr, EquationInfo)
shift Id
n1) (EquationInfo
eqn1EquationInfo -> [EquationInfo] -> [EquationInfo]
forall a. a -> [a] -> [a]
:[EquationInfo]
eqns)
        ; MatchResult CoreExpr
match_result <- [Id] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [Id]
vars Type
ty [EquationInfo]
eqns'
        ; MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return  (CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkGuardedMatchResult CoreExpr
pred_expr               (MatchResult CoreExpr -> MatchResult CoreExpr)
-> MatchResult CoreExpr -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$
                   CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr
mkCoLetMatchResult (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
n1 CoreExpr
minusk_expr)   (MatchResult CoreExpr -> MatchResult CoreExpr)
-> MatchResult CoreExpr -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$
                   (CoreExpr -> CoreExpr)
-> MatchResult CoreExpr -> MatchResult CoreExpr
forall a b. (a -> b) -> MatchResult a -> MatchResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((CoreExpr -> CoreExpr)
 -> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) [CoreExpr -> CoreExpr]
wraps)                      (MatchResult CoreExpr -> MatchResult CoreExpr)
-> MatchResult CoreExpr -> MatchResult CoreExpr
forall a b. (a -> b) -> a -> b
$
                   MatchResult CoreExpr
match_result) }
  where
    shift :: Id -> EquationInfo -> (CoreExpr -> CoreExpr, EquationInfo)
shift Id
n1 eqn :: EquationInfo
eqn@(EqnInfo { eqn_pats :: EquationInfo -> [Pat GhcTc]
eqn_pats = NPlusKPat XNPlusKPat GhcTc
_ (L SrcSpanAnnN
_ Id
n) XRec GhcTc (HsOverLit GhcTc)
_ HsOverLit GhcTc
_ SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_ : [Pat GhcTc]
pats })
        = (Id -> Id -> CoreExpr -> CoreExpr
wrapBind Id
n Id
n1, EquationInfo
eqn { eqn_pats = pats })
        -- The wrapBind is a no-op for the first equation
    shift Id
_ EquationInfo
e = String -> SDoc -> (CoreExpr -> CoreExpr, EquationInfo)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchNPlusKPats/shift" (EquationInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr EquationInfo
e)