{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
module Network.MessagePack.Interface
( Interface (..)
, InterfaceM (..)
, IsDocType (..)
, IsClientType (..)
, IsReturnType (..)
, Doc (..)
, Returns
, ReturnsM
, call
, concrete
, interface
, method
) where
import Control.Monad.Catch (MonadThrow)
import Data.Kind (Type)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (Typeable)
import qualified Data.Typeable as Typeable
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 Interface f = Interface
{ Interface f -> Text
name :: Text
, Interface f -> Doc f
docs :: Doc f
}
newtype InterfaceM (m :: Type -> Type) f = InterfaceM
{ InterfaceM m f -> Text
nameM :: Text
}
interface :: Text -> Doc f -> Interface f
interface :: Text -> Doc f -> Interface f
interface = Text -> Doc f -> Interface f
forall f. Text -> Doc f -> Interface f
Interface
concrete :: Interface f -> InterfaceM m f
concrete :: Interface f -> InterfaceM m f
concrete = Text -> InterfaceM m f
forall (m :: * -> *) f. Text -> InterfaceM m f
InterfaceM (Text -> InterfaceM m f)
-> (Interface f -> Text) -> Interface f -> InterfaceM m f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface f -> Text
forall f. Interface f -> Text
name
class IsDocType f where
data Doc f
flatDoc :: Doc f -> MethodDocs
data Returns r
instance Typeable (r :: Type) => IsDocType (Returns r) where
data Doc (Returns r) = Ret Text
deriving (Doc (Returns r) -> Doc (Returns r) -> Bool
(Doc (Returns r) -> Doc (Returns r) -> Bool)
-> (Doc (Returns r) -> Doc (Returns r) -> Bool)
-> Eq (Doc (Returns r))
forall r. Doc (Returns r) -> Doc (Returns r) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Doc (Returns r) -> Doc (Returns r) -> Bool
$c/= :: forall r. Doc (Returns r) -> Doc (Returns r) -> Bool
== :: Doc (Returns r) -> Doc (Returns r) -> Bool
$c== :: forall r. Doc (Returns r) -> Doc (Returns r) -> Bool
Eq, ReadPrec [Doc (Returns r)]
ReadPrec (Doc (Returns r))
Int -> ReadS (Doc (Returns r))
ReadS [Doc (Returns r)]
(Int -> ReadS (Doc (Returns r)))
-> ReadS [Doc (Returns r)]
-> ReadPrec (Doc (Returns r))
-> ReadPrec [Doc (Returns r)]
-> Read (Doc (Returns r))
forall r. ReadPrec [Doc (Returns r)]
forall r. ReadPrec (Doc (Returns r))
forall r. Int -> ReadS (Doc (Returns r))
forall r. ReadS [Doc (Returns r)]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Doc (Returns r)]
$creadListPrec :: forall r. ReadPrec [Doc (Returns r)]
readPrec :: ReadPrec (Doc (Returns r))
$creadPrec :: forall r. ReadPrec (Doc (Returns r))
readList :: ReadS [Doc (Returns r)]
$creadList :: forall r. ReadS [Doc (Returns r)]
readsPrec :: Int -> ReadS (Doc (Returns r))
$creadsPrec :: forall r. Int -> ReadS (Doc (Returns r))
Read, Int -> Doc (Returns r) -> ShowS
[Doc (Returns r)] -> ShowS
Doc (Returns r) -> String
(Int -> Doc (Returns r) -> ShowS)
-> (Doc (Returns r) -> String)
-> ([Doc (Returns r)] -> ShowS)
-> Show (Doc (Returns r))
forall r. Int -> Doc (Returns r) -> ShowS
forall r. [Doc (Returns r)] -> ShowS
forall r. Doc (Returns r) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Doc (Returns r)] -> ShowS
$cshowList :: forall r. [Doc (Returns r)] -> ShowS
show :: Doc (Returns r) -> String
$cshow :: forall r. Doc (Returns r) -> String
showsPrec :: Int -> Doc (Returns r) -> ShowS
$cshowsPrec :: forall r. Int -> Doc (Returns r) -> ShowS
Show)
flatDoc :: Doc (Returns r) -> MethodDocs
flatDoc (Ret retName) =
[MethodVal] -> MethodVal -> MethodDocs
MethodDocs [] (Text -> Text -> MethodVal
MethodVal Text
retName (r -> Text
forall a. Typeable a => a -> Text
typeName (r
forall a. HasCallStack => a
undefined :: r)))
data ReturnsM (m :: Type -> Type) r
instance Typeable (r :: Type) => IsDocType (ReturnsM m r) where
data Doc (ReturnsM m r) = RetM Text
deriving (Doc (ReturnsM m r) -> Doc (ReturnsM m r) -> Bool
(Doc (ReturnsM m r) -> Doc (ReturnsM m r) -> Bool)
-> (Doc (ReturnsM m r) -> Doc (ReturnsM m r) -> Bool)
-> Eq (Doc (ReturnsM m r))
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: * -> *) r.
Doc (ReturnsM m r) -> Doc (ReturnsM m r) -> Bool
/= :: Doc (ReturnsM m r) -> Doc (ReturnsM m r) -> Bool
$c/= :: forall (m :: * -> *) r.
Doc (ReturnsM m r) -> Doc (ReturnsM m r) -> Bool
== :: Doc (ReturnsM m r) -> Doc (ReturnsM m r) -> Bool
$c== :: forall (m :: * -> *) r.
Doc (ReturnsM m r) -> Doc (ReturnsM m r) -> Bool
Eq, ReadPrec [Doc (ReturnsM m r)]
ReadPrec (Doc (ReturnsM m r))
Int -> ReadS (Doc (ReturnsM m r))
ReadS [Doc (ReturnsM m r)]
(Int -> ReadS (Doc (ReturnsM m r)))
-> ReadS [Doc (ReturnsM m r)]
-> ReadPrec (Doc (ReturnsM m r))
-> ReadPrec [Doc (ReturnsM m r)]
-> Read (Doc (ReturnsM m r))
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (m :: * -> *) r. ReadPrec [Doc (ReturnsM m r)]
forall (m :: * -> *) r. ReadPrec (Doc (ReturnsM m r))
forall (m :: * -> *) r. Int -> ReadS (Doc (ReturnsM m r))
forall (m :: * -> *) r. ReadS [Doc (ReturnsM m r)]
readListPrec :: ReadPrec [Doc (ReturnsM m r)]
$creadListPrec :: forall (m :: * -> *) r. ReadPrec [Doc (ReturnsM m r)]
readPrec :: ReadPrec (Doc (ReturnsM m r))
$creadPrec :: forall (m :: * -> *) r. ReadPrec (Doc (ReturnsM m r))
readList :: ReadS [Doc (ReturnsM m r)]
$creadList :: forall (m :: * -> *) r. ReadS [Doc (ReturnsM m r)]
readsPrec :: Int -> ReadS (Doc (ReturnsM m r))
$creadsPrec :: forall (m :: * -> *) r. Int -> ReadS (Doc (ReturnsM m r))
Read, Int -> Doc (ReturnsM m r) -> ShowS
[Doc (ReturnsM m r)] -> ShowS
Doc (ReturnsM m r) -> String
(Int -> Doc (ReturnsM m r) -> ShowS)
-> (Doc (ReturnsM m r) -> String)
-> ([Doc (ReturnsM m r)] -> ShowS)
-> Show (Doc (ReturnsM m r))
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *) r. Int -> Doc (ReturnsM m r) -> ShowS
forall (m :: * -> *) r. [Doc (ReturnsM m r)] -> ShowS
forall (m :: * -> *) r. Doc (ReturnsM m r) -> String
showList :: [Doc (ReturnsM m r)] -> ShowS
$cshowList :: forall (m :: * -> *) r. [Doc (ReturnsM m r)] -> ShowS
show :: Doc (ReturnsM m r) -> String
$cshow :: forall (m :: * -> *) r. Doc (ReturnsM m r) -> String
showsPrec :: Int -> Doc (ReturnsM m r) -> ShowS
$cshowsPrec :: forall (m :: * -> *) r. Int -> Doc (ReturnsM m r) -> ShowS
Show)
flatDoc :: Doc (ReturnsM m r) -> MethodDocs
flatDoc (RetM retName) =
[MethodVal] -> MethodVal -> MethodDocs
MethodDocs [] (Text -> Text -> MethodVal
MethodVal Text
retName (r -> Text
forall a. Typeable a => a -> Text
typeName (r
forall a. HasCallStack => a
undefined :: r)))
instance (Typeable o, IsDocType r) => IsDocType (o -> r) where
data Doc (o -> r) = Arg Text (Doc r)
flatDoc :: Doc (o -> r) -> MethodDocs
flatDoc (Arg o r) =
let doc :: MethodDocs
doc = Doc r -> MethodDocs
forall f. IsDocType f => Doc f -> MethodDocs
flatDoc Doc r
r in
let ty :: Text
ty = o -> Text
forall a. Typeable a => a -> Text
typeName (o
forall a. HasCallStack => a
undefined :: o) in
MethodDocs
doc { methodArgs :: [MethodVal]
methodArgs = Text -> Text -> MethodVal
MethodVal Text
o Text
ty MethodVal -> [MethodVal] -> [MethodVal]
forall a. a -> [a] -> [a]
: MethodDocs -> [MethodVal]
methodArgs MethodDocs
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))
typeName :: Typeable a => a -> Text
typeName :: a -> Text
typeName = Text -> Text -> Text -> Text
Text.replace Text
"[Char]" Text
"String" (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> (a -> TypeRep) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep
forall a. Typeable a => a -> TypeRep
Typeable.typeOf
class IsClientType (m :: Type -> Type) 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 :: InterfaceM m f -> ClientType m f
call = Text -> ClientType m f
forall a. RpcType a => Text -> a
Client.call (Text -> ClientType m f)
-> (InterfaceM m f -> Text) -> InterfaceM m f -> ClientType m f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterfaceM m f -> Text
forall (m :: * -> *) f. InterfaceM m f -> Text
nameM
class IsReturnType (m :: Type -> Type) 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 :: InterfaceM m (o -> r)
-> HaskellType (o -> r) -> ServerType m (o -> r)
implement InterfaceM m (o -> r)
i HaskellType (o -> r)
f o
a = InterfaceM m r -> HaskellType r -> ServerType m r
next (InterfaceM m (o -> r) -> InterfaceM m r
forall a b. InterfaceM m a -> InterfaceM m b
coerce InterfaceM m (o -> r)
i) (HaskellType (o -> r)
o -> HaskellType r
f o
a)
where
next :: InterfaceM m r -> HaskellType r -> ServerType m r
next :: InterfaceM m r -> HaskellType r -> ServerType m r
next = InterfaceM m r -> HaskellType r -> ServerType m r
forall (m :: * -> *) f.
IsReturnType m f =>
InterfaceM m f -> HaskellType f -> ServerType m f
implement
coerce :: InterfaceM m a -> InterfaceM m b
coerce :: InterfaceM m a -> InterfaceM m b
coerce = Text -> InterfaceM m b
forall (m :: * -> *) f. Text -> InterfaceM m f
InterfaceM (Text -> InterfaceM m b)
-> (InterfaceM m a -> Text) -> InterfaceM m a -> InterfaceM m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterfaceM m a -> Text
forall (m :: * -> *) f. InterfaceM m f -> Text
nameM
methodM
:: ( Server.MethodType m (ServerType m f)
, IsDocType f
, IsReturnType m f
, MonadThrow m
)
=> InterfaceM m f -> Doc f -> HaskellType f -> Method m
methodM :: InterfaceM m f -> Doc f -> HaskellType f -> Method m
methodM InterfaceM m f
i Doc f
doc HaskellType f
f = Text -> MethodDocs -> ServerType m f -> Method m
forall (m :: * -> *) f.
MethodType m f =>
Text -> MethodDocs -> f -> Method m
Server.method (InterfaceM m f -> Text
forall (m :: * -> *) f. InterfaceM m f -> Text
nameM InterfaceM m f
i) (Doc f -> MethodDocs
forall f. IsDocType f => Doc f -> MethodDocs
flatDoc Doc f
doc) (InterfaceM m f -> HaskellType f -> ServerType m f
forall (m :: * -> *) f.
IsReturnType m f =>
InterfaceM m f -> HaskellType f -> ServerType m f
implement InterfaceM m f
i HaskellType f
f)
method
:: ( MonadThrow m
, Server.MethodType m (ServerType m f)
, IsDocType f
, IsReturnType m f)
=> Interface f -> HaskellType f -> Method m
method :: Interface f -> HaskellType f -> Method m
method Interface f
i = InterfaceM m f -> Doc f -> HaskellType f -> Method m
forall (m :: * -> *) f.
(MethodType m (ServerType m f), IsDocType f, IsReturnType m f,
MonadThrow m) =>
InterfaceM m f -> Doc f -> HaskellType f -> Method m
methodM (Interface f -> InterfaceM m f
forall f (m :: * -> *). Interface f -> InterfaceM m f
concrete Interface f
i) (Interface f -> Doc f
forall f. Interface f -> Doc f
docs Interface f
i)