{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StaticPointers #-}
#if !MIN_VERSION_binary(0,7,6)
{-# OPTIONS_GHC -fno-warn-orphans #-}
#endif
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
module Control.Distributed.Closure.Internal
( Serializable
, Closure(..)
, closure
, unclosure
, cpure
, cap
, capDup
, cmap
, cduplicate
) where
import Data.Binary (Binary(..), Get, Put, decode, encode)
import Data.Binary.Put (putWord8)
import Data.Binary.Get (getWord8)
import Data.Constraint (Dict(..))
import Data.Typeable (Typeable)
import Data.ByteString.Lazy (ByteString)
import GHC.Base (Any)
#if !MIN_VERSION_binary(0,7,6)
import GHC.Fingerprint
#endif
import GHC.StaticPtr
import Unsafe.Coerce (unsafeCoerce)
import System.IO.Unsafe (unsafePerformIO)
type Serializable a = (Binary a, Typeable a)
data Closure a where
StaticPtr :: !(StaticPtr a) -> Closure a
Encoded :: !ByteString -> Closure ByteString
Ap :: !(Closure (a -> b)) -> !(Closure a) -> Closure b
Duplicate :: Closure a -> Closure (Closure a)
Closure :: a -> !(Closure a) -> Closure a
#if MIN_VERSION_base(4,9,0)
instance IsStatic Closure where
fromStaticPtr :: forall a. StaticPtr a -> Closure a
fromStaticPtr = forall a. StaticPtr a -> Closure a
closure
#endif
newtype DynClosure = DynClosure Any
toDynClosure :: Closure a -> DynClosure
toDynClosure :: forall a. Closure a -> DynClosure
toDynClosure = Any -> DynClosure
DynClosure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b
unsafeCoerce
fromDynClosure :: Typeable a => DynClosure -> Closure a
fromDynClosure :: forall a. Typeable a => DynClosure -> Closure a
fromDynClosure (DynClosure Any
x) = forall a b. a -> b
unsafeCoerce Any
x
dynClosureApply :: DynClosure -> DynClosure -> DynClosure
dynClosureApply :: DynClosure -> DynClosure -> DynClosure
dynClosureApply (DynClosure Any
x1) (DynClosure Any
x2) =
case forall a b. a -> b
unsafeCoerce Any
x1 of
(Closure (Any -> Any)
clos1 :: Closure (a -> b)) -> case forall a b. a -> b
unsafeCoerce Any
x2 of
(Closure Any
clos2 :: Closure a) -> Any -> DynClosure
DynClosure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b
unsafeCoerce forall a b. (a -> b) -> a -> b
$ forall a b. Closure (a -> b) -> Closure a -> Closure b
Ap Closure (Any -> Any)
clos1 Closure Any
clos2
dynClosureDuplicate :: DynClosure -> DynClosure
dynClosureDuplicate :: DynClosure -> DynClosure
dynClosureDuplicate (DynClosure Any
x) =
Any -> DynClosure
DynClosure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b
unsafeCoerce forall a b. (a -> b) -> a -> b
$ forall a. Closure a -> Closure (Closure a)
Duplicate forall a b. (a -> b) -> a -> b
$ forall a b. a -> b
unsafeCoerce Any
x
putClosure :: Closure a -> Put
putClosure :: forall a. Closure a -> Put
putClosure (StaticPtr StaticPtr a
sptr) = Word8 -> Put
putWord8 Word8
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put (forall a. StaticPtr a -> StaticKey
staticKey StaticPtr a
sptr)
putClosure (Encoded ByteString
bs) = Word8 -> Put
putWord8 Word8
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put ByteString
bs
putClosure (Ap Closure (a -> a)
clos1 Closure a
clos2) = Word8 -> Put
putWord8 Word8
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Closure a -> Put
putClosure Closure (a -> a)
clos1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Closure a -> Put
putClosure Closure a
clos2
putClosure (Closure a
_ Closure a
clos) = forall a. Closure a -> Put
putClosure Closure a
clos
putClosure (Duplicate Closure a
clos) = Word8 -> Put
putWord8 Word8
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Closure a -> Put
putClosure Closure a
clos
getDynClosure :: Get DynClosure
getDynClosure :: Get DynClosure
getDynClosure = Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Word8
0 -> forall t. Binary t => Get t
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \StaticKey
key -> case forall a. IO a -> a
unsafePerformIO (forall a. StaticKey -> IO (Maybe (StaticPtr a))
unsafeLookupStaticPtr StaticKey
key) of
Just StaticPtr Any
sptr -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Closure a -> DynClosure
toDynClosure forall a b. (a -> b) -> a -> b
$ forall a. StaticPtr a -> Closure a
StaticPtr StaticPtr Any
sptr
Maybe (StaticPtr Any)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Static pointer lookup failed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StaticKey
key
Word8
1 -> forall a. Closure a -> DynClosure
toDynClosure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Closure ByteString
Encoded forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get
Word8
2 -> DynClosure -> DynClosure -> DynClosure
dynClosureApply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get DynClosure
getDynClosure forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get DynClosure
getDynClosure
Word8
3 -> DynClosure -> DynClosure
dynClosureDuplicate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get DynClosure
getDynClosure
Word8
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Binary.get(Closure): unrecognized tag."
#if !MIN_VERSION_binary(0,7,6)
instance Binary Fingerprint where
put (Fingerprint x1 x2) = do
put x1
put x2
get = do
x1 <- get
x2 <- get
return $! Fingerprint x1 x2
#endif
instance Typeable a => Binary (Closure a) where
put :: Closure a -> Put
put = forall a. Closure a -> Put
putClosure
get :: Get (Closure a)
get = do
Closure a
clos <- forall a. Typeable a => DynClosure -> Closure a
fromDynClosure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get DynClosure
getDynClosure
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Closure a -> Closure a
Closure (forall a. Closure a -> a
unclosure Closure a
clos) Closure a
clos
closure :: StaticPtr a -> Closure a
closure :: forall a. StaticPtr a -> Closure a
closure StaticPtr a
sptr = forall a. a -> Closure a -> Closure a
Closure (forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr a
sptr) (forall a. StaticPtr a -> Closure a
StaticPtr StaticPtr a
sptr)
unclosure :: Closure a -> a
unclosure :: forall a. Closure a -> a
unclosure (StaticPtr StaticPtr a
sptr) = forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr a
sptr
unclosure (Encoded ByteString
x) = ByteString
x
unclosure (Ap Closure (a -> a)
cf Closure a
cx) = (forall a. Closure a -> a
unclosure Closure (a -> a)
cf) (forall a. Closure a -> a
unclosure Closure a
cx)
unclosure (Closure a
x Closure a
_) = a
x
unclosure (Duplicate Closure a
x) = Closure a
x
cduplicate :: Closure a -> Closure (Closure a)
cduplicate :: forall a. Closure a -> Closure (Closure a)
cduplicate = forall a. Closure a -> Closure (Closure a)
Duplicate
decodeD :: Dict (Serializable a) -> ByteString -> a
decodeD :: forall a. Dict (Serializable a) -> ByteString -> a
decodeD Dict (Serializable a)
Dict = forall a. Binary a => ByteString -> a
decode
cpure :: Closure (Dict (Serializable a)) -> a -> Closure a
cpure :: forall a. Closure (Dict (Serializable a)) -> a -> Closure a
cpure Closure (Dict (Serializable a))
cdict a
x | Dict (Serializable a)
Dict <- forall a. Closure a -> a
unclosure Closure (Dict (Serializable a))
cdict =
forall a. a -> Closure a -> Closure a
Closure a
x forall a b. (a -> b) -> a -> b
$
forall a. StaticPtr a -> Closure a
StaticPtr (static forall a. Dict (Serializable a) -> ByteString -> a
decodeD) forall a b.
Typeable a =>
Closure (a -> b) -> Closure a -> Closure b
`cap`
Closure (Dict (Serializable a))
cdict forall a b.
Typeable a =>
Closure (a -> b) -> Closure a -> Closure b
`cap`
ByteString -> Closure ByteString
Encoded (forall a. Binary a => a -> ByteString
encode a
x)
cap :: Typeable a
=> Closure (a -> b)
-> Closure a
-> Closure b
cap :: forall a b.
Typeable a =>
Closure (a -> b) -> Closure a -> Closure b
cap (Closure a -> b
f Closure (a -> b)
closf) (Closure a
x Closure a
closx) = forall a. a -> Closure a -> Closure a
Closure (a -> b
f a
x) (forall a b. Closure (a -> b) -> Closure a -> Closure b
Ap Closure (a -> b)
closf Closure a
closx)
cap Closure (a -> b)
closf Closure a
closx = forall a b. Closure (a -> b) -> Closure a -> Closure b
Ap Closure (a -> b)
closf Closure a
closx
capDup :: Typeable a => Closure (Closure a -> b) -> Closure a -> Closure b
capDup :: forall a b.
Typeable a =>
Closure (Closure a -> b) -> Closure a -> Closure b
capDup Closure (Closure a -> b)
cf = forall a b.
Typeable a =>
Closure (a -> b) -> Closure a -> Closure b
cap Closure (Closure a -> b)
cf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Closure a -> Closure (Closure a)
cduplicate
cmap :: Typeable a => StaticPtr (a -> b) -> Closure a -> Closure b
cmap :: forall a b.
Typeable a =>
StaticPtr (a -> b) -> Closure a -> Closure b
cmap StaticPtr (a -> b)
sf = forall a b.
Typeable a =>
Closure (a -> b) -> Closure a -> Closure b
cap (forall a. StaticPtr a -> Closure a
closure StaticPtr (a -> b)
sf)
{-# DEPRECATED cmap "Use staticMap instead." #-}