{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
module Network.MessagePack.Rpc
( I.Doc (..)
, I.Returns
, I.ReturnsM
, method
, rpc
, docs
, stubs, Rpc, RpcT (local)
) where
import Control.Monad.Catch (MonadThrow)
import Data.Kind (Type)
import Data.Text (Text)
import qualified Network.MessagePack.Interface as I
import qualified Network.MessagePack.Types.Client as Client
import qualified Network.MessagePack.Types.Server as Server
import Network.MessagePack.Client.Basic ()
import Network.MessagePack.Server.Basic ()
class RpcService rpc where
type ClientMonad rpc :: Type -> Type
type ServerMonad rpc :: Type -> Type
type F rpc
rpc :: rpc -> I.ClientType (ClientMonad rpc) (F rpc)
method :: rpc -> Server.Method (ServerMonad rpc)
docs :: rpc -> (Text, I.Doc (F rpc))
type Rpc f = RpcT IO IO f
data RpcT mc ms f = RpcT
{ RpcT mc ms f -> ClientType mc f
rpcPure :: !(I.ClientType mc f)
, RpcT mc ms f -> HaskellType f
local :: !(I.HaskellType f)
, RpcT mc ms f -> Method ms
methodPure :: !(Server.Method ms)
, RpcT mc ms f -> Interface f
intfPure :: !(I.Interface f)
}
instance forall mc ms (f :: Type). RpcService (RpcT mc ms f) where
type ClientMonad (RpcT mc ms f) = mc
type ServerMonad (RpcT mc ms f) = ms
type F (RpcT mc ms f) = f
rpc :: RpcT mc ms f
-> ClientType (ClientMonad (RpcT mc ms f)) (F (RpcT mc ms f))
rpc = RpcT mc ms f
-> ClientType (ClientMonad (RpcT mc ms f)) (F (RpcT mc ms f))
forall (mc :: * -> *) (ms :: * -> *) f.
RpcT mc ms f -> ClientType mc f
rpcPure
{-# INLINE rpc #-}
method :: RpcT mc ms f -> Method (ServerMonad (RpcT mc ms f))
method = RpcT mc ms f -> Method (ServerMonad (RpcT mc ms f))
forall (mc :: * -> *) (ms :: * -> *) f. RpcT mc ms f -> Method ms
methodPure
{-# INLINE method #-}
docs :: RpcT mc ms f -> (Text, Doc (F (RpcT mc ms f)))
docs RpcT mc ms f
r = (Method ms -> Text
forall (m :: * -> *). Method m -> Text
Server.methodName (Method ms -> Text) -> Method ms -> Text
forall a b. (a -> b) -> a -> b
$ RpcT mc ms f -> Method (ServerMonad (RpcT mc ms f))
forall rpc. RpcService rpc => rpc -> Method (ServerMonad rpc)
method RpcT mc ms f
r, Interface f -> Doc f
forall f. Interface f -> Doc f
I.docs (Interface f -> Doc f) -> Interface f -> Doc f
forall a b. (a -> b) -> a -> b
$ RpcT mc ms f -> Interface f
forall (mc :: * -> *) (ms :: * -> *) f. RpcT mc ms f -> Interface f
intfPure RpcT mc ms f
r)
{-# INLINE docs #-}
stubs
:: ( Client.RpcType (I.ClientType mc f)
, Server.MethodType ms (I.ServerType ms f)
, I.IsReturnType ms f
, I.IsDocType f
, MonadThrow ms
)
=> Text -> I.Doc f -> I.HaskellType f -> RpcT mc ms f
stubs :: Text -> Doc f -> HaskellType f -> RpcT mc ms f
stubs Text
n Doc f
doc HaskellType f
f = ClientType mc f
-> HaskellType f -> Method ms -> Interface f -> RpcT mc ms f
forall (mc :: * -> *) (ms :: * -> *) f.
ClientType mc f
-> HaskellType f -> Method ms -> Interface f -> RpcT mc ms f
RpcT ClientType mc f
c HaskellType f
f Method ms
m Interface f
i
where
c :: ClientType mc f
c = Text -> ClientType mc f
forall a. RpcType a => Text -> a
Client.call Text
n
m :: Method ms
m = Interface f -> HaskellType f -> Method ms
forall (m :: * -> *) f.
(MonadThrow m, MethodType m (ServerType m f), IsDocType f,
IsReturnType m f) =>
Interface f -> HaskellType f -> Method m
I.method Interface f
i HaskellType f
f
i :: Interface f
i = Text -> Doc f -> Interface f
forall f. Text -> Doc f -> Interface f
I.interface Text
n Doc f
doc