module Control.Distributed.Closure.Internal
( Serializable
, Closure(..)
, closure
, unclosure
, cpure
, cap
, cmap
) 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)
import GHC.Fingerprint
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
Closure :: a -> !(Closure a) -> Closure a
newtype DynClosure = DynClosure Any
toDynClosure :: Closure a -> DynClosure
toDynClosure = DynClosure . unsafeCoerce
fromDynClosure :: Typeable a => DynClosure -> Closure a
fromDynClosure (DynClosure x) = unsafeCoerce x
dynClosureApply :: DynClosure -> DynClosure -> DynClosure
dynClosureApply (DynClosure x1) (DynClosure x2) =
case unsafeCoerce x1 of
(clos1 :: Closure (a -> b)) -> case unsafeCoerce x2 of
(clos2 :: Closure a) -> DynClosure $ unsafeCoerce $ Ap clos1 clos2
putClosure :: Closure a -> Put
putClosure (StaticPtr sptr) = putWord8 0 >> put (staticKey sptr)
putClosure (Encoded bs) = putWord8 1 >> put bs
putClosure (Ap clos1 clos2) = putWord8 2 >> putClosure clos1 >> putClosure clos2
putClosure (Closure _ clos) = putClosure clos
getDynClosure :: Get DynClosure
getDynClosure = getWord8 >>= \case
0 -> get >>= \key -> case unsafePerformIO (unsafeLookupStaticPtr key) of
Just sptr -> return $ toDynClosure $ StaticPtr sptr
Nothing -> fail $ "Static pointer lookup failed: " ++ show key
1 -> toDynClosure . Encoded <$> get
2 -> dynClosureApply <$> getDynClosure <*> getDynClosure
_ -> fail "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 = putClosure
get = do
clos <- fromDynClosure <$> getDynClosure
return $ Closure (unclosure clos) clos
closure :: StaticPtr a -> Closure a
closure sptr = Closure (deRefStaticPtr sptr) (StaticPtr sptr)
unclosure :: Closure a -> a
unclosure (StaticPtr sptr) = deRefStaticPtr sptr
unclosure (Encoded x) = x
unclosure (Ap cf cx) = (unclosure cf) (unclosure cx)
unclosure (Closure x _) = x
decodeD :: Dict (Serializable a) -> ByteString -> a
decodeD Dict = decode
cpure :: Closure (Dict (Serializable a)) -> a -> Closure a
cpure cdict x | Dict <- unclosure cdict =
Closure x $
StaticPtr (static decodeD) `cap`
cdict `cap`
Encoded (encode x)
cap :: Typeable a
=> Closure (a -> b)
-> Closure a
-> Closure b
cap (Closure f closf) (Closure x closx) = Closure (f x) (Ap closf closx)
cap closf closx = Ap closf closx
cmap :: Typeable a => StaticPtr (a -> b) -> Closure a -> Closure b
cmap sptr = cap (Closure (deRefStaticPtr sptr) (StaticPtr sptr))