{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.HsToCore.Pmc.Solver.Types (
BotInfo(..), PmAltConApp(..), VarInfo(..), TmState(..), TyState(..),
Nabla(..), Nablas(..), initNablas,
lookupRefuts, lookupSolution,
lookupVarInfo, lookupVarInfoNT, trvVarInfo,
CompleteMatch, ResidualCompleteMatches(..), getRcm, isRcmInitialised,
PmLit(..), PmLitValue(..), PmAltCon(..), pmLitType, pmAltConType,
isPmAltConMatchStrict, pmAltConImplBangs,
PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet,
extendPmAltConSet, pmAltConSetElems,
PmEquality(..), eqPmAltCon,
literalToPmLit, negatePmLit, overloadPmLit,
pmLitAsStringLit, coreExprAsPmLit
) where
import GHC.Prelude
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Types.Id
import GHC.Types.Var.Set
import GHC.Types.Unique.DSet
import GHC.Types.Unique.SDFM
import GHC.Types.Name
import GHC.Core.DataCon
import GHC.Core.ConLike
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc (lastMaybe)
import GHC.Data.List.SetOps (unionLists)
import GHC.Data.Maybe
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Types.Literal
import GHC.Core
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.Map.Expr
import GHC.Core.Utils (exprType)
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Tc.Solver.InertSet (InertSet, emptyInert)
import GHC.Tc.Utils.TcType (isStringTy)
import GHC.Types.CompleteMatch (CompleteMatch(..))
import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit
, fractionalLitFromRational
, FractionalExponentBase(..))
import Numeric (fromRat)
import Data.Foldable (find)
import Data.Ratio
import GHC.Real (Ratio(..))
import qualified Data.Semigroup as Semi
data Nabla
= MkNabla
{ Nabla -> TyState
nabla_ty_st :: !TyState
, Nabla -> TmState
nabla_tm_st :: !TmState
}
initNabla :: Nabla
initNabla :: Nabla
initNabla = TyState -> TmState -> Nabla
MkNabla TyState
initTyState TmState
initTmState
instance Outputable Nabla where
ppr :: Nabla -> SDoc
ppr Nabla
nabla = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Nabla") Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
TmState -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Nabla -> TmState
nabla_tm_st Nabla
nabla),
TyState -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Nabla -> TyState
nabla_ty_st Nabla
nabla)
]
newtype Nablas = MkNablas (Bag Nabla)
initNablas :: Nablas
initNablas :: Nablas
initNablas = Bag Nabla -> Nablas
MkNablas (Nabla -> Bag Nabla
forall a. a -> Bag a
unitBag Nabla
initNabla)
instance Outputable Nablas where
ppr :: Nablas -> SDoc
ppr (MkNablas Bag Nabla
nablas) = Bag Nabla -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag Nabla
nablas
instance Semigroup Nablas where
MkNablas Bag Nabla
l <> :: Nablas -> Nablas -> Nablas
<> MkNablas Bag Nabla
r = Bag Nabla -> Nablas
MkNablas (Bag Nabla
l Bag Nabla -> Bag Nabla -> Bag Nabla
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag Nabla
r)
instance Monoid Nablas where
mempty :: Nablas
mempty = Bag Nabla -> Nablas
MkNablas Bag Nabla
forall a. Bag a
emptyBag
data TyState = TySt { TyState -> Int
ty_st_n :: !Int, TyState -> InertSet
ty_st_inert :: !InertSet }
instance Outputable TyState where
ppr :: TyState -> SDoc
ppr (TySt Int
n InertSet
inert) = Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InertSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr InertSet
inert
initTyState :: TyState
initTyState :: TyState
initTyState = Int -> InertSet -> TyState
TySt Int
0 InertSet
emptyInert
data TmState
= TmSt
{ TmState -> UniqSDFM Id VarInfo
ts_facts :: !(UniqSDFM Id VarInfo)
, TmState -> CoreMap Id
ts_reps :: !(CoreMap Id)
, TmState -> DIdSet
ts_dirty :: !DIdSet
}
data VarInfo
= VI
{ VarInfo -> Id
vi_id :: !Id
, VarInfo -> [PmAltConApp]
vi_pos :: ![PmAltConApp]
, VarInfo -> PmAltConSet
vi_neg :: !PmAltConSet
, VarInfo -> BotInfo
vi_bot :: BotInfo
, VarInfo -> ResidualCompleteMatches
vi_rcm :: !ResidualCompleteMatches
}
data PmAltConApp
= PACA
{ PmAltConApp -> PmAltCon
paca_con :: !PmAltCon
, PmAltConApp -> [Id]
paca_tvs :: ![TyVar]
, PmAltConApp -> [Id]
paca_ids :: ![Id]
}
data BotInfo
= IsBot
| IsNotBot
| MaybeBot
deriving BotInfo -> BotInfo -> Bool
(BotInfo -> BotInfo -> Bool)
-> (BotInfo -> BotInfo -> Bool) -> Eq BotInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BotInfo -> BotInfo -> Bool
== :: BotInfo -> BotInfo -> Bool
$c/= :: BotInfo -> BotInfo -> Bool
/= :: BotInfo -> BotInfo -> Bool
Eq
instance Outputable PmAltConApp where
ppr :: PmAltConApp -> SDoc
ppr PACA{paca_con :: PmAltConApp -> PmAltCon
paca_con = PmAltCon
con, paca_tvs :: PmAltConApp -> [Id]
paca_tvs = [Id]
tvs, paca_ids :: PmAltConApp -> [Id]
paca_ids = [Id]
ids} =
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep (PmAltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmAltCon
con SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'@' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>) (SDoc -> SDoc) -> (Id -> SDoc) -> Id -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [Id]
tvs [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ (Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
ids)
instance Outputable BotInfo where
ppr :: BotInfo -> SDoc
ppr BotInfo
MaybeBot = SDoc
forall doc. IsLine doc => doc
underscore
ppr BotInfo
IsBot = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"~⊥"
ppr BotInfo
IsNotBot = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"≁⊥"
instance Outputable TmState where
ppr :: TmState -> SDoc
ppr (TmSt UniqSDFM Id VarInfo
state CoreMap Id
reps DIdSet
dirty) = UniqSDFM Id VarInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqSDFM Id VarInfo
state SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CoreMap Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreMap Id
reps SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ DIdSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr DIdSet
dirty
instance Outputable VarInfo where
ppr :: VarInfo -> SDoc
ppr (VI Id
x [PmAltConApp]
pos PmAltConSet
neg BotInfo
bot ResidualCompleteMatches
cache)
= SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc
pp_x, SDoc
pp_pos, SDoc
pp_neg, BotInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr BotInfo
bot, SDoc
pp_cache]))
where
pp_x :: SDoc
pp_x = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
x)
pp_pos :: SDoc
pp_pos
| [] <- [PmAltConApp]
pos = SDoc
forall doc. IsLine doc => doc
underscore
| [PmAltConApp
p] <- [PmAltConApp]
pos = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'~' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> PmAltConApp -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmAltConApp
p
| Bool
otherwise = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'~' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [PmAltConApp] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PmAltConApp]
pos
pp_neg :: SDoc
pp_neg
| PmAltConSet -> Bool
isEmptyPmAltConSet PmAltConSet
neg = SDoc
forall doc. IsLine doc => doc
underscore
| Bool
otherwise = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'≁' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> PmAltConSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmAltConSet
neg
pp_cache :: SDoc
pp_cache
| RCM Maybe CompleteMatch
Nothing Maybe [CompleteMatch]
Nothing <- ResidualCompleteMatches
cache = SDoc
forall doc. IsLine doc => doc
underscore
| Bool
otherwise = ResidualCompleteMatches -> SDoc
forall a. Outputable a => a -> SDoc
ppr ResidualCompleteMatches
cache
initTmState :: TmState
initTmState :: TmState
initTmState = UniqSDFM Id VarInfo -> CoreMap Id -> DIdSet -> TmState
TmSt UniqSDFM Id VarInfo
forall key ele. UniqSDFM key ele
emptyUSDFM CoreMap Id
forall a. CoreMap a
emptyCoreMap DIdSet
emptyDVarSet
data ResidualCompleteMatches
= RCM
{ ResidualCompleteMatches -> Maybe CompleteMatch
rcm_vanilla :: !(Maybe CompleteMatch)
, ResidualCompleteMatches -> Maybe [CompleteMatch]
rcm_pragmas :: !(Maybe [CompleteMatch])
}
getRcm :: ResidualCompleteMatches -> [CompleteMatch]
getRcm :: ResidualCompleteMatches -> [CompleteMatch]
getRcm (RCM Maybe CompleteMatch
vanilla Maybe [CompleteMatch]
pragmas) = Maybe CompleteMatch -> [CompleteMatch]
forall a. Maybe a -> [a]
maybeToList Maybe CompleteMatch
vanilla [CompleteMatch] -> [CompleteMatch] -> [CompleteMatch]
forall a. [a] -> [a] -> [a]
++ [CompleteMatch] -> Maybe [CompleteMatch] -> [CompleteMatch]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [CompleteMatch]
pragmas
isRcmInitialised :: ResidualCompleteMatches -> Bool
isRcmInitialised :: ResidualCompleteMatches -> Bool
isRcmInitialised (RCM Maybe CompleteMatch
vanilla Maybe [CompleteMatch]
pragmas) = Maybe CompleteMatch -> Bool
forall a. Maybe a -> Bool
isJust Maybe CompleteMatch
vanilla Bool -> Bool -> Bool
&& Maybe [CompleteMatch] -> Bool
forall a. Maybe a -> Bool
isJust Maybe [CompleteMatch]
pragmas
instance Outputable ResidualCompleteMatches where
ppr :: ResidualCompleteMatches -> SDoc
ppr ResidualCompleteMatches
rcm = [CompleteMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ResidualCompleteMatches -> [CompleteMatch]
getRcm ResidualCompleteMatches
rcm)
emptyRCM :: ResidualCompleteMatches
emptyRCM :: ResidualCompleteMatches
emptyRCM = Maybe CompleteMatch
-> Maybe [CompleteMatch] -> ResidualCompleteMatches
RCM Maybe CompleteMatch
forall a. Maybe a
Nothing Maybe [CompleteMatch]
forall a. Maybe a
Nothing
emptyVarInfo :: Id -> VarInfo
emptyVarInfo :: Id -> VarInfo
emptyVarInfo Id
x
= VI
{ vi_id :: Id
vi_id = Id
x
, vi_pos :: [PmAltConApp]
vi_pos = []
, vi_neg :: PmAltConSet
vi_neg = PmAltConSet
emptyPmAltConSet
, vi_bot :: BotInfo
vi_bot = BotInfo
MaybeBot
, vi_rcm :: ResidualCompleteMatches
vi_rcm = ResidualCompleteMatches
emptyRCM
}
lookupVarInfo :: TmState -> Id -> VarInfo
lookupVarInfo :: TmState -> Id -> VarInfo
lookupVarInfo (TmSt UniqSDFM Id VarInfo
env CoreMap Id
_ DIdSet
_) Id
x = VarInfo -> Maybe VarInfo -> VarInfo
forall a. a -> Maybe a -> a
fromMaybe (Id -> VarInfo
emptyVarInfo Id
x) (UniqSDFM Id VarInfo -> Id -> Maybe VarInfo
forall key ele.
Uniquable key =>
UniqSDFM key ele -> key -> Maybe ele
lookupUSDFM UniqSDFM Id VarInfo
env Id
x)
lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo)
lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo)
lookupVarInfoNT TmState
ts Id
x = case TmState -> Id -> VarInfo
lookupVarInfo TmState
ts Id
x of
VI{ vi_pos :: VarInfo -> [PmAltConApp]
vi_pos = [PmAltConApp] -> Maybe Id
as_newtype -> Just Id
y } -> TmState -> Id -> (Id, VarInfo)
lookupVarInfoNT TmState
ts Id
y
VarInfo
res -> (Id
x, VarInfo
res)
where
as_newtype :: [PmAltConApp] -> Maybe Id
as_newtype = [Id] -> Maybe Id
forall a. [a] -> Maybe a
listToMaybe ([Id] -> Maybe Id)
-> ([PmAltConApp] -> [Id]) -> [PmAltConApp] -> Maybe Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PmAltConApp -> Maybe Id) -> [PmAltConApp] -> [Id]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PmAltConApp -> Maybe Id
go
go :: PmAltConApp -> Maybe Id
go PACA{paca_con :: PmAltConApp -> PmAltCon
paca_con = PmAltConLike (RealDataCon DataCon
dc), paca_ids :: PmAltConApp -> [Id]
paca_ids = [Id
y]}
| DataCon -> Bool
isNewDataCon DataCon
dc = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
y
go PmAltConApp
_ = Maybe Id
forall a. Maybe a
Nothing
trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)
trvVarInfo :: forall (f :: * -> *) a.
Functor f =>
(VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)
trvVarInfo VarInfo -> f (a, VarInfo)
f nabla :: Nabla
nabla@MkNabla{ nabla_tm_st :: Nabla -> TmState
nabla_tm_st = ts :: TmState
ts@TmSt{ts_facts :: TmState -> UniqSDFM Id VarInfo
ts_facts = UniqSDFM Id VarInfo
env} } Id
x
= (a, VarInfo) -> (a, Nabla)
set_vi ((a, VarInfo) -> (a, Nabla)) -> f (a, VarInfo) -> f (a, Nabla)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VarInfo -> f (a, VarInfo)
f (TmState -> Id -> VarInfo
lookupVarInfo TmState
ts Id
x)
where
set_vi :: (a, VarInfo) -> (a, Nabla)
set_vi (a
a, VarInfo
vi') =
(a
a, Nabla
nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } })
lookupRefuts :: Nabla -> Id -> [PmAltCon]
lookupRefuts :: Nabla -> Id -> [PmAltCon]
lookupRefuts MkNabla{ nabla_tm_st :: Nabla -> TmState
nabla_tm_st = TmState
ts } Id
x =
PmAltConSet -> [PmAltCon]
pmAltConSetElems (PmAltConSet -> [PmAltCon]) -> PmAltConSet -> [PmAltCon]
forall a b. (a -> b) -> a -> b
$ VarInfo -> PmAltConSet
vi_neg (VarInfo -> PmAltConSet) -> VarInfo -> PmAltConSet
forall a b. (a -> b) -> a -> b
$ TmState -> Id -> VarInfo
lookupVarInfo TmState
ts Id
x
isDataConSolution :: PmAltConApp -> Bool
isDataConSolution :: PmAltConApp -> Bool
isDataConSolution PACA{paca_con :: PmAltConApp -> PmAltCon
paca_con = PmAltConLike (RealDataCon DataCon
_)} = Bool
True
isDataConSolution PmAltConApp
_ = Bool
False
lookupSolution :: Nabla -> Id -> Maybe PmAltConApp
lookupSolution :: Nabla -> Id -> Maybe PmAltConApp
lookupSolution Nabla
nabla Id
x = case VarInfo -> [PmAltConApp]
vi_pos (TmState -> Id -> VarInfo
lookupVarInfo (Nabla -> TmState
nabla_tm_st Nabla
nabla) Id
x) of
[] -> Maybe PmAltConApp
forall a. Maybe a
Nothing
pos :: [PmAltConApp]
pos@(PmAltConApp
x:[PmAltConApp]
_)
| Just PmAltConApp
sol <- (PmAltConApp -> Bool) -> [PmAltConApp] -> Maybe PmAltConApp
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find PmAltConApp -> Bool
isDataConSolution [PmAltConApp]
pos -> PmAltConApp -> Maybe PmAltConApp
forall a. a -> Maybe a
Just PmAltConApp
sol
| Bool
otherwise -> PmAltConApp -> Maybe PmAltConApp
forall a. a -> Maybe a
Just PmAltConApp
x
data PmLit = PmLit
{ PmLit -> Kind
pm_lit_ty :: Type
, PmLit -> PmLitValue
pm_lit_val :: PmLitValue }
data PmLitValue
= PmLitInt Integer
| PmLitRat Rational
| PmLitChar Char
| PmLitString FastString
| PmLitOverInt Int Integer
| PmLitOverRat Int FractionalLit
| PmLitOverString FastString
data PmEquality
= Equal
| Disjoint
| PossiblyOverlap
deriving (PmEquality -> PmEquality -> Bool
(PmEquality -> PmEquality -> Bool)
-> (PmEquality -> PmEquality -> Bool) -> Eq PmEquality
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PmEquality -> PmEquality -> Bool
== :: PmEquality -> PmEquality -> Bool
$c/= :: PmEquality -> PmEquality -> Bool
/= :: PmEquality -> PmEquality -> Bool
Eq, Int -> PmEquality -> ShowS
[PmEquality] -> ShowS
PmEquality -> String
(Int -> PmEquality -> ShowS)
-> (PmEquality -> String)
-> ([PmEquality] -> ShowS)
-> Show PmEquality
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PmEquality -> ShowS
showsPrec :: Int -> PmEquality -> ShowS
$cshow :: PmEquality -> String
show :: PmEquality -> String
$cshowList :: [PmEquality] -> ShowS
showList :: [PmEquality] -> ShowS
Show)
decEquality :: Bool -> PmEquality
decEquality :: Bool -> PmEquality
decEquality Bool
True = PmEquality
Equal
decEquality Bool
False = PmEquality
Disjoint
eqPmLit :: PmLit -> PmLit -> PmEquality
eqPmLit :: PmLit -> PmLit -> PmEquality
eqPmLit (PmLit Kind
t1 PmLitValue
v1) (PmLit Kind
t2 PmLitValue
v2)
| Bool -> Bool
not (Kind
t1 Kind -> Kind -> Bool
`eqType` Kind
t2) = PmEquality
Disjoint
| Bool
otherwise = PmLitValue -> PmLitValue -> PmEquality
go PmLitValue
v1 PmLitValue
v2
where
go :: PmLitValue -> PmLitValue -> PmEquality
go (PmLitInt Integer
i1) (PmLitInt Integer
i2) = Bool -> PmEquality
decEquality (Integer
i1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i2)
go (PmLitRat Rational
r1) (PmLitRat Rational
r2) = Bool -> PmEquality
decEquality (Rational
r1 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
r2)
go (PmLitChar Char
c1) (PmLitChar Char
c2) = Bool -> PmEquality
decEquality (Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c2)
go (PmLitString FastString
s1) (PmLitString FastString
s2) = Bool -> PmEquality
decEquality (FastString
s1 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
s2)
go (PmLitOverInt Int
n1 Integer
i1) (PmLitOverInt Int
n2 Integer
i2)
| Int
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n2 Bool -> Bool -> Bool
&& Integer
i1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i2 = PmEquality
Equal
go (PmLitOverRat Int
n1 FractionalLit
r1) (PmLitOverRat Int
n2 FractionalLit
r2)
| Int
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n2 Bool -> Bool -> Bool
&& FractionalLit
r1 FractionalLit -> FractionalLit -> Bool
forall a. Eq a => a -> a -> Bool
== FractionalLit
r2 = PmEquality
Equal
go (PmLitOverString FastString
s1) (PmLitOverString FastString
s2)
| FastString
s1 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
s2 = PmEquality
Equal
go PmLitValue
_ PmLitValue
_ = PmEquality
PossiblyOverlap
instance Eq PmLit where
PmLit
a == :: PmLit -> PmLit -> Bool
== PmLit
b = PmLit -> PmLit -> PmEquality
eqPmLit PmLit
a PmLit
b PmEquality -> PmEquality -> Bool
forall a. Eq a => a -> a -> Bool
== PmEquality
Equal
pmLitType :: PmLit -> Type
pmLitType :: PmLit -> Kind
pmLitType (PmLit Kind
ty PmLitValue
_) = Kind
ty
eqConLike :: ConLike -> ConLike -> PmEquality
eqConLike :: ConLike -> ConLike -> PmEquality
eqConLike (RealDataCon DataCon
dc1) (RealDataCon DataCon
dc2) = Bool -> PmEquality
decEquality (DataCon
dc1 DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
dc2)
eqConLike (PatSynCon PatSyn
psc1) (PatSynCon PatSyn
psc2)
| PatSyn
psc1 PatSyn -> PatSyn -> Bool
forall a. Eq a => a -> a -> Bool
== PatSyn
psc2
= PmEquality
Equal
eqConLike ConLike
_ ConLike
_ = PmEquality
PossiblyOverlap
data PmAltCon = PmAltConLike ConLike
| PmAltLit PmLit
data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit]
emptyPmAltConSet :: PmAltConSet
emptyPmAltConSet :: PmAltConSet
emptyPmAltConSet = UniqDSet ConLike -> [PmLit] -> PmAltConSet
PACS UniqDSet ConLike
forall a. UniqDSet a
emptyUniqDSet []
isEmptyPmAltConSet :: PmAltConSet -> Bool
isEmptyPmAltConSet :: PmAltConSet -> Bool
isEmptyPmAltConSet (PACS UniqDSet ConLike
cls [PmLit]
lits) = UniqDSet ConLike -> Bool
forall a. UniqDSet a -> Bool
isEmptyUniqDSet UniqDSet ConLike
cls Bool -> Bool -> Bool
&& [PmLit] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PmLit]
lits
elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool
elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool
elemPmAltConSet (PmAltConLike ConLike
cl) (PACS UniqDSet ConLike
cls [PmLit]
_ ) = ConLike -> UniqDSet ConLike -> Bool
forall a. Uniquable a => a -> UniqDSet a -> Bool
elementOfUniqDSet ConLike
cl UniqDSet ConLike
cls
elemPmAltConSet (PmAltLit PmLit
lit) (PACS UniqDSet ConLike
_ [PmLit]
lits) = PmLit -> [PmLit] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem PmLit
lit [PmLit]
lits
extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet
extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet
extendPmAltConSet (PACS UniqDSet ConLike
cls [PmLit]
lits) (PmAltConLike ConLike
cl)
= UniqDSet ConLike -> [PmLit] -> PmAltConSet
PACS (UniqDSet ConLike -> ConLike -> UniqDSet ConLike
forall a. Uniquable a => UniqDSet a -> a -> UniqDSet a
addOneToUniqDSet UniqDSet ConLike
cls ConLike
cl) [PmLit]
lits
extendPmAltConSet (PACS UniqDSet ConLike
cls [PmLit]
lits) (PmAltLit PmLit
lit)
= UniqDSet ConLike -> [PmLit] -> PmAltConSet
PACS UniqDSet ConLike
cls ([PmLit] -> [PmLit] -> [PmLit]
forall a.
(() :: Constraint, Outputable a, Eq a) =>
[a] -> [a] -> [a]
unionLists [PmLit]
lits [PmLit
lit])
pmAltConSetElems :: PmAltConSet -> [PmAltCon]
pmAltConSetElems :: PmAltConSet -> [PmAltCon]
pmAltConSetElems (PACS UniqDSet ConLike
cls [PmLit]
lits)
= (ConLike -> PmAltCon) -> [ConLike] -> [PmAltCon]
forall a b. (a -> b) -> [a] -> [b]
map ConLike -> PmAltCon
PmAltConLike (UniqDSet ConLike -> [ConLike]
forall a. UniqDSet a -> [a]
uniqDSetToList UniqDSet ConLike
cls) [PmAltCon] -> [PmAltCon] -> [PmAltCon]
forall a. [a] -> [a] -> [a]
++ (PmLit -> PmAltCon) -> [PmLit] -> [PmAltCon]
forall a b. (a -> b) -> [a] -> [b]
map PmLit -> PmAltCon
PmAltLit [PmLit]
lits
instance Outputable PmAltConSet where
ppr :: PmAltConSet -> SDoc
ppr = [PmAltCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([PmAltCon] -> SDoc)
-> (PmAltConSet -> [PmAltCon]) -> PmAltConSet -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PmAltConSet -> [PmAltCon]
pmAltConSetElems
eqPmAltCon :: PmAltCon -> PmAltCon -> PmEquality
eqPmAltCon :: PmAltCon -> PmAltCon -> PmEquality
eqPmAltCon (PmAltConLike ConLike
cl1) (PmAltConLike ConLike
cl2) = ConLike -> ConLike -> PmEquality
eqConLike ConLike
cl1 ConLike
cl2
eqPmAltCon (PmAltLit PmLit
l1) (PmAltLit PmLit
l2) = PmLit -> PmLit -> PmEquality
eqPmLit PmLit
l1 PmLit
l2
eqPmAltCon PmAltCon
_ PmAltCon
_ = PmEquality
PossiblyOverlap
instance Eq PmAltCon where
PmAltCon
a == :: PmAltCon -> PmAltCon -> Bool
== PmAltCon
b = PmAltCon -> PmAltCon -> PmEquality
eqPmAltCon PmAltCon
a PmAltCon
b PmEquality -> PmEquality -> Bool
forall a. Eq a => a -> a -> Bool
== PmEquality
Equal
pmAltConType :: PmAltCon -> [Type] -> Type
pmAltConType :: PmAltCon -> [Kind] -> Kind
pmAltConType (PmAltLit PmLit
lit) [Kind]
_arg_tys = Bool -> Kind -> Kind
forall a. HasCallStack => Bool -> a -> a
assert ([Kind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
_arg_tys ) (Kind -> Kind) -> Kind -> Kind
forall a b. (a -> b) -> a -> b
$ PmLit -> Kind
pmLitType PmLit
lit
pmAltConType (PmAltConLike ConLike
con) [Kind]
arg_tys = ConLike -> [Kind] -> Kind
conLikeResTy ConLike
con [Kind]
arg_tys
isPmAltConMatchStrict :: PmAltCon -> Bool
isPmAltConMatchStrict :: PmAltCon -> Bool
isPmAltConMatchStrict PmAltLit{} = Bool
True
isPmAltConMatchStrict (PmAltConLike PatSynCon{}) = Bool
True
isPmAltConMatchStrict (PmAltConLike (RealDataCon DataCon
dc)) = Bool -> Bool
not (DataCon -> Bool
isNewDataCon DataCon
dc)
pmAltConImplBangs :: PmAltCon -> [HsImplBang]
pmAltConImplBangs :: PmAltCon -> [HsImplBang]
pmAltConImplBangs PmAltLit{} = []
pmAltConImplBangs (PmAltConLike ConLike
con) = ConLike -> [HsImplBang]
conLikeImplBangs ConLike
con
literalToPmLit :: Type -> Literal -> Maybe PmLit
literalToPmLit :: Kind -> Literal -> Maybe PmLit
literalToPmLit Kind
ty Literal
l = Kind -> PmLitValue -> PmLit
PmLit Kind
ty (PmLitValue -> PmLit) -> Maybe PmLitValue -> Maybe PmLit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> Maybe PmLitValue
go Literal
l
where
go :: Literal -> Maybe PmLitValue
go (LitChar Char
c) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (Char -> PmLitValue
PmLitChar Char
c)
go (LitFloat Rational
r) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (Rational -> PmLitValue
PmLitRat Rational
r)
go (LitDouble Rational
r) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (Rational -> PmLitValue
PmLitRat Rational
r)
go (LitString ByteString
s) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (FastString -> PmLitValue
PmLitString (ByteString -> FastString
mkFastStringByteString ByteString
s))
go (LitNumber LitNumType
_ Integer
i) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (Integer -> PmLitValue
PmLitInt Integer
i)
go Literal
_ = Maybe PmLitValue
forall a. Maybe a
Nothing
negatePmLit :: PmLit -> Maybe PmLit
negatePmLit :: PmLit -> Maybe PmLit
negatePmLit (PmLit Kind
ty PmLitValue
v) = Kind -> PmLitValue -> PmLit
PmLit Kind
ty (PmLitValue -> PmLit) -> Maybe PmLitValue -> Maybe PmLit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PmLitValue -> Maybe PmLitValue
go PmLitValue
v
where
go :: PmLitValue -> Maybe PmLitValue
go (PmLitInt Integer
i) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (Integer -> PmLitValue
PmLitInt (-Integer
i))
go (PmLitRat Rational
r) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (Rational -> PmLitValue
PmLitRat (-Rational
r))
go (PmLitOverInt Int
n Integer
i) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (Int -> Integer -> PmLitValue
PmLitOverInt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Integer
i)
go (PmLitOverRat Int
n FractionalLit
r) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (Int -> FractionalLit -> PmLitValue
PmLitOverRat (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) FractionalLit
r)
go PmLitValue
_ = Maybe PmLitValue
forall a. Maybe a
Nothing
overloadPmLit :: Type -> PmLit -> Maybe PmLit
overloadPmLit :: Kind -> PmLit -> Maybe PmLit
overloadPmLit Kind
ty (PmLit Kind
_ PmLitValue
v) = Kind -> PmLitValue -> PmLit
PmLit Kind
ty (PmLitValue -> PmLit) -> Maybe PmLitValue -> Maybe PmLit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PmLitValue -> Maybe PmLitValue
go PmLitValue
v
where
go :: PmLitValue -> Maybe PmLitValue
go (PmLitInt Integer
i) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (Int -> Integer -> PmLitValue
PmLitOverInt Int
0 Integer
i)
go (PmLitRat Rational
r) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (PmLitValue -> Maybe PmLitValue) -> PmLitValue -> Maybe PmLitValue
forall a b. (a -> b) -> a -> b
$! Int -> FractionalLit -> PmLitValue
PmLitOverRat Int
0 (FractionalLit -> PmLitValue) -> FractionalLit -> PmLitValue
forall a b. (a -> b) -> a -> b
$! Rational -> FractionalLit
fractionalLitFromRational Rational
r
go (PmLitString FastString
s)
| Kind
ty Kind -> Kind -> Bool
`eqType` Kind
stringTy = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just PmLitValue
v
| Bool
otherwise = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (FastString -> PmLitValue
PmLitOverString FastString
s)
go ovRat :: PmLitValue
ovRat@PmLitOverRat{} = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just PmLitValue
ovRat
go PmLitValue
_ = Maybe PmLitValue
forall a. Maybe a
Nothing
pmLitAsStringLit :: PmLit -> Maybe FastString
pmLitAsStringLit :: PmLit -> Maybe FastString
pmLitAsStringLit (PmLit Kind
_ (PmLitString FastString
s)) = FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
s
pmLitAsStringLit PmLit
_ = Maybe FastString
forall a. Maybe a
Nothing
coreExprAsPmLit :: CoreExpr -> Maybe PmLit
coreExprAsPmLit :: CoreExpr -> Maybe PmLit
coreExprAsPmLit (Tick CoreTickish
_t CoreExpr
e) = CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
e
coreExprAsPmLit (Lit Literal
l) = Kind -> Literal -> Maybe PmLit
literalToPmLit (Literal -> Kind
literalType Literal
l) Literal
l
coreExprAsPmLit CoreExpr
e = case CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
e of
(Var Id
x, [Lit Literal
l])
| Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
x
, DataCon
dc DataCon -> [DataCon] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DataCon
intDataCon, DataCon
wordDataCon, DataCon
charDataCon, DataCon
floatDataCon, DataCon
doubleDataCon]
-> Kind -> Literal -> Maybe PmLit
literalToPmLit ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e) Literal
l
(Var Id
x, [Lit (LitNumber LitNumType
_ Integer
l)])
| Just (Kind
ty,Integer
l) <- Id -> Integer -> Maybe (Kind, Integer)
forall {b}. Num b => Id -> b -> Maybe (Kind, b)
bignum_lit_maybe Id
x Integer
l
-> PmLit -> Maybe PmLit
forall a. a -> Maybe a
Just (Kind -> PmLitValue -> PmLit
PmLit Kind
ty (Integer -> PmLitValue
PmLitInt Integer
l))
(Var Id
x, [CoreExpr
_ty, CoreExpr
n_arg, CoreExpr
d_arg])
| Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
x
, DataCon -> Name
dataConName DataCon
dc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
ratioDataConName
, Just (PmLit Kind
_ (PmLitInt Integer
n)) <- CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
n_arg
, Just (PmLit Kind
_ (PmLitInt Integer
d)) <- CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
d_arg
-> Kind -> Literal -> Maybe PmLit
literalToPmLit ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e) (Rational -> Literal
mkLitDouble (Integer
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
d))
(Var Id
x, [CoreExpr]
args)
| Id -> Name -> Bool
is_rebound_name Id
x Name
fromIntegerName
, Just CoreExpr
arg <- [CoreExpr] -> Maybe CoreExpr
forall a. [a] -> Maybe a
lastMaybe [CoreExpr]
args
, Just (Kind
_ty,Integer
l) <- CoreExpr -> Maybe (Kind, Integer)
forall {b}. Expr b -> Maybe (Kind, Integer)
bignum_conapp_maybe CoreExpr
arg
-> PmLit -> Maybe PmLit
forall a. a -> Maybe a
Just (Kind -> PmLitValue -> PmLit
PmLit Kind
integerTy (Integer -> PmLitValue
PmLitInt Integer
l)) Maybe PmLit -> (PmLit -> Maybe PmLit) -> Maybe PmLit
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Kind -> PmLit -> Maybe PmLit
overloadPmLit ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e)
(Var Id
x, [CoreExpr]
args)
| Id -> Name -> Bool
is_rebound_name Id
x Name
fromRationalName
, [CoreExpr
r] <- (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (CoreExpr -> Bool) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Bool
is_ratio) [CoreExpr]
args
-> CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
r Maybe PmLit -> (PmLit -> Maybe PmLit) -> Maybe PmLit
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Kind -> PmLit -> Maybe PmLit
overloadPmLit ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e)
(Var Id
x, [CoreExpr]
args)
| Just FractionalExponentBase
exp_base <- Id -> Maybe FractionalExponentBase
is_larg_exp_ratio Id
x
, [CoreExpr
r, CoreExpr
exp] <- (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (CoreExpr -> Bool) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Bool
is_ratio) [CoreExpr]
args
, (Var Id
x, [CoreExpr
_ty, CoreExpr
n_arg, CoreExpr
d_arg]) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
r
, Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
x
, DataCon -> Name
dataConName DataCon
dc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
ratioDataConName
, Just (PmLit Kind
_ (PmLitInt Integer
n)) <- CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
n_arg
, Just (PmLit Kind
_ (PmLitInt Integer
d)) <- CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
d_arg
, Just (Kind
_exp_ty,Integer
exp') <- CoreExpr -> Maybe (Kind, Integer)
forall {b}. Expr b -> Maybe (Kind, Integer)
bignum_conapp_maybe CoreExpr
exp
-> do
let rational :: Rational
rational = (Integer -> Integer
forall a. Num a => a -> a
abs Integer
n) Integer -> Integer -> Rational
forall a. a -> a -> Ratio a
:% Integer
d
let neg :: Int
neg = if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Int
1 else Int
0
let frac :: FractionalLit
frac = SourceText
-> Bool
-> Rational
-> Integer
-> FractionalExponentBase
-> FractionalLit
mkFractionalLit SourceText
NoSourceText Bool
False Rational
rational Integer
exp' FractionalExponentBase
exp_base
PmLit -> Maybe PmLit
forall a. a -> Maybe a
Just (PmLit -> Maybe PmLit) -> PmLit -> Maybe PmLit
forall a b. (a -> b) -> a -> b
$ Kind -> PmLitValue -> PmLit
PmLit ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e) (Int -> FractionalLit -> PmLitValue
PmLitOverRat Int
neg FractionalLit
frac)
(Var Id
x, [CoreExpr]
args)
| Id -> Name -> Bool
is_rebound_name Id
x Name
fromStringName
, CoreExpr
s:[CoreExpr]
_ <- (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
filter (Kind -> Bool
isStringTy (Kind -> Bool) -> (CoreExpr -> Kind) -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType) ([CoreExpr] -> [CoreExpr]) -> [CoreExpr] -> [CoreExpr]
forall a b. (a -> b) -> a -> b
$ (CoreExpr -> Bool) -> [CoreExpr] -> [CoreExpr]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg [CoreExpr]
args
-> CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
s Maybe PmLit -> (PmLit -> Maybe PmLit) -> Maybe PmLit
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Kind -> PmLit -> Maybe PmLit
overloadPmLit ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e)
(Var Id
x, [Type Kind
ty])
| Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
x
, DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
nilDataCon
, Kind
ty Kind -> Kind -> Bool
`eqType` Kind
charTy
-> Kind -> Literal -> Maybe PmLit
literalToPmLit Kind
stringTy (String -> Literal
mkLitString String
"")
(Var Id
x, [Lit Literal
l])
| Id -> Name
idName Id
x Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
unpackCStringName, Name
unpackCStringUtf8Name]
-> Kind -> Literal -> Maybe PmLit
literalToPmLit Kind
stringTy Literal
l
(CoreExpr, [CoreExpr])
_ -> Maybe PmLit
forall a. Maybe a
Nothing
where
bignum_conapp_maybe :: Expr b -> Maybe (Kind, Integer)
bignum_conapp_maybe (App (Var Id
x) (Lit (LitNumber LitNumType
_ Integer
l)))
= Id -> Integer -> Maybe (Kind, Integer)
forall {b}. Num b => Id -> b -> Maybe (Kind, b)
bignum_lit_maybe Id
x Integer
l
bignum_conapp_maybe Expr b
_ = Maybe (Kind, Integer)
forall a. Maybe a
Nothing
bignum_lit_maybe :: Id -> b -> Maybe (Kind, b)
bignum_lit_maybe Id
x b
l
| Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
x
= if | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
integerISDataCon -> (Kind, b) -> Maybe (Kind, b)
forall a. a -> Maybe a
Just (Kind
integerTy,b
l)
| DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
integerIPDataCon -> (Kind, b) -> Maybe (Kind, b)
forall a. a -> Maybe a
Just (Kind
integerTy,b
l)
| DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
integerINDataCon -> (Kind, b) -> Maybe (Kind, b)
forall a. a -> Maybe a
Just (Kind
integerTy,b -> b
forall a. Num a => a -> a
negate b
l)
| DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
naturalNSDataCon -> (Kind, b) -> Maybe (Kind, b)
forall a. a -> Maybe a
Just (Kind
naturalTy,b
l)
| DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
naturalNBDataCon -> (Kind, b) -> Maybe (Kind, b)
forall a. a -> Maybe a
Just (Kind
naturalTy,b
l)
| Bool
otherwise -> Maybe (Kind, b)
forall a. Maybe a
Nothing
bignum_lit_maybe Id
_ b
_ = Maybe (Kind, b)
forall a. Maybe a
Nothing
is_ratio :: CoreExpr -> Bool
is_ratio (Type Kind
_) = Bool
False
is_ratio CoreExpr
r
| Just (TyCon
tc, [Kind]
_) <- (() :: Constraint) => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
r)
= TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
ratioTyConName
| Bool
otherwise
= Bool
False
is_larg_exp_ratio :: Id -> Maybe FractionalExponentBase
is_larg_exp_ratio Id
x
| Id -> Name -> Bool
is_rebound_name Id
x Name
mkRationalBase10Name
= FractionalExponentBase -> Maybe FractionalExponentBase
forall a. a -> Maybe a
Just FractionalExponentBase
Base10
| Id -> Name -> Bool
is_rebound_name Id
x Name
mkRationalBase2Name
= FractionalExponentBase -> Maybe FractionalExponentBase
forall a. a -> Maybe a
Just FractionalExponentBase
Base2
| Bool
otherwise
= Maybe FractionalExponentBase
forall a. Maybe a
Nothing
is_rebound_name :: Id -> Name -> Bool
is_rebound_name :: Id -> Name -> Bool
is_rebound_name Id
x Name
n = Name -> FastString
forall a. NamedThing a => a -> FastString
getOccFS (Id -> Name
idName Id
x) FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> FastString
forall a. NamedThing a => a -> FastString
getOccFS Name
n
instance Outputable PmLitValue where
ppr :: PmLitValue -> SDoc
ppr (PmLitInt Integer
i) = Integer -> SDoc
forall a. Outputable a => a -> SDoc
ppr Integer
i
ppr (PmLitRat Rational
r) = Double -> SDoc
forall doc. IsLine doc => Double -> doc
double (Rational -> Double
forall a. RealFloat a => Rational -> a
fromRat Rational
r)
ppr (PmLitChar Char
c) = Char -> SDoc
pprHsChar Char
c
ppr (PmLitString FastString
s) = FastString -> SDoc
pprHsString FastString
s
ppr (PmLitOverInt Int
n Integer
i) = Int -> SDoc -> SDoc
minuses Int
n (Integer -> SDoc
forall a. Outputable a => a -> SDoc
ppr Integer
i)
ppr (PmLitOverRat Int
n FractionalLit
r) = Int -> SDoc -> SDoc
minuses Int
n (FractionalLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr FractionalLit
r)
ppr (PmLitOverString FastString
s) = FastString -> SDoc
pprHsString FastString
s
minuses :: Int -> SDoc -> SDoc
minuses :: Int -> SDoc -> SDoc
minuses Int
n SDoc
sdoc = (SDoc -> SDoc) -> SDoc -> [SDoc]
forall a. (a -> a) -> a -> [a]
iterate (\SDoc
sdoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'-' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
sdoc)) SDoc
sdoc [SDoc] -> Int -> SDoc
forall a. HasCallStack => [a] -> Int -> a
!! Int
n
instance Outputable PmLit where
ppr :: PmLit -> SDoc
ppr (PmLit Kind
ty PmLitValue
v) = PmLitValue -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmLitValue
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
suffix
where
tbl :: [(Kind, SDoc)]
tbl = [ (Kind
intPrimTy, SDoc
primIntSuffix)
, (Kind
int64PrimTy, SDoc
primInt64Suffix)
, (Kind
wordPrimTy, SDoc
primWordSuffix)
, (Kind
word64PrimTy, SDoc
primWord64Suffix)
, (Kind
charPrimTy, SDoc
primCharSuffix)
, (Kind
floatPrimTy, SDoc
primFloatSuffix)
, (Kind
doublePrimTy, SDoc
primDoubleSuffix) ]
suffix :: SDoc
suffix = SDoc -> Maybe SDoc -> SDoc
forall a. a -> Maybe a -> a
fromMaybe SDoc
forall doc. IsOutput doc => doc
empty ((Kind, SDoc) -> SDoc
forall a b. (a, b) -> b
snd ((Kind, SDoc) -> SDoc) -> Maybe (Kind, SDoc) -> Maybe SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Kind, SDoc) -> Bool) -> [(Kind, SDoc)] -> Maybe (Kind, SDoc)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Kind -> Kind -> Bool
eqType Kind
ty (Kind -> Bool) -> ((Kind, SDoc) -> Kind) -> (Kind, SDoc) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Kind, SDoc) -> Kind
forall a b. (a, b) -> a
fst) [(Kind, SDoc)]
tbl)
instance Outputable PmAltCon where
ppr :: PmAltCon -> SDoc
ppr (PmAltConLike ConLike
cl) = ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl
ppr (PmAltLit PmLit
l) = PmLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmLit
l
instance Outputable PmEquality where
ppr :: PmEquality -> SDoc
ppr = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> (PmEquality -> String) -> PmEquality -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PmEquality -> String
forall a. Show a => a -> String
show