{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
module GHC.HsToCore.PmCheck.Types (
PmLit(..), PmLitValue(..), PmAltCon(..), pmLitType, pmAltConType,
PmEquality(..), eqPmAltCon,
literalToPmLit, negatePmLit, overloadPmLit,
pmLitAsStringLit, coreExprAsPmLit,
ConLikeSet, PossibleMatches(..),
Shared(..), SharedDIdEnv(..), emptySDIE, lookupSDIE, sameRepresentativeSDIE,
setIndirectSDIE, setEntrySDIE, traverseSDIE,
VarInfo(..), TmState(..), TyState(..), Delta(..), initDelta
) where
#include "HsVersions.h"
import GhcPrelude
import Util
import Bag
import FastString
import Var (EvVar)
import Id
import VarEnv
import UniqDSet
import UniqDFM
import Name
import DataCon
import ConLike
import Outputable
import Maybes
import Type
import TyCon
import Literal
import CoreSyn
import CoreMap
import CoreUtils (exprType)
import PrelNames
import TysWiredIn
import TysPrim
import TcType (evVarPred)
import Numeric (fromRat)
import Data.Foldable (find)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Ratio
data PmLit = PmLit
{ PmLit -> Type
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 Rational
| 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
/= :: PmEquality -> PmEquality -> Bool
$c/= :: PmEquality -> PmEquality -> Bool
== :: PmEquality -> PmEquality -> Bool
$c== :: 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
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 Type
t1 PmLitValue
v1) (PmLit Type
t2 PmLitValue
v2)
| Bool -> Bool
not (Type
t1 Type -> Type -> Bool
`eqType` Type
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 Rational
r1) (PmLitOverRat Int
n2 Rational
r2)
| Int
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n2 Bool -> Bool -> Bool
&& Rational
r1 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
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 -> Type
pmLitType (PmLit Type
ty PmLitValue
_) = Type
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
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 -> [Type] -> Type
pmAltConType (PmAltLit PmLit
lit) [Type]
_arg_tys = ASSERT( null _arg_tys ) pmLitType lit
pmAltConType (PmAltConLike ConLike
con) [Type]
arg_tys = ConLike -> [Type] -> Type
conLikeResTy ConLike
con [Type]
arg_tys
literalToPmLit :: Type -> Literal -> Maybe PmLit
literalToPmLit :: Type -> Literal -> Maybe PmLit
literalToPmLit Type
ty Literal
l = Type -> PmLitValue -> PmLit
PmLit Type
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 Type
_) = 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 Type
ty PmLitValue
v) = Type -> PmLitValue -> PmLit
PmLit Type
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 Rational
r) = PmLitValue -> Maybe PmLitValue
forall a. a -> Maybe a
Just (Int -> Rational -> PmLitValue
PmLitOverRat (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Rational
r)
go PmLitValue
_ = Maybe PmLitValue
forall a. Maybe a
Nothing
overloadPmLit :: Type -> PmLit -> Maybe PmLit
overloadPmLit :: Type -> PmLit -> Maybe PmLit
overloadPmLit Type
ty (PmLit Type
_ PmLitValue
v) = Type -> PmLitValue -> PmLit
PmLit Type
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 (Int -> Rational -> PmLitValue
PmLitOverRat Int
0 Rational
r)
go (PmLitString FastString
s)
| Type
ty Type -> Type -> Bool
`eqType` Type
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 PmLitValue
_ = Maybe PmLitValue
forall a. Maybe a
Nothing
pmLitAsStringLit :: PmLit -> Maybe FastString
pmLitAsStringLit :: PmLit -> Maybe FastString
pmLitAsStringLit (PmLit Type
_ (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 Tickish Id
_t CoreExpr
e) = CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
e
coreExprAsPmLit (Lit Literal
l) = Type -> Literal -> Maybe PmLit
literalToPmLit (Literal -> Type
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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DataCon
intDataCon, DataCon
wordDataCon, DataCon
charDataCon, DataCon
floatDataCon, DataCon
doubleDataCon]
-> Type -> Literal -> Maybe PmLit
literalToPmLit (CoreExpr -> Type
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
ratioDataConName
-> Type -> Literal -> Maybe PmLit
literalToPmLit (CoreExpr -> Type
exprType CoreExpr
e) (Rational -> Literal
mkLitDouble (Literal -> Integer
litValue Literal
n Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Literal -> Integer
litValue Literal
d))
(Var Id
x, [CoreExpr]
args)
| [Lit Literal
l] <- (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
forall b. Expr b -> Bool
is_lit) [CoreExpr]
args
, 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
fromIntegerName
-> Type -> Literal -> Maybe PmLit
literalToPmLit (Literal -> Type
literalType Literal
l) Literal
l Maybe PmLit -> (PmLit -> Maybe PmLit) -> Maybe PmLit
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> PmLit -> Maybe PmLit
overloadPmLit (CoreExpr -> Type
exprType CoreExpr
e)
(Var Id
x, [CoreExpr]
args)
| [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
, 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
fromRationalName
-> CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
r Maybe PmLit -> (PmLit -> Maybe PmLit) -> Maybe PmLit
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> PmLit -> Maybe PmLit
overloadPmLit (CoreExpr -> Type
exprType CoreExpr
e)
(Var Id
x, [Type Type
_ty, CoreExpr
_dict, CoreExpr
s])
| Id -> Name
idName Id
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fromStringName
-> CoreExpr -> Maybe PmLit
coreExprAsPmLit CoreExpr
s Maybe PmLit -> (PmLit -> Maybe PmLit) -> Maybe PmLit
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> PmLit -> Maybe PmLit
overloadPmLit (CoreExpr -> Type
exprType CoreExpr
e)
(Var Id
x, [Type Type
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
, Type
ty Type -> Type -> Bool
`eqType` Type
charTy
-> Type -> Literal -> Maybe PmLit
literalToPmLit Type
stringTy (String -> Literal
mkLitString String
"")
(Var Id
x, [Lit Literal
l])
| Id -> Name
idName Id
x Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
unpackCStringName, Name
unpackCStringUtf8Name]
-> Type -> Literal -> Maybe PmLit
literalToPmLit Type
stringTy Literal
l
(CoreExpr, [CoreExpr])
_ -> Maybe PmLit
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 Type
_) = Bool
False
is_ratio CoreExpr
r
| Just (TyCon
tc, [Type]
_) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe (CoreExpr -> Type
exprType CoreExpr
r)
= TyCon -> Name
tyConName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
ratioTyConName
| Bool
otherwise
= Bool
False
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) = SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Double -> SDoc
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 Rational
r) = Int -> SDoc -> SDoc
minuses Int
n (SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Double -> SDoc
double (Rational -> Double
forall a. RealFloat a => Rational -> a
fromRat Rational
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
parens (Char -> SDoc
char Char
'-' SDoc -> SDoc -> SDoc
<> SDoc
sdoc)) SDoc
sdoc [SDoc] -> Int -> SDoc
forall a. [a] -> Int -> a
!! Int
n
instance Outputable PmLit where
ppr :: PmLit -> SDoc
ppr (PmLit Type
ty PmLitValue
v) = PmLitValue -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmLitValue
v SDoc -> SDoc -> SDoc
<> SDoc
suffix
where
tbl :: [(Type, SDoc)]
tbl = [ (Type
intPrimTy, SDoc
primIntSuffix)
, (Type
int64PrimTy, SDoc
primInt64Suffix)
, (Type
wordPrimTy, SDoc
primWordSuffix)
, (Type
word64PrimTy, SDoc
primWord64Suffix)
, (Type
charPrimTy, SDoc
primCharSuffix)
, (Type
floatPrimTy, SDoc
primFloatSuffix)
, (Type
doublePrimTy, SDoc
primDoubleSuffix) ]
suffix :: SDoc
suffix = SDoc -> Maybe SDoc -> SDoc
forall a. a -> Maybe a -> a
fromMaybe SDoc
empty ((Type, SDoc) -> SDoc
forall a b. (a, b) -> b
snd ((Type, SDoc) -> SDoc) -> Maybe (Type, SDoc) -> Maybe SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type, SDoc) -> Bool) -> [(Type, SDoc)] -> Maybe (Type, SDoc)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Type -> Type -> Bool
eqType Type
ty (Type -> Bool) -> ((Type, SDoc) -> Type) -> (Type, SDoc) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type, SDoc) -> Type
forall a b. (a, b) -> a
fst) [(Type, 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
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
type ConLikeSet = UniqDSet ConLike
data PossibleMatches
= PM (NonEmpty.NonEmpty ConLikeSet)
| NoPM
instance Outputable PossibleMatches where
ppr :: PossibleMatches -> SDoc
ppr (PM NonEmpty ConLikeSet
cs) = [ConLikeSet] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (NonEmpty ConLikeSet -> [ConLikeSet]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty ConLikeSet
cs)
ppr PossibleMatches
NoPM = String -> SDoc
text String
"<NoPM>"
data Shared a
= Indirect Id
| Entry a
newtype SharedDIdEnv a
= SDIE { SharedDIdEnv a -> DIdEnv (Shared a)
unSDIE :: DIdEnv (Shared a) }
emptySDIE :: SharedDIdEnv a
emptySDIE :: SharedDIdEnv a
emptySDIE = DIdEnv (Shared a) -> SharedDIdEnv a
forall a. DIdEnv (Shared a) -> SharedDIdEnv a
SDIE DIdEnv (Shared a)
forall a. DVarEnv a
emptyDVarEnv
lookupReprAndEntrySDIE :: SharedDIdEnv a -> Id -> (Id, Maybe a)
lookupReprAndEntrySDIE :: SharedDIdEnv a -> Id -> (Id, Maybe a)
lookupReprAndEntrySDIE sdie :: SharedDIdEnv a
sdie@(SDIE DIdEnv (Shared a)
env) Id
x = case DIdEnv (Shared a) -> Id -> Maybe (Shared a)
forall a. DVarEnv a -> Id -> Maybe a
lookupDVarEnv DIdEnv (Shared a)
env Id
x of
Maybe (Shared a)
Nothing -> (Id
x, Maybe a
forall a. Maybe a
Nothing)
Just (Indirect Id
y) -> SharedDIdEnv a -> Id -> (Id, Maybe a)
forall a. SharedDIdEnv a -> Id -> (Id, Maybe a)
lookupReprAndEntrySDIE SharedDIdEnv a
sdie Id
y
Just (Entry a
a) -> (Id
x, a -> Maybe a
forall a. a -> Maybe a
Just a
a)
lookupSDIE :: SharedDIdEnv a -> Id -> Maybe a
lookupSDIE :: SharedDIdEnv a -> Id -> Maybe a
lookupSDIE SharedDIdEnv a
sdie Id
x = (Id, Maybe a) -> Maybe a
forall a b. (a, b) -> b
snd (SharedDIdEnv a -> Id -> (Id, Maybe a)
forall a. SharedDIdEnv a -> Id -> (Id, Maybe a)
lookupReprAndEntrySDIE SharedDIdEnv a
sdie Id
x)
sameRepresentativeSDIE :: SharedDIdEnv a -> Id -> Id -> Bool
sameRepresentativeSDIE :: SharedDIdEnv a -> Id -> Id -> Bool
sameRepresentativeSDIE SharedDIdEnv a
sdie Id
x Id
y =
(Id, Maybe a) -> Id
forall a b. (a, b) -> a
fst (SharedDIdEnv a -> Id -> (Id, Maybe a)
forall a. SharedDIdEnv a -> Id -> (Id, Maybe a)
lookupReprAndEntrySDIE SharedDIdEnv a
sdie Id
x) Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== (Id, Maybe a) -> Id
forall a b. (a, b) -> a
fst (SharedDIdEnv a -> Id -> (Id, Maybe a)
forall a. SharedDIdEnv a -> Id -> (Id, Maybe a)
lookupReprAndEntrySDIE SharedDIdEnv a
sdie Id
y)
setIndirectSDIE :: SharedDIdEnv a -> Id -> Id -> SharedDIdEnv a
setIndirectSDIE :: SharedDIdEnv a -> Id -> Id -> SharedDIdEnv a
setIndirectSDIE sdie :: SharedDIdEnv a
sdie@(SDIE DIdEnv (Shared a)
env) Id
x Id
y =
DIdEnv (Shared a) -> SharedDIdEnv a
forall a. DIdEnv (Shared a) -> SharedDIdEnv a
SDIE (DIdEnv (Shared a) -> SharedDIdEnv a)
-> DIdEnv (Shared a) -> SharedDIdEnv a
forall a b. (a -> b) -> a -> b
$ DIdEnv (Shared a) -> Id -> Shared a -> DIdEnv (Shared a)
forall a. DVarEnv a -> Id -> a -> DVarEnv a
extendDVarEnv DIdEnv (Shared a)
env ((Id, Maybe a) -> Id
forall a b. (a, b) -> a
fst (SharedDIdEnv a -> Id -> (Id, Maybe a)
forall a. SharedDIdEnv a -> Id -> (Id, Maybe a)
lookupReprAndEntrySDIE SharedDIdEnv a
sdie Id
x)) (Id -> Shared a
forall a. Id -> Shared a
Indirect Id
y)
setEntrySDIE :: SharedDIdEnv a -> Id -> a -> SharedDIdEnv a
setEntrySDIE :: SharedDIdEnv a -> Id -> a -> SharedDIdEnv a
setEntrySDIE sdie :: SharedDIdEnv a
sdie@(SDIE DIdEnv (Shared a)
env) Id
x a
a =
DIdEnv (Shared a) -> SharedDIdEnv a
forall a. DIdEnv (Shared a) -> SharedDIdEnv a
SDIE (DIdEnv (Shared a) -> SharedDIdEnv a)
-> DIdEnv (Shared a) -> SharedDIdEnv a
forall a b. (a -> b) -> a -> b
$ DIdEnv (Shared a) -> Id -> Shared a -> DIdEnv (Shared a)
forall a. DVarEnv a -> Id -> a -> DVarEnv a
extendDVarEnv DIdEnv (Shared a)
env ((Id, Maybe a) -> Id
forall a b. (a, b) -> a
fst (SharedDIdEnv a -> Id -> (Id, Maybe a)
forall a. SharedDIdEnv a -> Id -> (Id, Maybe a)
lookupReprAndEntrySDIE SharedDIdEnv a
sdie Id
x)) (a -> Shared a
forall a. a -> Shared a
Entry a
a)
traverseSDIE :: Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b)
traverseSDIE :: (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b)
traverseSDIE a -> f b
f = ([(Unique, Shared b)] -> SharedDIdEnv b)
-> f [(Unique, Shared b)] -> f (SharedDIdEnv b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DIdEnv (Shared b) -> SharedDIdEnv b
forall a. DIdEnv (Shared a) -> SharedDIdEnv a
SDIE (DIdEnv (Shared b) -> SharedDIdEnv b)
-> ([(Unique, Shared b)] -> DIdEnv (Shared b))
-> [(Unique, Shared b)]
-> SharedDIdEnv b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Unique, Shared b)] -> DIdEnv (Shared b)
forall key elt. Uniquable key => [(key, elt)] -> UniqDFM elt
listToUDFM) (f [(Unique, Shared b)] -> f (SharedDIdEnv b))
-> (SharedDIdEnv a -> f [(Unique, Shared b)])
-> SharedDIdEnv a
-> f (SharedDIdEnv b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Unique, Shared a) -> f (Unique, Shared b))
-> [(Unique, Shared a)] -> f [(Unique, Shared b)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Unique, Shared a) -> f (Unique, Shared b)
forall t. (t, Shared a) -> f (t, Shared b)
g ([(Unique, Shared a)] -> f [(Unique, Shared b)])
-> (SharedDIdEnv a -> [(Unique, Shared a)])
-> SharedDIdEnv a
-> f [(Unique, Shared b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqDFM (Shared a) -> [(Unique, Shared a)]
forall elt. UniqDFM elt -> [(Unique, elt)]
udfmToList (UniqDFM (Shared a) -> [(Unique, Shared a)])
-> (SharedDIdEnv a -> UniqDFM (Shared a))
-> SharedDIdEnv a
-> [(Unique, Shared a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SharedDIdEnv a -> UniqDFM (Shared a)
forall a. SharedDIdEnv a -> DIdEnv (Shared a)
unSDIE
where
g :: (t, Shared a) -> f (t, Shared b)
g (t
u, Indirect Id
y) = (t, Shared b) -> f (t, Shared b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
u,Id -> Shared b
forall a. Id -> Shared a
Indirect Id
y)
g (t
u, Entry a
a) = (t
u,) (Shared b -> (t, Shared b))
-> (b -> Shared b) -> b -> (t, Shared b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Shared b
forall a. a -> Shared a
Entry (b -> (t, Shared b)) -> f b -> f (t, Shared b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
instance Outputable a => Outputable (Shared a) where
ppr :: Shared a -> SDoc
ppr (Indirect Id
x) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x
ppr (Entry a
a) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
a
instance Outputable a => Outputable (SharedDIdEnv a) where
ppr :: SharedDIdEnv a -> SDoc
ppr (SDIE DIdEnv (Shared a)
env) = DIdEnv (Shared a) -> SDoc
forall a. Outputable a => a -> SDoc
ppr DIdEnv (Shared a)
env
data TmState
= TmSt
{ TmState -> SharedDIdEnv VarInfo
ts_facts :: !(SharedDIdEnv VarInfo)
, TmState -> CoreMap Id
ts_reps :: !(CoreMap Id)
}
data VarInfo
= VI
{ VarInfo -> Type
vi_ty :: !Type
, VarInfo -> [(PmAltCon, [Id])]
vi_pos :: ![(PmAltCon, [Id])]
, VarInfo -> [PmAltCon]
vi_neg :: ![PmAltCon]
, VarInfo -> PossibleMatches
vi_cache :: !PossibleMatches
}
instance Outputable TmState where
ppr :: TmState -> SDoc
ppr (TmSt SharedDIdEnv VarInfo
state CoreMap Id
reps) = SharedDIdEnv VarInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SharedDIdEnv VarInfo
state SDoc -> SDoc -> SDoc
$$ CoreMap Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreMap Id
reps
instance Outputable VarInfo where
ppr :: VarInfo -> SDoc
ppr (VI Type
ty [(PmAltCon, [Id])]
pos [PmAltCon]
neg PossibleMatches
cache)
= SDoc -> SDoc
braces ([SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty, [(PmAltCon, [Id])] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(PmAltCon, [Id])]
pos, [PmAltCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PmAltCon]
neg, PossibleMatches -> SDoc
forall a. Outputable a => a -> SDoc
ppr PossibleMatches
cache]))
initTmState :: TmState
initTmState :: TmState
initTmState = SharedDIdEnv VarInfo -> CoreMap Id -> TmState
TmSt SharedDIdEnv VarInfo
forall a. SharedDIdEnv a
emptySDIE CoreMap Id
forall a. CoreMap a
emptyCoreMap
newtype TyState = TySt (Bag EvVar)
instance Outputable TyState where
ppr :: TyState -> SDoc
ppr (TySt Bag Id
evs)
= SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> (Id -> Type) -> Id -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
evVarPred) ([Id] -> [SDoc]) -> [Id] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ Bag Id -> [Id]
forall a. Bag a -> [a]
bagToList Bag Id
evs
initTyState :: TyState
initTyState :: TyState
initTyState = Bag Id -> TyState
TySt Bag Id
forall a. Bag a
emptyBag
data Delta = MkDelta { Delta -> TyState
delta_ty_st :: TyState
, Delta -> TmState
delta_tm_st :: TmState }
initDelta :: Delta
initDelta :: Delta
initDelta = TyState -> TmState -> Delta
MkDelta TyState
initTyState TmState
initTmState
instance Outputable Delta where
ppr :: Delta -> SDoc
ppr Delta
delta = [SDoc] -> SDoc
vcat [
TmState -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Delta -> TmState
delta_tm_st Delta
delta),
TyState -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Delta -> TyState
delta_ty_st Delta
delta)
]