voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

still compiles

This commit is contained in:
Dmitry Zuikov 2023-01-16 12:53:39 +03:00
parent 86ee1ce581
commit 3322061b80
1 changed files with 18 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
hbs2-core/test/TestUniqProtoId.hs
View File

@ -11,7 +11,6 @@ import Data.Map qualified as Map
import Data.Map (Map) import Data.Map (Map)
import Control.Monad.Reader import Control.Monad.Reader
data AnyProtocol e m = forall p a . ( HasProtocol p a data AnyProtocol e m = forall p a . ( HasProtocol p a
, KnownNat (ProtocolId a) , KnownNat (ProtocolId a)
, Response p a m , Response p a m
@ -42,24 +41,29 @@ instance HasProtocol Fake PingPong where
class Response e p (m :: Type -> Type) where class Response e p (m :: Type -> Type) where
response :: p -> m () response :: p -> m ()
makeProtocol :: forall a p t m . ( MonadIO m makeResponse :: forall a p t m . ( MonadIO m
, Response a p (t m) , Response a p (t m)
, HasProtocol a p , HasProtocol a p
, KnownNat (ProtocolId p) , KnownNat (ProtocolId p)
) )
=> (p -> t m ()) -> AnyProtocol (Encoded a) (t m) => (p -> t m ()) -> AnyProtocol (Encoded a) (t m)
makeProtocol h = AnyProtocol { getProtoId = natVal (Proxy @(ProtocolId p)) makeResponse h = AnyProtocol { getProtoId = natVal (Proxy @(ProtocolId p))
, protoDecode = decode @a , protoDecode = decode @a
, protoEncode = encode @a , protoEncode = encode @a
, handle = h , handle = h
} }
newtype EngineM m a = EngineM { fromEngine :: ReaderT () m a } data EngineEnv =
EngineEnv
{
}
newtype EngineM m a = EngineM { fromEngine :: ReaderT EngineEnv m a }
deriving ( Functor, Applicative, Monad, MonadTrans, MonadIO ) deriving ( Functor, Applicative, Monad, MonadTrans, MonadIO )
runEngineM :: EngineM m a -> m a runEngineM :: EngineEnv -> EngineM m a -> m a
runEngineM f = runReaderT (fromEngine f) () runEngineM e f = runReaderT (fromEngine f) e
instance (Monad m, HasProtocol e p) => Response e p (EngineM m) where instance (Monad m, HasProtocol e p) => Response e p (EngineM m) where
response _ = do response _ = do
@ -71,12 +75,16 @@ instance (Monad m, HasProtocol e p) => Response e p (EngineM m) where
testUniqiProtoId :: IO () testUniqiProtoId :: IO ()
testUniqiProtoId = do testUniqiProtoId = do
let pingpong = makeProtocol @Fake @PingPong @EngineM let env = EngineEnv
-- let ssid = 0
-- runEngineM env $ request 2 (Ping ssid)
let pingpong = makeResponse
\case \case
Ping c -> lift (print "effect: PING") >> response (Pong c) Ping c -> lift (print "effect: PING") >> response (Pong c)
Pong _ -> lift (print "effect: PONG") Pong _ -> lift (print "effect: PONG")
let decoders = mempty :: Map Integer (AnyProtocol String (EngineM IO)) let decoders = mempty :: Map Integer (AnyProtocol String (EngineM IO))
let dec = Map.insert 1 pingpong decoders let dec = Map.insert 1 pingpong decoders
@ -84,11 +92,11 @@ testUniqiProtoId = do
-- TODO: GET RECIPIENT -- TODO: GET RECIPIENT
-- TODO: GET PROTO-ID FROM MESSAGE -- TODO: GET PROTO-ID FROM MESSAGE
let message = "" let message = "" :: Encoded Fake
-- FIXME: dispatcher! -- FIXME: dispatcher!
case Map.lookup 1 dec of case Map.lookup 1 dec of
Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) (runEngineM . h) (decoder message) Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) (runEngineM env . h) (decoder message)
Nothing -> pure () Nothing -> pure ()
pure () pure ()