{-# LANGUAGE CPP #-}
{-# 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
, warnAboutIdentities
, warnAboutOverflowedOverLit, warnAboutOverflowedLit
, warnAboutEmptyEnumerations
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import {-# SOURCE #-} GHC.HsToCore.Match ( match )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr )
import GHC.HsToCore.Monad
import GHC.HsToCore.Utils
import GHC.Hs
import GHC.Types.Id
import GHC.Types.SourceText
import GHC.Core
import GHC.Core.Make
import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Tc.Utils.Zonk ( shortCutLit )
import GHC.Tc.Utils.TcType
import GHC.Types.Name
import GHC.Core.Type
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Types.Literal
import GHC.Types.SrcLoc
import GHC.Utils.Outputable as Outputable
import GHC.Driver.Session
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )
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 :: HsLit GhcRn -> DsM CoreExpr
dsLit :: HsLit GhcRn -> DsM CoreExpr
dsLit HsLit GhcRn
l = do
DynFlags
dflags <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Literal -> Expr b
Lit (ByteString -> Literal
LitString ByteString
s))
HsCharPrim XHsCharPrim GhcRn
_ Char
c -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Literal -> Expr b
Lit (Char -> Literal
LitChar Char
c))
HsIntPrim XHsIntPrim GhcRn
_ Integer
i -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitIntWrap Platform
platform Integer
i))
HsWordPrim XHsWordPrim GhcRn
_ Integer
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Literal -> Expr b
Lit (Platform -> Integer -> Literal
mkLitWordWrap Platform
platform Integer
w))
HsInt64Prim XHsInt64Prim GhcRn
_ Integer
i -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitInt64Wrap Integer
i))
HsWord64Prim XHsWord64Prim GhcRn
_ Integer
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Literal -> Expr b
Lit (Integer -> Literal
mkLitWord64Wrap Integer
w))
HsFloatPrim XHsFloatPrim GhcRn
_ FractionalLit
fl -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Literal -> Expr b
Lit (Rational -> Literal
LitFloat (FractionalLit -> Rational
rationalFromFractionalLit FractionalLit
fl)))
HsDoublePrim XHsDoublePrim GhcRn
_ FractionalLit
fl -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Literal -> Expr b
Lit (Rational -> Literal
LitDouble (FractionalLit -> Rational
rationalFromFractionalLit FractionalLit
fl)))
HsChar XHsChar GhcRn
_ Char
c -> forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> CoreExpr
mkCharExpr Char
c)
HsString XHsString GhcRn
_ FastString
str -> forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS FastString
str
HsInteger XHsInteger GhcRn
_ Integer
i Type
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> CoreExpr
mkIntegerExpr Integer
i)
HsInt XHsInt GhcRn
_ IntegralLit
i -> 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
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
| forall a. Num a => a -> a
abs Integer
exp forall a. Ord a => a -> a -> Bool
<= Integer
100
= let !val :: Rational
val = FractionalLit -> Rational
rationalFromFractionalLit FractionalLit
fl
!num :: CoreExpr
num = Integer -> CoreExpr
mkIntegerExpr (forall a. Ratio a -> a
numerator Rational
val)
!denom :: CoreExpr
denom = Integer -> CoreExpr
mkIntegerExpr (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]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(forall a. [a] -> a
head (TyCon -> [DataCon]
tyConDataCons TyCon
tycon), Type
i_ty)
(TyCon, [Type])
x -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsLit" (forall a. Outputable a => a -> SDoc
ppr (TyCon, [Type])
x)
in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
ratio_data_con [forall b. Type -> Expr b
Type Type
integer_ty, CoreExpr
num, CoreExpr
denom])
| 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
let litE :: CoreExpr
litE = Integer -> CoreExpr
mkIntegerExpr Integer
exp
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (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
DataCon
dcn <- Name -> DsM DataCon
dsLookupDataCon Name
ratioDataConName
let cn :: CoreExpr
cn = Integer -> CoreExpr
mkIntegerExpr Integer
n
let dn :: CoreExpr
dn = Integer -> CoreExpr
mkIntegerExpr Integer
d
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
dcn [forall b. Type -> Expr b
Type Type
integerTy, CoreExpr
cn, CoreExpr
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 Type
ty
, ol_witness :: forall p. HsOverLit p -> HsExpr p
ol_witness = HsExpr GhcTc
witness }) = do
DynFlags
dflags <- 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
Maybe (HsExpr GhcTc)
_ -> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
witness
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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
conversionNames
, Just (Type
_, Type
arg_ty, Type
res_ty) <- Type -> Maybe (Type, Type, Type)
splitFunTy_maybe Type
type_of_conv
, Type
arg_ty Type -> Type -> Bool
`eqType` Type
res_ty
= WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnIdentities)
([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Call of" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Id
conv_fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
type_of_conv
, Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"can probably be omitted"
])
warnAboutIdentities DynFlags
_ Id
_ Type
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
conversionNames :: [Name]
conversionNames :: [Name]
conversionNames
= [ Name
toIntegerName, Name
toRationalName
, Name
fromIntegralName, Name
realToFracName ]
warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
warnAboutOverflowedOverLit HsOverLit GhcTc
hsOverLit = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
FamInstEnvs
fam_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
DynFlags -> Maybe (Integer, Name) -> DsM ()
warnAboutOverflowedLiterals DynFlags
dflags forall a b. (a -> b) -> a -> b
$
HsOverLit GhcTc -> Maybe (Integer, Type)
getIntegralLit HsOverLit GhcTc
hsOverLit forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)
getNormalisedTyconName FamInstEnvs
fam_envs
warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
warnAboutOverflowedLit HsLit GhcTc
hsLit = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DynFlags -> Maybe (Integer, Name) -> DsM ()
warnAboutOverflowedLiterals DynFlags
dflags forall a b. (a -> b) -> a -> b
$
HsLit GhcTc -> Maybe (Integer, Type)
getSimpleIntegralLit HsLit GhcTc
hsLit forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Integer, Type) -> Maybe (Integer, Name)
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
tc forall a. Eq a => a -> a -> Bool
== Name
intTyConName -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc Integer
minInt Integer
maxInt
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
wordTyConName -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc Integer
minWord Integer
maxWord
| Name
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== Name
naturalTyConName -> Integer -> Name -> DsM ()
checkPositive Integer
i Name
tc
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
intPrimTyConName -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc Integer
minInt Integer
maxInt
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
wordPrimTyConName -> Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc Integer
minWord Integer
maxWord
| Name
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = 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' = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
minBound :: a)
max' :: forall a. (Integral a, Bounded a) => Integer
max' :: forall a. (Integral a, Bounded a) => Integer
max' = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: a)
checkPositive :: Integer -> Name -> DsM ()
checkPositive :: Integer -> Name -> DsM ()
checkPositive Integer
i Name
tc
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
i forall a. Ord a => a -> a -> Bool
< Integer
0) forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnOverflowedLiterals)
([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Literal" SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
integer Integer
i
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is negative but" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
tc
SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"only supports positive numbers")
])
check :: Integer -> Name -> Integer -> Integer -> DsM ()
check Integer
i Name
tc Integer
minB Integer
maxB
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
i forall a. Ord a => a -> a -> Bool
< Integer
minB Bool -> Bool -> Bool
|| Integer
i forall a. Ord a => a -> a -> Bool
> Integer
maxB) forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnOverflowedLiterals)
([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Literal" SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
integer Integer
i
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is out of the" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
tc SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"range")
SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
integer Integer
minB SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
".." SDoc -> SDoc -> SDoc
<> Integer -> SDoc
integer Integer
maxB
, SDoc
sug ])
where
sug :: SDoc
sug | Integer
minB forall a. Eq a => a -> a -> Bool
== -Integer
i
, Integer
i forall a. Ord a => a -> a -> Bool
> Integer
0
, Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.NegativeLiterals DynFlags
dflags)
= String -> SDoc
text String
"If you are trying to write a large negative literal, use NegativeLiterals"
| Bool
otherwise = SDoc
Outputable.empty
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 forall a b. (a -> b) -> a -> b
$ WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnEmptyEnumerations DynFlags
dflags
= 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' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LHsExpr GhcTc -> Maybe (Integer, Type)
getLHsIntegralLit Maybe (LHsExpr 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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 = forall a. Integral a => a -> Integer
toInteger (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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (Integral a, Num a) => Integer -> Integer
wrap @a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Maybe (Integer, Type)
mThn'
Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if | Name
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== 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
tc forall a. Eq a => a -> a -> Bool
== Name
int8TyConName -> forall a. (Integral a, Num a) => DsM ()
check @Int8
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
int16TyConName -> forall a. (Integral a, Num a) => DsM ()
check @Int16
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
int32TyConName -> forall a. (Integral a, Num a) => DsM ()
check @Int32
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
int64TyConName -> forall a. (Integral a, Num a) => DsM ()
check @Int64
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
word8TyConName -> forall a. (Integral a, Num a) => DsM ()
check @Word8
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
word16TyConName -> forall a. (Integral a, Num a) => DsM ()
check @Word16
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
word32TyConName -> forall a. (Integral a, Num a) => DsM ()
check @Word32
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
word64TyConName -> forall a. (Integral a, Num a) => DsM ()
check @Word64
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
integerTyConName -> forall a. (Integral a, Num a) => DsM ()
check @Integer
| Name
tc forall a. Eq a => a -> a -> Bool
== Name
naturalTyConName -> forall a. (Integral a, Num a) => DsM ()
check @Integer
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just Char
fromChar <- LHsExpr GhcTc -> Maybe Char
getLHsCharLit LHsExpr GhcTc
fromExpr
, Just Maybe Char
mThnChar <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LHsExpr GhcTc -> Maybe Char
getLHsCharLit Maybe (LHsExpr 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]
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
enumeration) DsM ()
raiseWarning
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
raiseWarning :: DsM ()
raiseWarning = WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnEmptyEnumerations) (String -> SDoc
text String
"Enumeration is empty")
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 (HsTick XTick GhcTc
_ CoreTickish
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> Maybe (Integer, Type)
getLHsIntegralLit LHsExpr GhcTc
e
go (HsBinTick XBinTick GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> Maybe (Integer, Type)
getLHsIntegralLit LHsExpr GhcTc
e
go (XExpr (WrapExpr (HsWrap HsWrapper
_ HsExpr GhcTc
e))) = HsExpr GhcTc -> Maybe (Integer, Type)
go HsExpr GhcTc
e
go HsExpr GhcTc
_ = 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 Bool
_ Type
ty })
= forall a. a -> Maybe a
Just (IntegralLit -> Integer
il_value IntegralLit
i, Type
ty)
getIntegralLit HsOverLit GhcTc
_ = 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 }) = forall a. a -> Maybe a
Just (Integer
i, Type
intTy)
getSimpleIntegralLit (HsIntPrim XHsIntPrim GhcTc
_ Integer
i) = forall a. a -> Maybe a
Just (Integer
i, Type
intPrimTy)
getSimpleIntegralLit (HsWordPrim XHsWordPrim GhcTc
_ Integer
i) = forall a. a -> Maybe a
Just (Integer
i, Type
wordPrimTy)
getSimpleIntegralLit (HsInt64Prim XHsInt64Prim GhcTc
_ Integer
i) = forall a. a -> Maybe a
Just (Integer
i, Type
int64PrimTy)
getSimpleIntegralLit (HsWord64Prim XHsWord64Prim GhcTc
_ Integer
i) = forall a. a -> Maybe a
Just (Integer
i, Type
word64PrimTy)
getSimpleIntegralLit (HsInteger XHsInteger GhcTc
_ Integer
i Type
ty) = forall a. a -> Maybe a
Just (Integer
i, Type
ty)
getSimpleIntegralLit HsLit GhcTc
_ = 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
_ (HsTick XTick GhcTc
_ CoreTickish
_ LHsExpr GhcTc
e)) = LHsExpr GhcTc -> Maybe Char
getLHsCharLit LHsExpr GhcTc
e
getLHsCharLit (L SrcSpanAnnA
_ (HsBinTick XBinTick GhcTc
_ Int
_ Int
_ LHsExpr GhcTc
e)) = LHsExpr GhcTc -> Maybe Char
getLHsCharLit LHsExpr GhcTc
e
getLHsCharLit (L SrcSpanAnnA
_ (HsLit XLitE GhcTc
_ (HsChar XHsChar GhcTc
_ Char
c))) = forall a. a -> Maybe a
Just Char
c
getLHsCharLit LHsExpr GhcTc
_ = 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)
= forall a. a -> Maybe a
Just (Integer
i, TyCon -> Name
tyConName TyCon
tc)
| Bool
otherwise = forall a. Maybe a
Nothing
where
normaliseNominal :: FamInstEnvs -> Type -> Type
normaliseNominal :: FamInstEnvs -> Type -> Type
normaliseNominal FamInstEnvs
fam_envs Type
ty = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ FamInstEnvs -> Role -> Type -> (Coercion, Type)
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 = forall a. a -> Maybe a
Just (Integer
i, TyCon -> Name
tyConName TyCon
tc)
| Bool
otherwise = forall a. Maybe a
Nothing
tidyLitPat :: HsLit GhcTc -> Pat GhcTc
tidyLitPat :: HsLit GhcTc -> Pat GhcTc
tidyLitPat (HsChar XHsChar GhcTc
src Char
c) = forall l e. GenLocated l e -> e
unLoc (SourceText -> Char -> LPat GhcTc
mkCharLitPat XHsChar GhcTc
src Char
c)
tidyLitPat (HsString XHsString GhcTc
src FastString
s)
| FastString -> Int
lengthFS FastString
s forall a. Ord a => a -> a -> Bool
<= Int
1
= forall l e. GenLocated l e -> e
unLoc forall a b. (a -> 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
src Char
c, GenLocated SrcSpanAnnA (Pat GhcTc)
pat] [Type
charTy])
(Type -> LPat GhcTc
mkNilPat Type
charTy) (FastString -> String
unpackFS FastString
s)
tidyLitPat HsLit GhcTc
lit = forall p. XLitPat p -> HsLit p -> Pat p
LitPat 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 Type
ty) OverLitVal
val HsExpr GhcTc
_) 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 (forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim 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 (forall x. XHsWordPrim x -> Integer -> HsLit x
HsWordPrim 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 (forall x. XHsString x -> FastString -> HsLit x
HsString SourceText
NoSourceText FastString
str_lit)
where
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
= forall l e. GenLocated l e -> e
unLoc (DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc
mkPrefixConPat DataCon
con [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p. XLitPat p -> HsLit p -> Pat p
LitPat NoExtField
noExtField HsLit GhcTc
lit] [])
mb_int_lit :: Maybe Integer
mb_int_lit :: Maybe Integer
mb_int_lit = case (Maybe (SyntaxExpr GhcTc)
mb_neg, OverLitVal
val) of
(Maybe SyntaxExprTc
Nothing, HsIntegral IntegralLit
i) -> forall a. a -> Maybe a
Just (IntegralLit -> Integer
il_value IntegralLit
i)
(Just SyntaxExprTc
_, HsIntegral IntegralLit
i) -> forall a. a -> Maybe a
Just (-(IntegralLit -> Integer
il_value IntegralLit
i))
(Maybe SyntaxExprTc, OverLitVal)
_ -> forall a. Maybe a
Nothing
mb_str_lit :: Maybe FastString
mb_str_lit :: Maybe FastString
mb_str_lit = case (Maybe (SyntaxExpr GhcTc)
mb_neg, OverLitVal
val) of
(Maybe SyntaxExprTc
Nothing, HsIsString SourceText
_ FastString
s) -> forall a. a -> Maybe a
Just FastString
s
(Maybe SyntaxExprTc, OverLitVal)
_ -> forall a. Maybe a
Nothing
tidyNPat HsOverLit GhcTc
over_lit Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq Type
outer_ty
= forall p.
XNPat p
-> XRec p (HsOverLit p)
-> Maybe (SyntaxExpr p)
-> SyntaxExpr p
-> Pat p
NPat Type
outer_ty (forall e. e -> Located e
noLoc HsOverLit GhcTc
over_lit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq
matchLiterals :: NonEmpty Id
-> Type
-> NonEmpty (NonEmpty EquationInfo)
-> 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 {
; NonEmpty (Literal, MatchResult CoreExpr)
alts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
match_group NonEmpty (NonEmpty EquationInfo)
sub_groups
; if Type -> Bool
isStringTy (Id -> Type
idType Id
var) then
do { Id
eq_str <- Name -> DsM Id
dsLookupGlobalId Name
eqStringName
; NonEmpty (MatchResult CoreExpr)
mrs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id -> (Literal, MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
wrap_str_guard Id
eq_str) NonEmpty (Literal, MatchResult CoreExpr)
alts
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 MatchResult CoreExpr
-> MatchResult CoreExpr -> MatchResult CoreExpr
combineMatchResults NonEmpty (MatchResult CoreExpr)
mrs) }
else
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
-> Type
-> [(Literal, MatchResult CoreExpr)]
-> MatchResult CoreExpr
mkCoPrimCaseMatchResult Id
var Type
ty forall a b. (a -> b) -> a -> b
$ 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 -> DsM (Literal, MatchResult CoreExpr)
match_group eqns :: NonEmpty EquationInfo
eqns@(EquationInfo
firstEqn :| [EquationInfo]
_)
= do { DynFlags
dflags <- 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 (forall a. NonEmpty a -> [a]
NEL.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Functor f => f EquationInfo -> f EquationInfo
shiftEqns NonEmpty EquationInfo
eqns)
; 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)
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
; CoreExpr
lit <- forall (m :: * -> *). MonadThings m => FastString -> m CoreExpr
mkStringExprFS FastString
s'
; let pred :: CoreExpr
pred = forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
eq_str) [forall b. Id -> Expr b
Var Id
var, CoreExpr
lit]
; 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
_) = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchLiterals/wrap_str_guard" (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
_ (HsInt64Prim XHsInt64Prim GhcTc
_ Integer
i) = Integer -> Literal
mkLitInt64Wrap Integer
i
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 = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"hsLitKey" (forall a. Outputable a => a -> SDoc
ppr HsLit GhcTc
l)
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)
= do { let NPat XNPat GhcTc
_ (L SrcSpan
_ 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 -> 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 [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 (forall (f :: * -> *). Functor f => f EquationInfo -> f EquationInfo
shiftEqns (EquationInfo
eqn1forall a. a -> [a] -> [a]
:[EquationInfo]
eqns))
; forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkGuardedMatchResult CoreExpr
pred_expr MatchResult CoreExpr
match_result) }
matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
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 SrcSpan
_ 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 [forall b. Id -> Expr b
Var Id
var, CoreExpr
lit1_expr]
; CoreExpr
minusk_expr <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
minus [forall b. Id -> Expr b
Var Id
var, CoreExpr
lit2_expr]
; let ([CoreExpr -> CoreExpr]
wraps, [EquationInfo]
eqns') = forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip (Id -> EquationInfo -> (CoreExpr -> CoreExpr, EquationInfo)
shift Id
n1) (EquationInfo
eqn1forall a. a -> [a] -> [a]
:[EquationInfo]
eqns)
; MatchResult CoreExpr
match_result <- [Id] -> Type -> [EquationInfo] -> DsM (MatchResult CoreExpr)
match [Id]
vars Type
ty [EquationInfo]
eqns'
; forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
mkGuardedMatchResult CoreExpr
pred_expr forall a b. (a -> b) -> a -> b
$
CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr
mkCoLetMatchResult (forall b. b -> Expr b -> Bind b
NonRec Id
n1 CoreExpr
minusk_expr) forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) [CoreExpr -> CoreExpr]
wraps) 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 :: [Pat GhcTc]
eqn_pats = [Pat GhcTc]
pats })
shift Id
_ EquationInfo
e = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchNPlusKPats/shift" (forall a. Outputable a => a -> SDoc
ppr EquationInfo
e)