{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StaticPointers #-}

-- | Private internals. You should not use this module unless you are determined
-- to monkey with the internals. This module comes with no API stability
-- guarantees whatsoever. Use at your own risks.

#if !MIN_VERSION_binary(0,7,6)
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for binary < 0.7.6 compat.
#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) -- for dynClosureApply
import System.IO.Unsafe (unsafePerformIO)

-- | Values that can be sent across the network.
type Serializable a = (Binary a, Typeable a)

-- | Type of serializable closures. Abstractly speaking, a closure is a code
-- reference paired together with an environment. A serializable closure
-- includes a /shareable/ code reference (i.e. a 'StaticPtr'). Closures can be
-- serialized only if all expressions captured in the environment are
-- serializable.
data Closure a where
  -- XXX Can't unpack because of https://ghc.haskell.org/trac/ghc/ticket/12622.
  StaticPtr :: !(StaticPtr a) -> Closure a
  Encoded :: !ByteString -> Closure ByteString
  Ap :: !(Closure (a -> b)) -> !(Closure a) -> Closure b
  Duplicate :: Closure a -> Closure (Closure a)
  -- Cache the value a closure resolves to.
  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

-- Will be obsoleted by https://ghc.haskell.org/trac/ghc/wiki/Typeable. We use
-- our own datatype instead of Dynamic in order to support dynClosureApply.
newtype DynClosure = DynClosure Any -- invariant: only values of type Closure.

-- | Until GHC.StaticPtr can give us a proper TypeRep upon decoding, we have to
-- pretend that this function doesn't need a 'Typeable' constraint to be safe.
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

-- | Until GHC.StaticPtr can give us a proper TypeRep upon decoding, we have to
-- pretend that serializing/deserializing a @'Closure' a@ without a @'Typeable'
-- a@ constraint, i.e. for /any/ @a@, is safe.
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)
-- Orphan instance
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

-- | Lift a Static pointer to a closure with an empty environment.
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)

-- | Resolve a 'Closure' to the value that it represents. Calling 'unclosure'
-- multiple times on the same closure is efficient: for most argument values the
-- result is memoized.
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

-- | Turn a closure into a closure of a closure.
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

-- | A closure can be created from any serializable value. 'cpure' corresponds
-- to "Control.Applicative"'s 'Control.Applicative.pure', but restricted to
-- lifting serializable values only.
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)

-- | Closure application. Note that 'Closure' is not a functor, let alone an
-- applicative functor, even if it too has a meaningful notion of application.
cap :: Typeable a          -- XXX 'Typeable' constraint only for forward compat.
    => 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

-- | Nested closure application.
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

-- | 'Closure' is not a 'Functor', in that we cannot map arbitrary functions
-- over it. That is, we cannot define 'fmap'. However, we can map a static
-- pointer to a function over a 'Closure'.
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." #-}