Reduce code duplication for serving IO methods.

The downside is that the IO-ness of the server method is now part of the
interface, but callers don't really care because they are already in a
MonadIO.

network-msgpack-rpc.cabal

@@ -39,8 +39,6 @@ library
       Network.MessagePack.Capabilities
       Network.MessagePack.Client.Basic
       Network.MessagePack.Client.Internal
-      Network.MessagePack.Interface.Internal
-      Network.MessagePack.Internal.TypeUtil
       Network.MessagePack.Protocol
       Network.MessagePack.Server.Basic
       Network.MessagePack.Types.Client

src/Network/MessagePack/Client/Internal.hs

@@ -6,28 +6,27 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Network.MessagePack.Client.Internal where
 
-import           Control.Applicative                    (Applicative)
-import           Control.Monad                          (when)
-import           Control.Monad.Catch                    (MonadCatch, MonadThrow,
-                                                         throwM)
-import qualified Control.Monad.State.Strict             as CMS
-import qualified Data.Binary                            as Binary
-import qualified Data.ByteString                        as S
-import           Data.Conduit                           (ConduitT,
-                                                         SealedConduitT, Void,
-                                                         runConduit, ($$++),
-                                                         (.|))
-import qualified Data.Conduit.Binary                    as CB
-import           Data.Conduit.Serialization.Binary      (sinkGet)
-import           Data.MessagePack                       (MessagePack (fromObject),
-                                                         Object)
-import qualified Data.MessagePack.Types.Result          as R
-import           Data.Monoid                            ((<>))
-import           Data.Text                              (Text)
-import qualified Data.Text                              as T
-
-import           Network.MessagePack.Interface.Internal (IsClientType (..),
-                                                         Returns)
+import           Control.Applicative               (Applicative)
+import           Control.Monad                     (when)
+import           Control.Monad.Catch               (MonadCatch, MonadThrow,
+                                                    throwM)
+import qualified Control.Monad.State.Strict        as CMS
+import qualified Data.Binary                       as Binary
+import qualified Data.ByteString                   as S
+import           Data.Conduit                      (ConduitT, SealedConduitT,
+                                                    Void, runConduit, ($$++),
+                                                    (.|))
+import qualified Data.Conduit.Binary               as CB
+import           Data.Conduit.Serialization.Binary (sinkGet)
+import           Data.MessagePack                  (MessagePack (fromObject),
+                                                    Object)
+import qualified Data.MessagePack.Types.Result     as R
+import           Data.Monoid                       ((<>))
+import           Data.Text                         (Text)
+import qualified Data.Text                         as T
+
+import           Network.MessagePack.Interface     (IsClientType (..), Returns,
+                                                    ReturnsM)
 import           Network.MessagePack.Types.Client
 import           Network.MessagePack.Types.Error
 import           Network.MessagePack.Types.Spec
@@ -51,6 +50,9 @@ type Client a = ClientT IO a
 instance IsClientType m (Returns r) where
   type ClientType m (Returns r) = ClientT m r
 
+instance IsClientType m (ReturnsM io r) where
+  type ClientType m (ReturnsM io r) = ClientT m r
+
 
 instance (CMS.MonadIO m, MonadThrow m, MessagePack o)
     => RpcType (ClientT m o) where

src/Network/MessagePack/Interface.hs

@@ -1,12 +1,148 @@
-module Network.MessagePack.Interface
-  ( Returns
-  , Interface
-  , interface
-  , call
-  , concrete
-  , method
-  , methodIO
-  , Doc (Arg, Ret)
-  ) where
-
-import           Network.MessagePack.Interface.Internal
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE InstanceSigs          #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE Safe                  #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TypeFamilies          #-}
+module Network.MessagePack.Interface 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
+  { name :: !Text
+  , docs :: !(Doc f)
+  }
+
+
+newtype InterfaceM (m :: * -> *) f = InterfaceM
+  { nameM :: Text
+  }
+
+
+interface :: Text -> Doc f -> Interface f
+interface = Interface
+
+
+concrete :: Interface f -> InterfaceM m f
+concrete = InterfaceM . 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 (Eq, Read, Show)
+  flatDoc (Ret retName) =
+    MethodDocs [] (MethodVal retName (typeName (undefined :: r)))
+
+data ReturnsM (m :: * -> *) r
+
+instance Typeable r => IsDocType (ReturnsM m r) where
+  data Doc (ReturnsM m r) = RetM Text
+    deriving (Eq, Read, Show)
+  flatDoc (RetM retName) =
+    MethodDocs [] (MethodVal retName (typeName (undefined :: r)))
+
+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 ty = typeName (undefined :: o) in
+    doc { methodArgs = MethodVal o ty : 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))
+
+
+typeName :: Typeable a => a -> Text
+typeName = Text.replace "[Char]" "String" . Text.pack . show . 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 = Client.call . 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 i f a = next (coerce i) (f a)
+    where
+      next :: InterfaceM m r -> HaskellType r -> ServerType m r
+      next = implement
+
+      coerce :: InterfaceM m a -> InterfaceM m b
+      coerce = InterfaceM . 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 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)