{-# LANGUAGE ScopedTypeVariables
  , MultiParamTypeClasses
  , FlexibleInstances
  , FunctionalDependencies
  , FlexibleContexts
  , UndecidableInstances
  , KindSignatures
  , GADTs
  , EmptyDataDecls
  , TypeOperators
  , DeriveDataTypeable #-}
module Control.Distributed.Process.Internal.Closure.Explicit
  (
    RemoteRegister
  , MkTDict(..)
  , mkStaticVal
  , mkClosureValSingle
  , mkClosureVal
  , call'
  ) where

import Control.Distributed.Static
import Control.Distributed.Process.Serializable
import Control.Distributed.Process.Internal.Closure.BuiltIn
  ( -- Static dictionaries and associated operations
    staticDecode
  )
import Control.Distributed.Process
import Data.Rank1Dynamic
import Data.Rank1Typeable
import Data.Binary(encode,put,get,Binary)
import qualified Data.ByteString.Lazy as B
import Data.Kind (Type)

-- | A RemoteRegister is a trasformer on a RemoteTable to register additional static values.
type RemoteRegister = RemoteTable -> RemoteTable

-- | This takes an explicit name and a value, and produces both a static reference to the name and a RemoteRegister for it.
mkStaticVal :: Serializable a => String -> a -> (Static a, RemoteRegister)
mkStaticVal :: forall a.
Serializable a =>
String -> a -> (Static a, RemoteRegister)
mkStaticVal String
n a
v = (String -> Static a
forall a. String -> Static a
staticLabel String
n_s, String -> Dynamic -> RemoteRegister
registerStatic String
n_s (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDynamic a
v))
    where n_s :: String
n_s = String
n

class MkTDict a where
    mkTDict :: String -> a -> RemoteRegister

instance (Serializable b) => MkTDict (Process b) where
    mkTDict :: String -> Process b -> RemoteRegister
mkTDict String
_ Process b
_ = String -> Dynamic -> RemoteRegister
registerStatic (TypeRep -> String
forall a. Show a => a -> String
show (b -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (b
forall a. HasCallStack => a
undefined :: b)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__staticDict") (SerializableDict b -> Dynamic
forall a. Typeable a => a -> Dynamic
toDynamic (SerializableDict b
forall a. Serializable a => SerializableDict a
SerializableDict :: SerializableDict b))

instance MkTDict a where
    mkTDict :: String -> a -> RemoteRegister
mkTDict String
_ a
_ = RemoteRegister
forall a. a -> a
id

-- | This takes an explicit name, a function of arity one, and creates a creates a function yielding a closure and a remote register for it.
mkClosureValSingle :: forall a b. (Serializable a, Typeable b, MkTDict b) => String -> (a -> b) -> (a -> Closure b, RemoteRegister)
mkClosureValSingle :: forall a b.
(Serializable a, Typeable b, MkTDict b) =>
String -> (a -> b) -> (a -> Closure b, RemoteRegister)
mkClosureValSingle String
n a -> b
v = (a -> Closure b
c, String -> Dynamic -> RemoteRegister
registerStatic String
n_s ((a -> b) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDynamic a -> b
v) RemoteRegister -> RemoteRegister -> RemoteRegister
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                             String -> Dynamic -> RemoteRegister
registerStatic String
n_sdict (SerializableDict a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDynamic SerializableDict a
sdict) RemoteRegister -> RemoteRegister -> RemoteRegister
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                             String -> b -> RemoteRegister
forall a. MkTDict a => String -> a -> RemoteRegister
mkTDict String
n_tdict (b
forall a. HasCallStack => a
undefined :: b)
                         ) where
    n_s :: String
n_s = String
n
    n_sdict :: String
n_sdict = String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__sdict"
    n_tdict :: String
n_tdict = String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__tdict"

    c :: a -> Closure b
c = Static (ByteString -> b) -> ByteString -> Closure b
forall a. Static (ByteString -> a) -> ByteString -> Closure a
closure Static (ByteString -> b)
decoder (ByteString -> Closure b) -> (a -> ByteString) -> a -> Closure b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Binary a => a -> ByteString
encode

    decoder :: Static (ByteString -> b)
decoder = (String -> Static (a -> b)
forall a. String -> Static a
staticLabel String
n_s :: Static (a -> b)) Static (a -> b)
-> Static (ByteString -> a) -> Static (ByteString -> b)
forall b c a. Static (b -> c) -> Static (a -> b) -> Static (a -> c)
`staticCompose` Static (SerializableDict a) -> Static (ByteString -> a)
forall a.
Typeable a =>
Static (SerializableDict a) -> Static (ByteString -> a)
staticDecode (String -> Static (SerializableDict a)
forall a. String -> Static a
staticLabel String
n_sdict :: Static (SerializableDict a))

    sdict :: (SerializableDict a)
    sdict :: SerializableDict a
sdict = SerializableDict a
forall a. Serializable a => SerializableDict a
SerializableDict

-- | This takes an explict name, a function of any arity, and creates a function yielding a closure and a remote register for it.
mkClosureVal :: forall func argTuple result closureFunction.
                (Curry (argTuple -> Closure result) closureFunction,
                 MkTDict result,
                 Uncurry HTrue argTuple func result,
                 Typeable result, Serializable argTuple, IsFunction func HTrue) =>
                String -> func -> (closureFunction, RemoteRegister)
mkClosureVal :: forall func argTuple result closureFunction.
(Curry (argTuple -> Closure result) closureFunction,
 MkTDict result, Uncurry HTrue argTuple func result,
 Typeable result, Serializable argTuple, IsFunction func HTrue) =>
String -> func -> (closureFunction, RemoteRegister)
mkClosureVal String
n func
v = ((argTuple -> Closure result) -> closureFunction
forall a b. Curry a b => a -> b
curryFun argTuple -> Closure result
c, RemoteRegister
rtable)
    where
      uv :: argTuple -> result
      uv :: argTuple -> result
uv = Fun argTuple func result -> func -> argTuple -> result
forall args func result.
Fun args func result -> func -> args -> result
uncurry' Fun argTuple func result
forall args func result.
Uncurry'' args func result =>
Fun args func result
reify func
v

      n_s :: String
n_s = String
n
      n_sdict :: String
n_sdict = String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__sdict"
      n_tdict :: String
n_tdict = String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__tdict"

      c :: argTuple -> Closure result
      c :: argTuple -> Closure result
c = Static (ByteString -> result) -> ByteString -> Closure result
forall a. Static (ByteString -> a) -> ByteString -> Closure a
closure Static (ByteString -> result)
decoder (ByteString -> Closure result)
-> (argTuple -> ByteString) -> argTuple -> Closure result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. argTuple -> ByteString
forall a. Binary a => a -> ByteString
encode

      decoder :: Static (B.ByteString -> result)
      decoder :: Static (ByteString -> result)
decoder = (String -> Static (argTuple -> result)
forall a. String -> Static a
staticLabel String
n_s :: Static (argTuple -> result)) Static (argTuple -> result)
-> Static (ByteString -> argTuple) -> Static (ByteString -> result)
forall b c a. Static (b -> c) -> Static (a -> b) -> Static (a -> c)
`staticCompose` Static (SerializableDict argTuple)
-> Static (ByteString -> argTuple)
forall a.
Typeable a =>
Static (SerializableDict a) -> Static (ByteString -> a)
staticDecode (String -> Static (SerializableDict argTuple)
forall a. String -> Static a
staticLabel String
n_sdict :: Static (SerializableDict argTuple))

      rtable :: RemoteRegister
rtable = String -> Dynamic -> RemoteRegister
registerStatic String
n_s ((argTuple -> result) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDynamic argTuple -> result
uv) RemoteRegister -> RemoteRegister -> RemoteRegister
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               String -> Dynamic -> RemoteRegister
registerStatic String
n_sdict (SerializableDict argTuple -> Dynamic
forall a. Typeable a => a -> Dynamic
toDynamic SerializableDict argTuple
sdict) RemoteRegister -> RemoteRegister -> RemoteRegister
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               String -> result -> RemoteRegister
forall a. MkTDict a => String -> a -> RemoteRegister
mkTDict String
n_tdict (result
forall a. HasCallStack => a
undefined :: result)


      sdict :: (SerializableDict argTuple)
      sdict :: SerializableDict argTuple
sdict = SerializableDict argTuple
forall a. Serializable a => SerializableDict a
SerializableDict

-- | Works just like standard call, but with a simpler signature.
call' :: forall a. Serializable a => NodeId -> Closure (Process a) -> Process a
call' :: forall a.
Serializable a =>
NodeId -> Closure (Process a) -> Process a
call' = Static (SerializableDict a)
-> NodeId -> Closure (Process a) -> Process a
forall a.
Serializable a =>
Static (SerializableDict a)
-> NodeId -> Closure (Process a) -> Process a
call (String -> Static (SerializableDict a)
forall a. String -> Static a
staticLabel (String -> Static (SerializableDict a))
-> String -> Static (SerializableDict a)
forall a b. (a -> b) -> a -> b
$ (TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a -> TypeRep) -> a -> TypeRep
forall a b. (a -> b) -> a -> b
$ (a
forall a. HasCallStack => a
undefined :: a)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"__staticDict")


data EndOfTuple deriving Typeable
instance Binary EndOfTuple where
    put :: EndOfTuple -> Put
put EndOfTuple
_ = () -> Put
forall a. a -> PutM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    get :: Get EndOfTuple
get = EndOfTuple -> Get EndOfTuple
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return EndOfTuple
forall a. HasCallStack => a
undefined

-- This generic curry is straightforward
class Curry a b | a -> b where
    curryFun :: a -> b

instance Curry ((a, EndOfTuple) -> b) (a -> b) where
    curryFun :: ((a, EndOfTuple) -> b) -> a -> b
curryFun (a, EndOfTuple) -> b
f = \a
x -> (a, EndOfTuple) -> b
f (a
x,EndOfTuple
forall a. HasCallStack => a
undefined)

instance Curry (b -> c) r => Curry ((a,b) -> c) (a -> r) where
    curryFun :: ((a, b) -> c) -> a -> r
curryFun (a, b) -> c
f = \a
x -> (b -> c) -> r
forall a b. Curry a b => a -> b
curryFun (\b
y -> ((a, b) -> c
f (a
x,b
y)))


-- This generic uncurry courtesy Andrea Vezzosi
data HTrue
data HFalse
data Fun :: Type -> Type -> Type -> Type where
  Done :: Fun EndOfTuple r r
  Moar :: Fun xs f r -> Fun (x,xs) (x -> f) r

class Uncurry'' args func result | func -> args, func -> result, args result -> func where
    reify :: Fun args func result

class Uncurry flag args func result | flag func -> args, flag func -> result, args result -> func where
    reify' :: flag -> Fun args func result

instance Uncurry'' rest f r => Uncurry HTrue (a,rest) (a -> f) r where
    reify' :: HTrue -> Fun (a, rest) (a -> f) r
reify' HTrue
_ = Fun rest f r -> Fun (a, rest) (a -> f) r
forall xs f r x. Fun xs f r -> Fun (x, xs) (x -> f) r
Moar Fun rest f r
forall args func result.
Uncurry'' args func result =>
Fun args func result
reify

instance Uncurry HFalse EndOfTuple a a where
    reify' :: HFalse -> Fun EndOfTuple a a
reify' HFalse
_ = Fun EndOfTuple a a
forall r. Fun EndOfTuple r r
Done

instance (IsFunction func b, Uncurry b args func result) => Uncurry'' args func result where
    reify :: Fun args func result
reify = b -> Fun args func result
forall flag args func result.
Uncurry flag args func result =>
flag -> Fun args func result
reify' (b
forall a. HasCallStack => a
undefined :: b)

uncurry' :: Fun args func result -> func -> args -> result
uncurry' :: forall args func result.
Fun args func result -> func -> args -> result
uncurry' Fun args func result
Done func
r args
_ = func
result
r
uncurry' (Moar Fun xs f result
fun) func
f (x
x,xs
xs) = Fun xs f result -> f -> xs -> result
forall args func result.
Fun args func result -> func -> args -> result
uncurry' Fun xs f result
fun (func
x -> f
f x
x) xs
xs

class IsFunction t b | t -> b
instance (b ~ HTrue) => IsFunction (a -> c) b
instance (b ~ HFalse) => IsFunction a b