{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE Safe                  #-}
{-# 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           Control.Monad.Trans              (MonadIO)
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 :: * -> *) 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


--------------------------------------------------------------------------------
--
-- :: Documentation
--
--------------------------------------------------------------------------------


class IsDocType f where
  data Doc f
  flatDoc :: Doc f -> MethodDocs

data Returns r

instance Typeable r => 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 :: * -> *) r

instance Typeable r => 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


--------------------------------------------------------------------------------
--
-- :: Client
--
--------------------------------------------------------------------------------


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 :: 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


--------------------------------------------------------------------------------
--
-- :: Server
--
--------------------------------------------------------------------------------


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 :: 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)