{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GHC.HsToCore.Pmc.Solver.Types (
BotInfo(..), PmAltConApp(..), VarInfo(..), TmState(..), TyState(..),
Nabla(..), Nablas(..), initNablas,
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
#include "HsVersions.h"
import GHC.Prelude
import GHC.Utils.Misc
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
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.Map.Expr
import GHC.Core.Utils (exprType)
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Tc.Solver.Monad (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
text String
"Nabla") Int
2 forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [
forall a. Outputable a => a -> SDoc
ppr (Nabla -> TmState
nabla_tm_st Nabla
nabla),
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 (forall a. a -> Bag a
unitBag Nabla
initNabla)
instance Outputable Nablas where
ppr :: Nablas -> SDoc
ppr (MkNablas Bag Nabla
nablas) = 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 forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag Nabla
r)
instance Monoid Nablas where
mempty :: Nablas
mempty = Bag Nabla -> Nablas
MkNablas 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) = forall a. Outputable a => a -> SDoc
ppr Int
n SDoc -> SDoc -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BotInfo -> BotInfo -> Bool
$c/= :: BotInfo -> BotInfo -> Bool
== :: BotInfo -> BotInfo -> Bool
$c== :: 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
hsep (forall a. Outputable a => a -> SDoc
ppr PmAltCon
con forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ((Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr) [Id]
tvs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [Id]
ids)
instance Outputable BotInfo where
ppr :: BotInfo -> SDoc
ppr BotInfo
MaybeBot = SDoc
underscore
ppr BotInfo
IsBot = String -> SDoc
text String
"~⊥"
ppr BotInfo
IsNotBot = String -> SDoc
text String
"≁⊥"
instance Outputable TmState where
ppr :: TmState -> SDoc
ppr (TmSt UniqSDFM Id VarInfo
state CoreMap Id
reps DIdSet
dirty) = forall a. Outputable a => a -> SDoc
ppr UniqSDFM Id VarInfo
state SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr CoreMap Id
reps SDoc -> SDoc -> 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
braces ([SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc
pp_x, SDoc
pp_pos, SDoc
pp_neg, forall a. Outputable a => a -> SDoc
ppr BotInfo
bot, SDoc
pp_cache]))
where
pp_x :: SDoc
pp_x = forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
<> SDoc
dcolon SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
x)
pp_pos :: SDoc
pp_pos
| [] <- [PmAltConApp]
pos = SDoc
underscore
| [PmAltConApp
p] <- [PmAltConApp]
pos = Char -> SDoc
char Char
'~' SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr PmAltConApp
p
| Bool
otherwise = Char -> SDoc
char Char
'~' SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr [PmAltConApp]
pos
pp_neg :: SDoc
pp_neg
| PmAltConSet -> Bool
isEmptyPmAltConSet PmAltConSet
neg = SDoc
underscore
| Bool
otherwise = Char -> SDoc
char Char
'≁' SDoc -> SDoc -> 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
underscore
| Bool
otherwise = forall a. Outputable a => a -> SDoc
ppr ResidualCompleteMatches
cache
initTmState :: TmState
initTmState :: TmState
initTmState = UniqSDFM Id VarInfo -> CoreMap Id -> DIdSet -> TmState
TmSt forall key ele. UniqSDFM key ele
emptyUSDFM 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) = forall a. Maybe a -> [a]
maybeToList Maybe CompleteMatch
vanilla forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe [] Maybe [CompleteMatch]
pragmas
isRcmInitialised :: ResidualCompleteMatches -> Bool
isRcmInitialised :: ResidualCompleteMatches -> Bool
isRcmInitialised (RCM Maybe CompleteMatch
vanilla Maybe [CompleteMatch]
pragmas) = forall a. Maybe a -> Bool
isJust Maybe CompleteMatch
vanilla Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe [CompleteMatch]
pragmas
instance Outputable ResidualCompleteMatches where
ppr :: ResidualCompleteMatches -> SDoc
ppr ResidualCompleteMatches
rcm = forall a. Outputable a => a -> SDoc
ppr (ResidualCompleteMatches -> [CompleteMatch]
getRcm ResidualCompleteMatches
rcm)
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PmEquality -> PmEquality -> Bool
$c/= :: PmEquality -> PmEquality -> Bool
== :: PmEquality -> PmEquality -> Bool
$c== :: PmEquality -> PmEquality -> Bool
Eq, Int -> PmEquality -> ShowS
[PmEquality] -> ShowS
PmEquality -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PmEquality] -> ShowS
$cshowList :: [PmEquality] -> ShowS
show :: PmEquality -> String
$cshow :: PmEquality -> String
showsPrec :: Int -> PmEquality -> ShowS
$cshowsPrec :: Int -> 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 forall a. Eq a => a -> a -> Bool
== Integer
i2)
go (PmLitRat Rational
r1) (PmLitRat Rational
r2) = Bool -> PmEquality
decEquality (Rational
r1 forall a. Eq a => a -> a -> Bool
== Rational
r2)
go (PmLitChar Char
c1) (PmLitChar Char
c2) = Bool -> PmEquality
decEquality (Char
c1 forall a. Eq a => a -> a -> Bool
== Char
c2)
go (PmLitString FastString
s1) (PmLitString FastString
s2) = Bool -> PmEquality
decEquality (FastString
s1 forall a. Eq a => a -> a -> Bool
== FastString
s2)
go (PmLitOverInt Int
n1 Integer
i1) (PmLitOverInt Int
n2 Integer
i2)
| Int
n1 forall a. Eq a => a -> a -> Bool
== Int
n2 Bool -> Bool -> Bool
&& Integer
i1 forall a. Eq a => a -> a -> Bool
== Integer
i2 = PmEquality
Equal
go (PmLitOverRat Int
n1 FractionalLit
r1) (PmLitOverRat Int
n2 FractionalLit
r2)
| Int
n1 forall a. Eq a => a -> a -> Bool
== Int
n2 Bool -> Bool -> Bool
&& FractionalLit
r1 forall a. Eq a => a -> a -> Bool
== FractionalLit
r2 = PmEquality
Equal
go (PmLitOverString FastString
s1) (PmLitOverString FastString
s2)
| FastString
s1 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 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 forall a. Eq a => a -> a -> Bool
== DataCon
dc2)
eqConLike (PatSynCon PatSyn
psc1) (PatSynCon PatSyn
psc2)
| PatSyn
psc1 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 forall a. UniqDSet a
emptyUniqDSet []
isEmptyPmAltConSet :: PmAltConSet -> Bool
isEmptyPmAltConSet :: PmAltConSet -> Bool
isEmptyPmAltConSet (PACS UniqDSet ConLike
cls [PmLit]
lits) = forall a. UniqDSet a -> Bool
isEmptyUniqDSet UniqDSet ConLike
cls Bool -> Bool -> 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]
_ ) = forall a. Uniquable a => a -> UniqDSet a -> Bool
elementOfUniqDSet ConLike
cl UniqDSet ConLike
cls
elemPmAltConSet (PmAltLit PmLit
lit) (PACS UniqDSet ConLike
_ [PmLit]
lits) = 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 (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 (forall a.
(HasDebugCallStack, 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)
= forall a b. (a -> b) -> [a] -> [b]
map ConLike -> PmAltCon
PmAltConLike (forall a. UniqDSet a -> [a]
uniqDSetToList UniqDSet ConLike
cls) forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map PmLit -> PmAltCon
PmAltLit [PmLit]
lits
instance Outputable PmAltConSet where
ppr :: PmAltConSet -> SDoc
ppr = forall a. Outputable a => a -> SDoc
ppr 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 forall a. Eq a => a -> a -> Bool
== PmEquality
Equal
pmAltConType :: PmAltCon -> [Type] -> Type
pmAltConType :: PmAltCon -> [Kind] -> Kind
pmAltConType (PmAltLit PmLit
lit) [Kind]
_arg_tys = ASSERT( null _arg_tys ) pmLitType 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 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) = forall a. a -> Maybe a
Just (Char -> PmLitValue
PmLitChar Char
c)
go (LitFloat Rational
r) = forall a. a -> Maybe a
Just (Rational -> PmLitValue
PmLitRat Rational
r)
go (LitDouble Rational
r) = forall a. a -> Maybe a
Just (Rational -> PmLitValue
PmLitRat Rational
r)
go (LitString ByteString
s) = forall a. a -> Maybe a
Just (FastString -> PmLitValue
PmLitString (ByteString -> FastString
mkFastStringByteString ByteString
s))
go (LitNumber LitNumType
_ Integer
i) = forall a. a -> Maybe a
Just (Integer -> PmLitValue
PmLitInt Integer
i)
go Literal
_ = 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 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) = forall a. a -> Maybe a
Just (Integer -> PmLitValue
PmLitInt (-Integer
i))
go (PmLitRat Rational
r) = forall a. a -> Maybe a
Just (Rational -> PmLitValue
PmLitRat (-Rational
r))
go (PmLitOverInt Int
n Integer
i) = forall a. a -> Maybe a
Just (Int -> Integer -> PmLitValue
PmLitOverInt (Int
nforall a. Num a => a -> a -> a
+Int
1) Integer
i)
go (PmLitOverRat Int
n FractionalLit
r) = forall a. a -> Maybe a
Just (Int -> FractionalLit -> PmLitValue
PmLitOverRat (Int
nforall a. Num a => a -> a -> a
+Int
1) FractionalLit
r)
go 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 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) = forall a. a -> Maybe a
Just (Int -> Integer -> PmLitValue
PmLitOverInt Int
0 Integer
i)
go (PmLitRat Rational
r) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Int -> FractionalLit -> PmLitValue
PmLitOverRat Int
0 forall a b. (a -> b) -> a -> b
$! Rational -> FractionalLit
fractionalLitFromRational Rational
r
go (PmLitString FastString
s)
| Kind
ty Kind -> Kind -> Bool
`eqType` Kind
stringTy = forall a. a -> Maybe a
Just PmLitValue
v
| Bool
otherwise = forall a. a -> Maybe a
Just (FastString -> PmLitValue
PmLitOverString FastString
s)
go ovRat :: PmLitValue
ovRat@PmLitOverRat{} = forall a. a -> Maybe a
Just PmLitValue
ovRat
go PmLitValue
_ = forall a. Maybe a
Nothing
pmLitAsStringLit :: PmLit -> Maybe FastString
pmLitAsStringLit :: PmLit -> Maybe FastString
pmLitAsStringLit (PmLit Kind
_ (PmLitString FastString
s)) = forall a. a -> Maybe a
Just FastString
s
pmLitAsStringLit PmLit
_ = 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 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 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 (CoreExpr -> Kind
exprType CoreExpr
e) Literal
l
(Var Id
x, [CoreExpr
_ty, Lit Literal
n, Lit Literal
d])
| Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
x
, DataCon -> Name
dataConName DataCon
dc forall a. Eq a => a -> a -> Bool
== Name
ratioDataConName
-> Kind -> Literal -> Maybe PmLit
literalToPmLit (CoreExpr -> Kind
exprType CoreExpr
e) (Rational -> Literal
mkLitDouble (Literal -> Integer
litValue Literal
n forall a. Integral a => a -> a -> Ratio a
% Literal -> Integer
litValue Literal
d))
(Var Id
x, [CoreExpr]
args)
| Id -> Name -> Bool
is_rebound_name Id
x Name
fromIntegerName
, [Lit Literal
l] <- forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Expr b -> Bool
is_lit) [CoreExpr]
args
-> Kind -> Literal -> Maybe PmLit
literalToPmLit (Literal -> Kind
literalType Literal
l) Literal
l forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Kind -> PmLit -> Maybe PmLit
overloadPmLit (CoreExpr -> Kind
exprType CoreExpr
e)
(Var Id
x, [CoreExpr]
args)
| Id -> Name -> Bool
is_rebound_name Id
x Name
fromRationalName
, [CoreExpr
r] <- forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Bool
is_ratio) [CoreExpr]
args
-> CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Kind -> PmLit -> Maybe PmLit
overloadPmLit (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, Lit Literal
exp] <- forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Bool
is_ratio) [CoreExpr]
args
, (Var Id
x, [CoreExpr
_ty, Lit Literal
n, Lit Literal
d]) <- 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 forall a. Eq a => a -> a -> Bool
== Name
ratioDataConName
-> do
Integer
n' <- Literal -> Maybe Integer
isLitValue_maybe Literal
n
Integer
d' <- Literal -> Maybe Integer
isLitValue_maybe Literal
d
Integer
exp' <- Literal -> Maybe Integer
isLitValue_maybe Literal
exp
let rational :: Rational
rational = (forall a. Num a => a -> a
abs Integer
n') forall a. a -> a -> Ratio a
:% Integer
d'
let neg :: Int
neg = if Integer
n' 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
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Kind -> PmLitValue -> PmLit
PmLit (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]
_ <- forall a. (a -> Bool) -> [a] -> [a]
filter (Kind -> Bool
isStringTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Kind
exprType) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. Expr b -> Bool
isValArg [CoreExpr]
args
-> CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Kind -> PmLit -> Maybe PmLit
overloadPmLit (CoreExpr -> Kind
exprType CoreExpr
e)
(Var Id
x, [Type Kind
ty])
| Just DataCon
dc <- Id -> Maybe DataCon
isDataConWorkId_maybe Id
x
, DataCon
dc 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 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])
_ -> forall a. Maybe a
Nothing
where
is_lit :: Expr b -> Bool
is_lit Lit{} = Bool
True
is_lit Expr b
_ = Bool
False
is_ratio :: CoreExpr -> Bool
is_ratio (Type Kind
_) = Bool
False
is_ratio CoreExpr
r
| Just (TyCon
tc, [Kind]
_) <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe (CoreExpr -> Kind
exprType CoreExpr
r)
= TyCon -> Name
tyConName TyCon
tc 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
= forall a. a -> Maybe a
Just FractionalExponentBase
Base10
| Id -> Name -> Bool
is_rebound_name Id
x Name
mkRationalBase2Name
= forall a. a -> Maybe a
Just FractionalExponentBase
Base2
| Bool
otherwise
= forall a. Maybe a
Nothing
is_rebound_name :: Id -> Name -> Bool
is_rebound_name :: Id -> Name -> Bool
is_rebound_name Id
x Name
n = forall a. NamedThing a => a -> FastString
getOccFS (Id -> Name
idName Id
x) forall a. Eq a => a -> a -> Bool
== forall a. NamedThing a => a -> FastString
getOccFS Name
n
instance Outputable PmLitValue where
ppr :: PmLitValue -> SDoc
ppr (PmLitInt Integer
i) = forall a. Outputable a => a -> SDoc
ppr Integer
i
ppr (PmLitRat Rational
r) = forall a. Outputable a => a -> SDoc
ppr (Double -> SDoc
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 (forall a. Outputable a => a -> SDoc
ppr Integer
i)
ppr (PmLitOverRat Int
n FractionalLit
r) = Int -> SDoc -> SDoc
minuses Int
n (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 = forall a. (a -> a) -> a -> [a]
iterate (\SDoc
sdoc -> SDoc -> SDoc
parens (Char -> SDoc
char Char
'-' SDoc -> SDoc -> SDoc
<> SDoc
sdoc)) SDoc
sdoc forall a. [a] -> Int -> a
!! Int
n
instance Outputable PmLit where
ppr :: PmLit -> SDoc
ppr (PmLit Kind
ty PmLitValue
v) = forall a. Outputable a => a -> SDoc
ppr PmLitValue
v SDoc -> SDoc -> SDoc
<> 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 = forall a. a -> Maybe a -> a
fromMaybe SDoc
empty (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Kind -> Kind -> Bool
eqType Kind
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Kind, SDoc)]
tbl)
instance Outputable PmAltCon where
ppr :: PmAltCon -> SDoc
ppr (PmAltConLike ConLike
cl) = forall a. Outputable a => a -> SDoc
ppr ConLike
cl
ppr (PmAltLit PmLit
l) = forall a. Outputable a => a -> SDoc
ppr PmLit
l
instance Outputable PmEquality where
ppr :: PmEquality -> SDoc
ppr = String -> SDoc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show