{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Match.Literal
( dsLit, dsOverLit, hsLitKey
, tidyLitPat, tidyNPat
, matchLiterals, matchNPlusKPats, matchNPats
, numericConversionNames
, 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.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 )
dsLit :: forall p. IsPass p => HsLit (GhcPass p) -> DsM CoreExpr
dsLit :: forall (p :: Pass). IsPass p => HsLit (GhcPass p) -> DsM CoreExpr
dsLit HsLit (GhcPass p)
l = do
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
case l of
HsStringPrim XHsStringPrim (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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))
HsFloatPrim XHsFloatPrim (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ 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 (GhcPass p)
_ FastString
str -> FastString -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS FastString
str
HsMultilineString XHsMultilineString (GhcPass p)
_ FastString
str -> FastString -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS FastString
str
HsInt XHsInt (GhcPass p)
_ 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))
XLit XXLit (GhcPass p)
x -> case forall (p :: Pass). IsPass p => GhcPass p
ghcPass @p of
GhcPass p
GhcTc -> case XXLit (GhcPass p)
x of
HsInteger SourceText
_ 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)
HsRat FractionalLit
fl Type
ty -> FractionalLit -> Type -> DsM CoreExpr
dsFractionalLitToRational FractionalLit
fl Type
ty
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
| 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 <- 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 = FractionalLit -> Rational
rationalFromFractionalLit FractionalLit
fl
!num = Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
val)
!denom = Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
val)
(ratio_data_con, integer_ty)
= case tcSplitTyConApp 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)
return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
| Bool
otherwise
= do
let mkRationalName :: Name
mkRationalName = case FractionalExponentBase
base of
FractionalExponentBase
Base2 -> Name
mkRationalBase2Name
FractionalExponentBase
Base10 -> Name
mkRationalBase10Name
mkRational <- Name -> DsM Id
dsLookupGlobalId Name
mkRationalName
litR <- dsRational signi
platform <- targetPlatform <$> getDynFlags
let litE = Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform Integer
exp
return (mkCoreApps (Var mkRational) [litR, litE])
dsRational :: Rational -> DsM CoreExpr
dsRational :: Rational -> DsM CoreExpr
dsRational (Integer
n :% Integer
d) = do
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
dcn <- dsLookupDataCon ratioDataConName
let cn = Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform Integer
n
let dn = Platform -> Integer -> CoreExpr
mkIntegerExpr Platform
platform Integer
d
return $ mkCoreConApps dcn [Type integerTy, cn, dn]
dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
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
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
case shortCutLit platform val ty of
Just HsExpr GhcTc
expr | Bool -> Bool
not Bool
rebindable -> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
Maybe (HsExpr GhcTc)
_ -> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
witness
numericConversionNames :: [Name]
numericConversionNames :: [Name]
numericConversionNames
= [ Name
toIntegerName, Name
toRationalName
, Name
fromIntegralName, Name
realToFracName ]
warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
warnAboutOverflowedOverLit HsOverLit GhcTc
hsOverLit = do
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
fam_envs <- dsGetFamInstEnvs
warnAboutOverflowedLiterals dflags $
getIntegralLit hsOverLit >>= getNormalisedTyconName fam_envs
warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
warnAboutOverflowedLit HsLit GhcTc
hsLit = do
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
warnAboutOverflowedLiterals dflags $
getSimpleIntegralLit hsLit >>= getTyconName
warnAboutOverflowedLiterals
:: DynFlags
-> Maybe (Integer, Name)
-> 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
| 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
| 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
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 ()
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 ()
| 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 <- 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
if | sameUnique tc intTyConName -> case platformWordSize platform of
PlatformWordSize
PW4 -> forall a. (Integral a, Num a) => DsM ()
check @Int32
PlatformWordSize
PW8 -> forall a. (Integral a, Num a) => DsM ()
check @Int64
| sameUnique tc wordTyConName -> case platformWordSize platform of
PlatformWordSize
PW4 -> forall a. (Integral a, Num a) => DsM ()
check @Word32
PlatformWordSize
PW8 -> forall a. (Integral a, Num a) => DsM ()
check @Word64
| sameUnique tc int8TyConName -> check @Int8
| sameUnique tc int16TyConName -> check @Int16
| sameUnique tc int32TyConName -> check @Int32
| sameUnique tc int64TyConName -> check @Int64
| sameUnique tc word8TyConName -> check @Word8
| sameUnique tc word16TyConName -> check @Word16
| sameUnique tc word32TyConName -> check @Word32
| sameUnique tc word64TyConName -> check @Word64
| sameUnique tc integerTyConName -> check @Integer
| sameUnique tc naturalTyConName -> check @Integer
| otherwise -> return ()
| 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)
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
_ LHsExpr GhcTc
e) = 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
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
go (XExpr (WrapExpr HsWrapper
_ HsExpr GhcTc
e)) = HsExpr GhcTc -> Maybe (Integer, Type)
go HsExpr GhcTc
e
go HsExpr GhcTc
_ = Maybe (Integer, Type)
forall a. Maybe a
Nothing
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
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 (XLit (HsInteger SourceText
_ 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 HsMultilineString{} = Maybe (Integer, Type)
forall a. Maybe a
Nothing
getSimpleIntegralLit HsStringPrim{} = Maybe (Integer, Type)
forall a. Maybe a
Nothing
getSimpleIntegralLit (XLit (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
getLHsCharLit :: LHsExpr GhcTc -> Maybe Char
getLHsCharLit :: LHsExpr GhcTc -> Maybe Char
getLHsCharLit (L SrcSpanAnnA
_ (HsPar XPar GhcTc
_ LHsExpr GhcTc
e)) = 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
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
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
tidyLitPat :: HsLit GhcTc -> Pat GhcTc
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
= 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)
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
| 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)
where
type_change :: Bool
type_change = Bool -> Bool
not (Type
outer_ty HasCallStack => Type -> Type -> Bool
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 e a. HasAnnotation e => a -> GenLocated e 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 -> GenLocated EpAnnCO (HsOverLit GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsOverLit GhcTc
over_lit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq
matchLiterals :: NonEmpty Id
-> Type
-> NonEmpty (NonEmpty EquationInfoNE)
-> DsM (MatchResult CoreExpr)
matchLiterals :: NonEmpty Id
-> Type
-> NonEmpty (NonEmpty EquationInfoNE)
-> DsM (MatchResult CoreExpr)
matchLiterals (Id
var :| [Id]
vars) Type
ty NonEmpty (NonEmpty EquationInfoNE)
sub_groups
= do {
; alts <- (NonEmpty EquationInfoNE
-> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult CoreExpr))
-> NonEmpty (NonEmpty EquationInfoNE)
-> 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 EquationInfoNE
-> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult CoreExpr)
match_group NonEmpty (NonEmpty EquationInfoNE)
sub_groups
; if isStringTy (idType var) then
do { eq_str <- dsLookupGlobalId eqStringName
; mrs <- mapM (wrap_str_guard eq_str) alts
; return (foldr1 combineMatchResults mrs) }
else
return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
}
where
match_group :: NonEmpty EquationInfoNE -> DsM (Literal, MatchResult CoreExpr)
match_group :: NonEmpty EquationInfoNE
-> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult CoreExpr)
match_group NonEmpty EquationInfoNE
eqns
= do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
; let EqnMatch { eqn_pat = L _ (LitPat _ hs_lit) } = NEL.head eqns
; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
; return (hsLitKey platform hs_lit, match_result) }
wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
wrap_str_guard :: Id -> (Literal, MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
wrap_str_guard Id
eq_str (LitString ByteString
s, MatchResult CoreExpr
mr)
= do {
let s' :: FastString
s' = ByteString -> FastString
mkFastStringByteString ByteString
s
; lit <- FastString -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS FastString
s'
; let 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]
; return (mkGuardedMatchResult pred 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
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
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)
matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchNPats :: NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchNPats (Id
var :| [Id]
vars) Type
ty (EquationInfoNE
eqn1 :| [EquationInfoNE]
eqns)
= do { let NPat XNPat GhcTc
_ (L EpAnnCO
_ HsOverLit GhcTc
lit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq_chk = EquationInfoNE -> Pat GhcTc
firstPat EquationInfoNE
eqn1
; lit_expr <- HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit
; neg_lit <- case 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]
; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
; match_result <- match vars ty (shiftEqns (eqn1:eqns))
; return (mkGuardedMatchResult pred_expr match_result) }
matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchNPlusKPats :: NonEmpty Id
-> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr)
matchNPlusKPats (Id
var :| [Id]
vars) Type
ty (EquationInfoNE
eqn1 :| [EquationInfoNE]
eqns)
= do { let NPlusKPat XNPlusKPat GhcTc
_ (L SrcSpanAnnN
_ Id
n1) (L EpAnnCO
_ HsOverLit GhcTc
lit1) HsOverLit GhcTc
lit2 SyntaxExpr GhcTc
ge SyntaxExpr GhcTc
minus
= EquationInfoNE -> Pat GhcTc
firstPat EquationInfoNE
eqn1
; lit1_expr <- HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit1
; lit2_expr <- dsOverLit lit2
; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr]
; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
; match_result <- match vars ty eqns'
; return (mkGuardedMatchResult pred_expr $
mkCoLetMatchResult (NonRec n1 minusk_expr) $
fmap (foldr1 (.) wraps) $
match_result) }
where
shift :: Id -> EquationInfoNE -> (CoreExpr -> CoreExpr, EquationInfoNE)
shift Id
n1 (EqnMatch { eqn_pat :: EquationInfoNE -> LPat GhcTc
eqn_pat = L SrcSpanAnnA
_ (NPlusKPat XNPlusKPat GhcTc
_ (L SrcSpanAnnN
_ Id
n) XRec GhcTc (HsOverLit GhcTc)
_ HsOverLit GhcTc
_ SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_), eqn_rest :: EquationInfoNE -> EquationInfoNE
eqn_rest = EquationInfoNE
rest })
= (Id -> Id -> CoreExpr -> CoreExpr
wrapBind Id
n Id
n1, EquationInfoNE
rest)
shift Id
_ EquationInfoNE
e = String -> SDoc -> (CoreExpr -> CoreExpr, EquationInfoNE)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchNPlusKPats/shift" (EquationInfoNE -> SDoc
forall a. Outputable a => a -> SDoc
ppr EquationInfoNE
e)