{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module MatchLit ( dsLit, dsOverLit, hsLitKey
, tidyLitPat, tidyNPat
, matchLiterals, matchNPlusKPats, matchNPats
, warnAboutIdentities
, warnAboutOverflowedOverLit, warnAboutOverflowedLit
, warnAboutEmptyEnumerations
) where
#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} Match ( match )
import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr )
import DsMonad
import DsUtils
import GHC.Hs
import Id
import CoreSyn
import MkCore
import TyCon
import DataCon
import TcHsSyn ( shortCutLit )
import TcType
import Name
import Type
import PrelNames
import TysWiredIn
import TysPrim
import Literal
import SrcLoc
import Data.Ratio
import Outputable
import BasicTypes
import DynFlags
import Util
import FastString
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.Int
import Data.Word
import Data.Proxy
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
case HsLit GhcRn
l of
HsStringPrim XHsStringPrim GhcRn
_ ByteString
s -> CoreExpr -> DsM CoreExpr
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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Integer -> Literal
mkLitIntWrap DynFlags
dflags Integer
i))
HsWordPrim XHsWordPrim GhcRn
_ Integer
w -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Integer -> Literal
mkLitWordWrap DynFlags
dflags Integer
w))
HsInt64Prim XHsInt64Prim GhcRn
_ Integer
i -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Integer -> Literal
mkLitInt64Wrap DynFlags
dflags Integer
i))
HsWord64Prim XHsWord64Prim GhcRn
_ Integer
w -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (DynFlags -> Integer -> Literal
mkLitWord64Wrap DynFlags
dflags Integer
w))
HsFloatPrim XHsFloatPrim GhcRn
_ FractionalLit
f -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Rational -> Literal
LitFloat (FractionalLit -> Rational
fl_value FractionalLit
f)))
HsDoublePrim XHsDoublePrim GhcRn
_ FractionalLit
d -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (Rational -> Literal
LitDouble (FractionalLit -> Rational
fl_value FractionalLit
d)))
HsChar XHsChar GhcRn
_ Char
c -> CoreExpr -> DsM CoreExpr
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
_ -> Integer -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => Integer -> m CoreExpr
mkIntegerExpr Integer
i
HsInt XHsInt GhcRn
_ IntegralLit
i -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Integer -> CoreExpr
mkIntExpr DynFlags
dflags (IntegralLit -> Integer
il_value IntegralLit
i))
XLit XXLit GhcRn
nec -> NoExtCon -> DsM CoreExpr
forall a. NoExtCon -> a
noExtCon XXLit GhcRn
NoExtCon
nec
HsRat XHsRat GhcRn
_ (FL SourceText
_ Bool
_ Rational
val) Type
ty -> do
CoreExpr
num <- Integer -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => Integer -> m CoreExpr
mkIntegerExpr (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
val)
CoreExpr
denom <- Integer -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => Integer -> m CoreExpr
mkIntegerExpr (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
val)
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
ratio_data_con [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
integer_ty, CoreExpr
num, CoreExpr
denom])
where
(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)
([DataCon] -> DataCon
forall a. [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)
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 rebindable ty
, ol_witness :: forall p. HsOverLit p -> HsExpr p
ol_witness = HsExpr GhcTc
witness }) = do
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case DynFlags -> OverLitVal -> Type -> Maybe (HsExpr GhcTc)
shortCutLit DynFlags
dflags 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
dsOverLit (XOverLit XXOverLit GhcTc
nec) = NoExtCon -> DsM CoreExpr
forall a. NoExtCon -> a
noExtCon XXOverLit GhcTc
NoExtCon
nec
warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
warnAboutIdentities DynFlags
dflags (Var 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
conversionNames
, Just (Type
arg_ty, Type
res_ty) <- Type -> Maybe (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
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
conv_fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
type_of_conv
, Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"can probably be omitted"
])
warnAboutIdentities DynFlags
_ CoreExpr
_ Type
_ = () -> DsM ()
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 <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DynFlags -> Maybe (Integer, Name) -> DsM ()
warnAboutOverflowedLiterals DynFlags
dflags (HsOverLit GhcTc -> Maybe (Integer, Name)
getIntegralLit HsOverLit GhcTc
hsOverLit)
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 (HsLit GhcTc -> Maybe (Integer, Name)
getSimpleIntegralLit HsLit GhcTc
hsLit)
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
intTyConName then Integer -> Name -> Proxy Int -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Int
forall k (t :: k). Proxy t
Proxy :: Proxy Int)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int8TyConName then Integer -> Name -> Proxy Int8 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Int8
forall k (t :: k). Proxy t
Proxy :: Proxy Int8)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int16TyConName then Integer -> Name -> Proxy Int16 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Int16
forall k (t :: k). Proxy t
Proxy :: Proxy Int16)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int32TyConName then Integer -> Name -> Proxy Int32 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Int32
forall k (t :: k). Proxy t
Proxy :: Proxy Int32)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int64TyConName then Integer -> Name -> Proxy Int64 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Int64
forall k (t :: k). Proxy t
Proxy :: Proxy Int64)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
wordTyConName then Integer -> Name -> Proxy Word -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Word
forall k (t :: k). Proxy t
Proxy :: Proxy Word)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word8TyConName then Integer -> Name -> Proxy Word8 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Word8
forall k (t :: k). Proxy t
Proxy :: Proxy Word8)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word16TyConName then Integer -> Name -> Proxy Word16 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Word16
forall k (t :: k). Proxy t
Proxy :: Proxy Word16)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word32TyConName then Integer -> Name -> Proxy Word32 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Word32
forall k (t :: k). Proxy t
Proxy :: Proxy Word32)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word64TyConName then Integer -> Name -> Proxy Word64 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Word64
forall k (t :: k). Proxy t
Proxy :: Proxy Word64)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
naturalTyConName then Integer -> Name -> DsM ()
checkPositive Integer
i Name
tc
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
intPrimTyConName then Integer -> Name -> Proxy Int -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Int
forall k (t :: k). Proxy t
Proxy :: Proxy Int)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int8PrimTyConName then Integer -> Name -> Proxy Int8 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Int8
forall k (t :: k). Proxy t
Proxy :: Proxy Int8)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int32PrimTyConName then Integer -> Name -> Proxy Int32 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Int32
forall k (t :: k). Proxy t
Proxy :: Proxy Int32)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int64PrimTyConName then Integer -> Name -> Proxy Int64 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Int64
forall k (t :: k). Proxy t
Proxy :: Proxy Int64)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
wordPrimTyConName then Integer -> Name -> Proxy Word -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Word
forall k (t :: k). Proxy t
Proxy :: Proxy Word)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word8PrimTyConName then Integer -> Name -> Proxy Word8 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Word8
forall k (t :: k). Proxy t
Proxy :: Proxy Word8)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word32PrimTyConName then Integer -> Name -> Proxy Word32 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Word32
forall k (t :: k). Proxy t
Proxy :: Proxy Word32)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word64PrimTyConName then Integer -> Name -> Proxy Word64 -> DsM ()
forall a.
(Bounded a, Integral a) =>
Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc (Proxy Word64
forall k (t :: k). Proxy t
Proxy :: Proxy Word64)
else () -> DsM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = () -> DsM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
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
$ do
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
<+> Name -> 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 :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
check :: Integer -> Name -> Proxy a -> DsM ()
check Integer
i Name
tc Proxy a
_proxy
= 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
$ do
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
<+> Name -> 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
minB :: Integer
minB = a -> Integer
forall a. Integral a => a -> Integer
toInteger (a
forall a. Bounded a => a
minBound :: a)
maxB :: Integer
maxB = a -> Integer
forall a. Integral a => a -> Integer
toInteger (a
forall a. Bounded a => a
maxBound :: a)
sug :: SDoc
sug | Integer
minB Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
i
, Integer
i Integer -> Integer -> Bool
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 :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc -> DsM ()
warnAboutEmptyEnumerations :: DynFlags
-> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> DsM ()
warnAboutEmptyEnumerations DynFlags
dflags LHsExpr GhcTc
fromExpr Maybe (LHsExpr GhcTc)
mThnExpr LHsExpr GhcTc
toExpr
| WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnEmptyEnumerations DynFlags
dflags
, Just (Integer
from,Name
tc) <- LHsExpr GhcTc -> Maybe (Integer, Name)
getLHsIntegralLit LHsExpr GhcTc
fromExpr
, Just Maybe (Integer, Name)
mThn <- (LHsExpr GhcTc -> Maybe (Integer, Name))
-> Maybe (LHsExpr GhcTc) -> Maybe (Maybe (Integer, Name))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LHsExpr GhcTc -> Maybe (Integer, Name)
getLHsIntegralLit Maybe (LHsExpr GhcTc)
mThnExpr
, Just (Integer
to,Name
_) <- LHsExpr GhcTc -> Maybe (Integer, Name)
getLHsIntegralLit LHsExpr GhcTc
toExpr
, let check :: forall a. (Enum a, Num a) => Proxy a -> DsM ()
check :: Proxy a -> DsM ()
check Proxy a
_proxy
= Bool -> DsM () -> DsM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
enumeration) (DsM () -> DsM ()) -> DsM () -> DsM ()
forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> DsM ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnEmptyEnumerations) (String -> SDoc
text String
"Enumeration is empty")
where
enumeration :: [a]
enumeration :: [a]
enumeration = case Maybe (Integer, Name)
mThn of
Maybe (Integer, Name)
Nothing -> [Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
from .. Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
to]
Just (Integer
thn,Name
_) -> [Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
from, Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
thn .. Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
to]
= if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
intTyConName then Proxy Int -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Int
forall k (t :: k). Proxy t
Proxy :: Proxy Int)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int8TyConName then Proxy Int8 -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Int8
forall k (t :: k). Proxy t
Proxy :: Proxy Int8)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int16TyConName then Proxy Int16 -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Int16
forall k (t :: k). Proxy t
Proxy :: Proxy Int16)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int32TyConName then Proxy Int32 -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Int32
forall k (t :: k). Proxy t
Proxy :: Proxy Int32)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
int64TyConName then Proxy Int64 -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Int64
forall k (t :: k). Proxy t
Proxy :: Proxy Int64)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
wordTyConName then Proxy Word -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Word
forall k (t :: k). Proxy t
Proxy :: Proxy Word)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word8TyConName then Proxy Word8 -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Word8
forall k (t :: k). Proxy t
Proxy :: Proxy Word8)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word16TyConName then Proxy Word16 -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Word16
forall k (t :: k). Proxy t
Proxy :: Proxy Word16)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word32TyConName then Proxy Word32 -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Word32
forall k (t :: k). Proxy t
Proxy :: Proxy Word32)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
word64TyConName then Proxy Word64 -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Word64
forall k (t :: k). Proxy t
Proxy :: Proxy Word64)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
integerTyConName then Proxy Integer -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Integer
forall k (t :: k). Proxy t
Proxy :: Proxy Integer)
else if Name
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
naturalTyConName then Proxy Integer -> DsM ()
forall a. (Enum a, Num a) => Proxy a -> DsM ()
check (Proxy Integer
forall k (t :: k). Proxy t
Proxy :: Proxy Integer)
else () -> DsM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = () -> DsM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
getLHsIntegralLit (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsPar _ e)) = LHsExpr GhcTc -> Maybe (Integer, Name)
getLHsIntegralLit LHsExpr GhcTc
e
getLHsIntegralLit (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsTick _ _ e)) = LHsExpr GhcTc -> Maybe (Integer, Name)
getLHsIntegralLit LHsExpr GhcTc
e
getLHsIntegralLit (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsBinTick _ _ _ e)) = LHsExpr GhcTc -> Maybe (Integer, Name)
getLHsIntegralLit LHsExpr GhcTc
e
getLHsIntegralLit (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsOverLit _ over_lit)) = HsOverLit GhcTc -> Maybe (Integer, Name)
getIntegralLit HsOverLit GhcTc
over_lit
getLHsIntegralLit (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsLit _ lit)) = HsLit GhcTc -> Maybe (Integer, Name)
getSimpleIntegralLit HsLit GhcTc
lit
getLHsIntegralLit LHsExpr GhcTc
_ = Maybe (Integer, Name)
forall a. Maybe a
Nothing
getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
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 _ ty })
| Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty
= (Integer, Name) -> Maybe (Integer, Name)
forall a. a -> Maybe a
Just (IntegralLit -> Integer
il_value IntegralLit
i, TyCon -> Name
tyConName TyCon
tc)
getIntegralLit HsOverLit GhcTc
_ = Maybe (Integer, Name)
forall a. Maybe a
Nothing
getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)
getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)
getSimpleIntegralLit (HsInt XHsInt GhcTc
_ IL{ il_value :: IntegralLit -> Integer
il_value = Integer
i }) = (Integer, Name) -> Maybe (Integer, Name)
forall a. a -> Maybe a
Just (Integer
i, Name
intTyConName)
getSimpleIntegralLit (HsIntPrim XHsIntPrim GhcTc
_ Integer
i) = (Integer, Name) -> Maybe (Integer, Name)
forall a. a -> Maybe a
Just (Integer
i, Name
intPrimTyConName)
getSimpleIntegralLit (HsWordPrim XHsWordPrim GhcTc
_ Integer
i) = (Integer, Name) -> Maybe (Integer, Name)
forall a. a -> Maybe a
Just (Integer
i, Name
wordPrimTyConName)
getSimpleIntegralLit (HsInt64Prim XHsInt64Prim GhcTc
_ Integer
i) = (Integer, Name) -> Maybe (Integer, Name)
forall a. a -> Maybe a
Just (Integer
i, Name
int64PrimTyConName)
getSimpleIntegralLit (HsWord64Prim XHsWord64Prim GhcTc
_ Integer
i) = (Integer, Name) -> Maybe (Integer, Name)
forall a. a -> Maybe a
Just (Integer
i, Name
word64PrimTyConName)
getSimpleIntegralLit (HsInteger XHsInteger GhcTc
_ 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)
getSimpleIntegralLit HsLit GhcTc
_ = 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) = Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (SourceText -> Char -> OutPat GhcTc
forall (p :: Pass). SourceText -> Char -> OutPat (GhcPass p)
mkCharLitPat SourceText
XHsChar GhcTc
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
= Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc)))
-> Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a b. (a -> b) -> a -> b
$ (Char -> Located (Pat GhcTc) -> Located (Pat GhcTc))
-> Located (Pat GhcTc) -> String -> Located (Pat GhcTc)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
c Located (Pat GhcTc)
pat -> DataCon -> [OutPat GhcTc] -> [Type] -> OutPat GhcTc
forall (p :: Pass).
DataCon -> [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)
mkPrefixConPat DataCon
consDataCon
[SourceText -> Char -> OutPat GhcTc
forall (p :: Pass). SourceText -> Char -> OutPat (GhcPass p)
mkCharLitPat SourceText
XHsString GhcTc
src Char
c, Located (Pat GhcTc)
OutPat GhcTc
pat] [Type
charTy])
(Type -> OutPat GhcTc
forall (p :: Pass). Type -> OutPat (GhcPass p)
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 False 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 (XHsIntPrim GhcTc -> Integer -> HsLit GhcTc
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
XHsIntPrim GhcTc
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 SourceText
XHsWordPrim GhcTc
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 SourceText
XHsString GhcTc
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
= Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (DataCon -> [OutPat GhcTc] -> [Type] -> OutPat GhcTc
forall (p :: Pass).
DataCon -> [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)
mkPrefixConPat DataCon
con [SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc))
-> SrcSpanLess (Located (Pat GhcTc)) -> Located (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)
mb_neg, OverLitVal
val) of
(Maybe (SyntaxExpr GhcTc)
Nothing, HsIntegral IntegralLit
i) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (IntegralLit -> Integer
il_value IntegralLit
i)
(Just SyntaxExpr GhcTc
_, HsIntegral IntegralLit
i) -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (-(IntegralLit -> Integer
il_value IntegralLit
i))
(Maybe (SyntaxExpr GhcTc), 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)
mb_neg, OverLitVal
val) of
(Maybe (SyntaxExpr GhcTc)
Nothing, HsIsString SourceText
_ FastString
s) -> FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
s
(Maybe (SyntaxExpr GhcTc), 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
-> Located (HsOverLit GhcTc)
-> Maybe (SyntaxExpr GhcTc)
-> SyntaxExpr GhcTc
-> Pat GhcTc
forall p.
XNPat p
-> Located (HsOverLit p)
-> Maybe (SyntaxExpr p)
-> SyntaxExpr p
-> Pat p
NPat Type
XNPat GhcTc
outer_ty (SrcSpanLess (Located (HsOverLit GhcTc))
-> Located (HsOverLit GhcTc)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located (HsOverLit GhcTc))
HsOverLit GhcTc
over_lit) Maybe (SyntaxExpr GhcTc)
mb_neg SyntaxExpr GhcTc
eq
matchLiterals :: [Id]
-> Type
-> [[EquationInfo]]
-> DsM MatchResult
matchLiterals :: [Id] -> Type -> [[EquationInfo]] -> DsM MatchResult
matchLiterals (Id
var:[Id]
vars) Type
ty [[EquationInfo]]
sub_groups
= ASSERT( notNull sub_groups && all notNull sub_groups )
do {
; [(Literal, MatchResult)]
alts <- ([EquationInfo]
-> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult))
-> [[EquationInfo]]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Literal, MatchResult)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [EquationInfo]
-> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult)
match_group [[EquationInfo]]
sub_groups
; if Type -> Bool
isStringTy (Id -> Type
idType Id
var) then
do { Id
eq_str <- Name -> DsM Id
dsLookupGlobalId Name
eqStringName
; [MatchResult]
mrs <- ((Literal, MatchResult) -> DsM MatchResult)
-> [(Literal, MatchResult)]
-> IOEnv (Env DsGblEnv DsLclEnv) [MatchResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id -> (Literal, MatchResult) -> DsM MatchResult
wrap_str_guard Id
eq_str) [(Literal, MatchResult)]
alts
; MatchResult -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return ((MatchResult -> MatchResult -> MatchResult)
-> [MatchResult] -> MatchResult
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 MatchResult -> MatchResult -> MatchResult
combineMatchResults [MatchResult]
mrs) }
else
MatchResult -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Type -> [(Literal, MatchResult)] -> MatchResult
mkCoPrimCaseMatchResult Id
var Type
ty [(Literal, MatchResult)]
alts)
}
where
match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
match_group :: [EquationInfo]
-> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult)
match_group [EquationInfo]
eqns
= do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let LitPat XLitPat GhcTc
_ HsLit GhcTc
hs_lit = EquationInfo -> Pat GhcTc
firstPat ([EquationInfo] -> EquationInfo
forall a. [a] -> a
head [EquationInfo]
eqns)
; MatchResult
match_result <- [Id] -> Type -> [EquationInfo] -> DsM MatchResult
match [Id]
vars Type
ty ([EquationInfo] -> [EquationInfo]
shiftEqns [EquationInfo]
eqns)
; (Literal, MatchResult)
-> IOEnv (Env DsGblEnv DsLclEnv) (Literal, MatchResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> HsLit GhcTc -> Literal
hsLitKey DynFlags
dflags HsLit GhcTc
hs_lit, MatchResult
match_result) }
wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
wrap_str_guard :: Id -> (Literal, MatchResult) -> DsM MatchResult
wrap_str_guard Id
eq_str (LitString ByteString
s, MatchResult
mr)
= do {
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 -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult CoreExpr
pred MatchResult
mr) }
wrap_str_guard Id
_ (Literal
l, MatchResult
_) = String -> SDoc -> DsM MatchResult
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchLiterals/wrap_str_guard" (Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
l)
matchLiterals [] Type
_ [[EquationInfo]]
_ = String -> DsM MatchResult
forall a. String -> a
panic String
"matchLiterals []"
hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
hsLitKey DynFlags
dflags (HsIntPrim XHsIntPrim GhcTc
_ Integer
i) = DynFlags -> Integer -> Literal
mkLitIntWrap DynFlags
dflags Integer
i
hsLitKey DynFlags
dflags (HsWordPrim XHsWordPrim GhcTc
_ Integer
w) = DynFlags -> Integer -> Literal
mkLitWordWrap DynFlags
dflags Integer
w
hsLitKey DynFlags
dflags (HsInt64Prim XHsInt64Prim GhcTc
_ Integer
i) = DynFlags -> Integer -> Literal
mkLitInt64Wrap DynFlags
dflags Integer
i
hsLitKey DynFlags
dflags (HsWord64Prim XHsWord64Prim GhcTc
_ Integer
w) = DynFlags -> Integer -> Literal
mkLitWord64Wrap DynFlags
dflags Integer
w
hsLitKey DynFlags
_ (HsCharPrim XHsCharPrim GhcTc
_ Char
c) = Char -> Literal
mkLitChar Char
c
hsLitKey DynFlags
_ (HsFloatPrim XHsFloatPrim GhcTc
_ FractionalLit
f) = Rational -> Literal
mkLitFloat (FractionalLit -> Rational
fl_value FractionalLit
f)
hsLitKey DynFlags
_ (HsDoublePrim XHsDoublePrim GhcTc
_ FractionalLit
d) = Rational -> Literal
mkLitDouble (FractionalLit -> Rational
fl_value FractionalLit
d)
hsLitKey DynFlags
_ (HsString XHsString GhcTc
_ FastString
s) = ByteString -> Literal
LitString (FastString -> ByteString
bytesFS FastString
s)
hsLitKey DynFlags
_ 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 :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPats (Id
var:[Id]
vars) Type
ty (EquationInfo
eqn1:[EquationInfo]
eqns)
= do { let NPat XNPat GhcTc
_ (Located (HsOverLit GhcTc)
-> Located (SrcSpanLess (Located (HsOverLit GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (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 (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
match_result <- [Id] -> Type -> [EquationInfo] -> DsM MatchResult
match [Id]
vars Type
ty ([EquationInfo] -> [EquationInfo]
shiftEqns (EquationInfo
eqn1EquationInfo -> [EquationInfo] -> [EquationInfo]
forall a. a -> [a] -> [a]
:[EquationInfo]
eqns))
; MatchResult -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult CoreExpr
pred_expr MatchResult
match_result) }
matchNPats [Id]
vars Type
_ [EquationInfo]
eqns = String -> SDoc -> DsM MatchResult
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchOneNPat" (([Id], [EquationInfo]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Id]
vars, [EquationInfo]
eqns))
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchNPlusKPats (Id
var:[Id]
vars) Type
ty (EquationInfo
eqn1:[EquationInfo]
eqns)
= do { let NPlusKPat XNPlusKPat GhcTc
_ (Located (IdP GhcTc) -> Located (SrcSpanLess (Located Id))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Id)
n1) (Located (HsOverLit GhcTc)
-> Located (SrcSpanLess (Located (HsOverLit GhcTc)))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located (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
match_result <- [Id] -> Type -> [EquationInfo] -> DsM MatchResult
match [Id]
vars Type
ty [EquationInfo]
eqns'
; MatchResult -> DsM MatchResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult CoreExpr
pred_expr (MatchResult -> MatchResult) -> MatchResult -> MatchResult
forall a b. (a -> b) -> a -> b
$
CoreBind -> MatchResult -> MatchResult
mkCoLetMatchResult (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
n1 CoreExpr
minusk_expr) (MatchResult -> MatchResult) -> MatchResult -> MatchResult
forall a b. (a -> b) -> a -> b
$
(CoreExpr -> CoreExpr) -> MatchResult -> MatchResult
adjustMatchResult (((CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr
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 -> MatchResult) -> MatchResult -> MatchResult
forall a b. (a -> b) -> a -> b
$
MatchResult
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
_ (Located (IdP GhcTc) -> Located (SrcSpanLess (Located Id))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Id)
n) Located (HsOverLit GhcTc)
_ HsOverLit GhcTc
_ SyntaxExpr GhcTc
_ SyntaxExpr GhcTc
_ : [Pat GhcTc]
pats })
= (Id -> Id -> CoreExpr -> CoreExpr
wrapBind SrcSpanLess (Located Id)
Id
n Id
n1, EquationInfo
eqn { eqn_pats :: [Pat GhcTc]
eqn_pats = [Pat GhcTc]
pats })
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)
matchNPlusKPats [Id]
vars Type
_ [EquationInfo]
eqns = String -> SDoc -> DsM MatchResult
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"matchNPlusKPats" (([Id], [EquationInfo]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Id]
vars, [EquationInfo]
eqns))