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.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."
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))