{-# LANGUAGE GeneralisedNewtypeDeriving #-}
module GHC.Types.Cpr (
CprResult, topCpr, botCpr, conCpr, asConCpr,
CprType (..), topCprType, botCprType, conCprType,
lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy,
CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig
) where
import GHC.Prelude
import GHC.Types.Basic
import GHC.Utils.Outputable
import GHC.Utils.Binary
data CprResult = NoCPR
| ConCPR !ConTag
| BotCPR
deriving( CprResult -> CprResult -> Bool
(CprResult -> CprResult -> Bool)
-> (CprResult -> CprResult -> Bool) -> Eq CprResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CprResult -> CprResult -> Bool
$c/= :: CprResult -> CprResult -> Bool
== :: CprResult -> CprResult -> Bool
$c== :: CprResult -> CprResult -> Bool
Eq, Int -> CprResult -> ShowS
[CprResult] -> ShowS
CprResult -> String
(Int -> CprResult -> ShowS)
-> (CprResult -> String)
-> ([CprResult] -> ShowS)
-> Show CprResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CprResult] -> ShowS
$cshowList :: [CprResult] -> ShowS
show :: CprResult -> String
$cshow :: CprResult -> String
showsPrec :: Int -> CprResult -> ShowS
$cshowsPrec :: Int -> CprResult -> ShowS
Show )
lubCpr :: CprResult -> CprResult -> CprResult
lubCpr :: CprResult -> CprResult -> CprResult
lubCpr (ConCPR Int
t1) (ConCPR Int
t2)
| Int
t1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
t2 = Int -> CprResult
ConCPR Int
t1
lubCpr CprResult
BotCPR CprResult
cpr = CprResult
cpr
lubCpr CprResult
cpr CprResult
BotCPR = CprResult
cpr
lubCpr CprResult
_ CprResult
_ = CprResult
NoCPR
topCpr :: CprResult
topCpr :: CprResult
topCpr = CprResult
NoCPR
botCpr :: CprResult
botCpr :: CprResult
botCpr = CprResult
BotCPR
conCpr :: ConTag -> CprResult
conCpr :: Int -> CprResult
conCpr = Int -> CprResult
ConCPR
trimCpr :: CprResult -> CprResult
trimCpr :: CprResult -> CprResult
trimCpr ConCPR{} = CprResult
NoCPR
trimCpr CprResult
cpr = CprResult
cpr
asConCpr :: CprResult -> Maybe ConTag
asConCpr :: CprResult -> Maybe Int
asConCpr (ConCPR Int
t) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
t
asConCpr CprResult
NoCPR = Maybe Int
forall a. Maybe a
Nothing
asConCpr CprResult
BotCPR = Maybe Int
forall a. Maybe a
Nothing
data CprType
= CprType
{ CprType -> Int
ct_arty :: !Arity
, CprType -> CprResult
ct_cpr :: !CprResult
}
instance Eq CprType where
CprType
a == :: CprType -> CprType -> Bool
== CprType
b = CprType -> CprResult
ct_cpr CprType
a CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprType -> CprResult
ct_cpr CprType
b
Bool -> Bool -> Bool
&& (CprType -> Int
ct_arty CprType
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== CprType -> Int
ct_arty CprType
b Bool -> Bool -> Bool
|| CprType -> CprResult
ct_cpr CprType
a CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprResult
topCpr)
topCprType :: CprType
topCprType :: CprType
topCprType = Int -> CprResult -> CprType
CprType Int
0 CprResult
topCpr
botCprType :: CprType
botCprType :: CprType
botCprType = Int -> CprResult -> CprType
CprType Int
0 CprResult
botCpr
conCprType :: ConTag -> CprType
conCprType :: Int -> CprType
conCprType Int
con_tag = Int -> CprResult -> CprType
CprType Int
0 (Int -> CprResult
conCpr Int
con_tag)
lubCprType :: CprType -> CprType -> CprType
lubCprType :: CprType -> CprType -> CprType
lubCprType ty1 :: CprType
ty1@(CprType Int
n1 CprResult
cpr1) ty2 :: CprType
ty2@(CprType Int
n2 CprResult
cpr2)
| CprResult
cpr1 CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprResult
botCpr Bool -> Bool -> Bool
&& Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n2 = CprType
ty2
| CprResult
cpr2 CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprResult
botCpr Bool -> Bool -> Bool
&& Int
n2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n1 = CprType
ty1
| Int
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n2 = Int -> CprResult -> CprType
CprType Int
n1 (CprResult -> CprResult -> CprResult
lubCpr CprResult
cpr1 CprResult
cpr2)
| Bool
otherwise = CprType
topCprType
applyCprTy :: CprType -> CprType
applyCprTy :: CprType -> CprType
applyCprTy (CprType Int
n CprResult
res)
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int -> CprResult -> CprType
CprType (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) CprResult
res
| CprResult
res CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprResult
botCpr = CprType
botCprType
| Bool
otherwise = CprType
topCprType
abstractCprTy :: CprType -> CprType
abstractCprTy :: CprType -> CprType
abstractCprTy (CprType Int
n CprResult
res)
| CprResult
res CprResult -> CprResult -> Bool
forall a. Eq a => a -> a -> Bool
== CprResult
topCpr = CprType
topCprType
| Bool
otherwise = Int -> CprResult -> CprType
CprType (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CprResult
res
ensureCprTyArity :: Arity -> CprType -> CprType
ensureCprTyArity :: Int -> CprType -> CprType
ensureCprTyArity Int
n ty :: CprType
ty@(CprType Int
m CprResult
_)
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
m = CprType
ty
| Bool
otherwise = CprType
topCprType
trimCprTy :: CprType -> CprType
trimCprTy :: CprType -> CprType
trimCprTy (CprType Int
arty CprResult
res) = Int -> CprResult -> CprType
CprType Int
arty (CprResult -> CprResult
trimCpr CprResult
res)
newtype CprSig = CprSig { CprSig -> CprType
getCprSig :: CprType }
deriving (CprSig -> CprSig -> Bool
(CprSig -> CprSig -> Bool)
-> (CprSig -> CprSig -> Bool) -> Eq CprSig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CprSig -> CprSig -> Bool
$c/= :: CprSig -> CprSig -> Bool
== :: CprSig -> CprSig -> Bool
$c== :: CprSig -> CprSig -> Bool
Eq, BinHandle -> IO CprSig
BinHandle -> CprSig -> IO ()
BinHandle -> CprSig -> IO (Bin CprSig)
(BinHandle -> CprSig -> IO ())
-> (BinHandle -> CprSig -> IO (Bin CprSig))
-> (BinHandle -> IO CprSig)
-> Binary CprSig
forall a.
(BinHandle -> a -> IO ())
-> (BinHandle -> a -> IO (Bin a))
-> (BinHandle -> IO a)
-> Binary a
get :: BinHandle -> IO CprSig
$cget :: BinHandle -> IO CprSig
put :: BinHandle -> CprSig -> IO (Bin CprSig)
$cput :: BinHandle -> CprSig -> IO (Bin CprSig)
put_ :: BinHandle -> CprSig -> IO ()
$cput_ :: BinHandle -> CprSig -> IO ()
Binary)
mkCprSigForArity :: Arity -> CprType -> CprSig
mkCprSigForArity :: Int -> CprType -> CprSig
mkCprSigForArity Int
arty CprType
ty = CprType -> CprSig
CprSig (Int -> CprType -> CprType
ensureCprTyArity Int
arty CprType
ty)
topCprSig :: CprSig
topCprSig :: CprSig
topCprSig = CprType -> CprSig
CprSig CprType
topCprType
mkCprSig :: Arity -> CprResult -> CprSig
mkCprSig :: Int -> CprResult -> CprSig
mkCprSig Int
arty CprResult
cpr = CprType -> CprSig
CprSig (Int -> CprResult -> CprType
CprType Int
arty CprResult
cpr)
seqCprSig :: CprSig -> ()
seqCprSig :: CprSig -> ()
seqCprSig CprSig
sig = CprSig
sig CprSig -> () -> ()
`seq` ()
instance Outputable CprResult where
ppr :: CprResult -> SDoc
ppr CprResult
NoCPR = SDoc
empty
ppr (ConCPR Int
n) = Char -> SDoc
char Char
'm' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
ppr CprResult
BotCPR = Char -> SDoc
char Char
'b'
instance Outputable CprType where
ppr :: CprType -> SDoc
ppr (CprType Int
arty CprResult
res) = Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
arty SDoc -> SDoc -> SDoc
<> CprResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr CprResult
res
instance Outputable CprSig where
ppr :: CprSig -> SDoc
ppr (CprSig CprType
ty) = CprResult -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CprType -> CprResult
ct_cpr CprType
ty)
instance Binary CprResult where
put_ :: BinHandle -> CprResult -> IO ()
put_ BinHandle
bh (ConCPR Int
n) = do { BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0; BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
n }
put_ BinHandle
bh CprResult
NoCPR = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
put_ BinHandle
bh CprResult
BotCPR = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2
get :: BinHandle -> IO CprResult
get BinHandle
bh = do
Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
case Word8
h of
Word8
0 -> do { Int
n <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh; CprResult -> IO CprResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> CprResult
ConCPR Int
n) }
Word8
1 -> CprResult -> IO CprResult
forall (m :: * -> *) a. Monad m => a -> m a
return CprResult
NoCPR
Word8
_ -> CprResult -> IO CprResult
forall (m :: * -> *) a. Monad m => a -> m a
return CprResult
BotCPR
instance Binary CprType where
put_ :: BinHandle -> CprType -> IO ()
put_ BinHandle
bh (CprType Int
arty CprResult
cpr) = do
BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
arty
BinHandle -> CprResult -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh CprResult
cpr
get :: BinHandle -> IO CprType
get BinHandle
bh = Int -> CprResult -> CprType
CprType (Int -> CprResult -> CprType)
-> IO Int -> IO (CprResult -> CprType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (CprResult -> CprType) -> IO CprResult -> IO CprType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO CprResult
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh