pb1.hs

{-# LANGUAGE KindSignatures, DataKinds, TypeFamilies, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, UndecidableInstances, BangPatterns, GeneralizedNewtypeDeriving, ExistentialQuantification, RankNTypes #-}

import GHC.TypeLits
import Data.Proxy
import Control.Monad.Reader
import Control.Monad.IO.Class

-- Dummy class for protocol-buffers wire class
class Wire a where

-- Dummy
instance Wire String where

-- Dummy
instance Wire Int where

-- | Copied from protocol-buffers patch
data Method (name :: Symbol) req resp = Method

-- | Wrapper for methods
data MethodHandler m = forall req resp . (Wire req, Wire resp) => MethodHandler String (req -> m resp)

-- | Hoist the handlers monad
hoist :: Monad m => (forall a. m a -> n a) -> MethodHandler m -> MethodHandler n
hoist h (MethodHandler method f) = MethodHandler method (h . f)

mkHandler :: forall m name req resp . (KnownSymbol name, Wire req, Wire resp) => Method name req resp -> (req -> m resp) -> MethodHandler m
mkHandler _ = MethodHandler sym
  where sym = symbolVal (Proxy :: Proxy name)

-- An example method
type Search = Method "search" String Int

-- Proxy
search :: Search
search = Method

-- Some imaginary connection to some pb-service
data Connection = Connection

-- A possible type class for some connection getter
class HasConnection m where
  getConnection :: m Connection


-- Test for method handler
test :: String -> IO Int
test s = putStrLn s >> return 42

x :: MethodHandler IO
x = mkHandler search test

-- example invoke
invoke :: forall m name req resp. (KnownSymbol name, MonadIO m, HasConnection m, Wire req, Wire resp) => Method name req resp -> req -> m resp
invoke _ req = invokeRaw name req
  where name = symbolVal (Proxy :: Proxy name)

invokeRaw :: (HasConnection m, MonadIO m, Wire req, Wire resp) => String -> req -> m resp
invokeRaw method _ = do
  liftIO (putStrLn method)
  return undefined

instance MonadReader Connection m => HasConnection m where
  getConnection = ask


main :: IO ()
main = do
  _ <- runReaderT (do invoke search "hello world") Connection
  return ()