mirror of https://github.com/voidlizard/hbs2
111 lines
2.8 KiB
Haskell
111 lines
2.8 KiB
Haskell
{-# Language TypeFamilyDependencies #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module TestUniqProtoId where
|
|
|
|
import HasProtocol
|
|
|
|
import Data.Kind
|
|
import GHC.TypeLits
|
|
import Data.Proxy
|
|
import Data.Map qualified as Map
|
|
import Data.Map (Map)
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Identity
|
|
|
|
data ProtocolA = ProtocolA
|
|
|
|
data ProtocolB = ProtocolB
|
|
|
|
instance HasProtocol ProtocolA where
|
|
type instance ProtocolId ProtocolA = 1
|
|
type instance Encoded ProtocolA = String
|
|
decode = undefined
|
|
encode = undefined
|
|
|
|
|
|
instance HasProtocol ProtocolB where
|
|
type instance ProtocolId ProtocolB = 2
|
|
type instance Encoded ProtocolB = String
|
|
decode = undefined
|
|
encode = undefined
|
|
|
|
-- class Response p (m :: Type -> Type) where
|
|
-- answer :: p -> m ()
|
|
|
|
data AnyProtocol m = forall a . ( HasProtocol a
|
|
, KnownNat (ProtocolId a)
|
|
, Response a m
|
|
) =>
|
|
AnyProtocol
|
|
{ getProtoId :: Integer
|
|
, protoDecode :: String -> Maybe a
|
|
, protoEncode :: a -> String
|
|
, handle :: a -> m ()
|
|
}
|
|
|
|
|
|
data PingPong = Ping Int
|
|
| Pong Int
|
|
|
|
|
|
instance HasProtocol PingPong where
|
|
type instance ProtocolId PingPong = 3
|
|
type instance Encoded PingPong = PingPong
|
|
decode = undefined
|
|
encode = undefined
|
|
|
|
|
|
class Response p (m :: Type -> Type) where
|
|
answer :: p -> m ()
|
|
|
|
anyProtocol :: forall p m . ( MonadIO m
|
|
, Response p m
|
|
, HasProtocol p
|
|
, KnownNat (ProtocolId p)
|
|
)
|
|
=> (p -> m ()) -> AnyProtocol m
|
|
|
|
anyProtocol h = AnyProtocol { getProtoId = natVal (Proxy @(ProtocolId p))
|
|
, protoDecode = decode @p
|
|
, protoEncode = encode @p
|
|
, handle = h
|
|
}
|
|
|
|
|
|
newtype EngineM m a = EngineM { fromEngine :: ReaderT () m a }
|
|
deriving ( Functor, Applicative, Monad, MonadTrans, MonadIO )
|
|
|
|
runEngineM :: EngineM m a -> m a
|
|
runEngineM f = runReaderT (fromEngine f) ()
|
|
|
|
instance (Monad m, HasProtocol p) => Response p m where
|
|
answer = undefined
|
|
|
|
|
|
testUniqiProtoId :: IO ()
|
|
testUniqiProtoId = do
|
|
|
|
let decoders = mempty :: Map Integer (AnyProtocol (EngineM IO))
|
|
|
|
-- TODO: GET MESSAGE
|
|
-- TODO: GET RECIPIENT
|
|
-- TODO: GET PROTO-ID FROM MESSAGE
|
|
|
|
let pingpong = anyProtocol @PingPong @(EngineM IO)
|
|
\case
|
|
Ping c -> lift (print "effect: PING") >> answer (Pong c)
|
|
Pong _ -> lift (print "effect: PONG")
|
|
|
|
|
|
-- FIXME: dispatcher!
|
|
case Map.lookup 3 decoders of
|
|
Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) (runEngineM . h) (decoder "AAA")
|
|
Nothing -> pure ()
|
|
|
|
-- let qq = natVal (Proxy @(ProtocolId ProtocolA))
|
|
|
|
pure ()
|
|
|
|
|
|
|