{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Network.MessagePack.Interface.Internal where
import Control.Monad.Catch (MonadThrow)
import Data.Text (Text)
import Data.Typeable (Typeable)
import qualified Network.MessagePack.Internal.TypeUtil as TypeUtil
import qualified Network.MessagePack.Types.Client as Client
import Network.MessagePack.Types.Server (Method, MethodDocs (..),
MethodVal (..))
import qualified Network.MessagePack.Types.Server as Server
data Returns r
data Interface f = Interface
{ name :: !Text
, docs :: !(Doc f)
}
data InterfaceM (m :: * -> *) f = InterfaceM
{ nameM :: !Text
}
interface :: Text -> Doc f -> Interface f
interface = Interface
concrete :: Interface f -> InterfaceM m f
concrete = InterfaceM . name
coerce :: InterfaceM m a -> InterfaceM m b
coerce = InterfaceM . nameM
class IsDocType f where
data Doc f
flatDoc :: Doc f -> MethodDocs
instance Typeable r => IsDocType (Returns r) where
data Doc (Returns r) = Ret Text
deriving (Eq, Read, Show)
flatDoc (Ret x) =
let typeName = TypeUtil.typeName (undefined :: r) in
MethodDocs [] (MethodVal x typeName)
instance (Typeable o, IsDocType r) => IsDocType (o -> r) where
data Doc (o -> r) = Arg Text (Doc r)
flatDoc (Arg o r) =
let doc = flatDoc r in
let typeName = TypeUtil.typeName (undefined :: o) in
doc { methodArgs = MethodVal o typeName : methodArgs doc }
deriving instance Eq (Doc r) => Eq (Doc (o -> r))
deriving instance Read (Doc r) => Read (Doc (o -> r))
deriving instance Show (Doc r) => Show (Doc (o -> r))
class IsClientType (m :: * -> *) f where
type ClientType m f
instance IsClientType m r => IsClientType m (o -> r) where
type ClientType m (o -> r) = o -> ClientType m r
call :: Client.RpcType (ClientType m f) => InterfaceM m f -> ClientType m f
call = Client.call . nameM
class IsReturnType (m :: * -> *) f where
type HaskellType f
type ServerType m f
implement :: InterfaceM m f -> HaskellType f -> ServerType m f
instance IsReturnType m r => IsReturnType m (o -> r) where
type HaskellType (o -> r) = o -> HaskellType r
type ServerType m (o -> r) = o -> ServerType m r
implement i f a = next (coerce i) (f a)
where
next :: InterfaceM m r -> HaskellType r -> ServerType m r
next = implement
methodM
:: ( Server.MethodType m (ServerType m f)
, IsDocType f
, IsReturnType m f
, MonadThrow m
)
=> InterfaceM m f -> Doc f -> HaskellType f -> Method m
methodM i doc f = Server.method (nameM i) (flatDoc doc) (implement i f)
method
:: ( MonadThrow m
, Server.MethodType m (ServerType m f)
, IsDocType f
, IsReturnType m f)
=> Interface f -> HaskellType f -> Method m
method i = methodM (concrete i) (docs i)
class IsReturnTypeIO (m :: * -> *) f where
type HaskellTypeIO f
type ServerTypeIO m f
implementIO :: InterfaceM m f -> HaskellTypeIO f -> ServerTypeIO m f
instance IsReturnTypeIO m r => IsReturnTypeIO m (o -> r) where
type HaskellTypeIO (o -> r) = o -> HaskellTypeIO r
type ServerTypeIO m (o -> r) = o -> ServerTypeIO m r
implementIO i f a = next (coerce i) (f a)
where
next :: InterfaceM m r -> HaskellTypeIO r -> ServerTypeIO m r
next = implementIO
methodIOM
:: ( Server.MethodType m (ServerTypeIO m f)
, IsDocType f
, IsReturnTypeIO m f
)
=> InterfaceM m f -> Doc f -> HaskellTypeIO f -> Method m
methodIOM i doc f = Server.method (nameM i) (flatDoc doc) (implementIO i f)
methodIO
:: ( Server.MethodType m (ServerTypeIO m f)
, IsDocType f
, IsReturnTypeIO m f)
=> Interface f -> HaskellTypeIO f -> Method m
methodIO i = methodIOM (concrete i) (docs i)