From 39d7e0c0355e5902f5d85a88ffee1323d5b55d65 Mon Sep 17 00:00:00 2001
From: Dmitry Zuikov <dzuikov@gmail.com>
Date: Tue, 17 Jan 2023 05:38:05 +0300
Subject: [PATCH] still working

---
 hbs2-core/lib/HBS2/Net/Proto/Types.hs |  8 +++
 hbs2-core/test/TestUniqProtoId.hs     | 72 ++++++++-------------------
 2 files changed, 30 insertions(+), 50 deletions(-)

diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs
index 02d113c5..e8a65a7f 100644
--- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs
+++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs
@@ -13,6 +13,14 @@ import Data.Hashable
 class (Hashable (Peer e), Eq (Peer e)) => HasPeer e where
   data family (Peer e) :: Type
 
+
+class Response e p (m :: Type -> Type) | p -> e where
+  response :: p -> m ()
+
+class Request e p (m :: Type -> Type) | p -> e where
+  request :: Peer e -> p -> m ()
+
+
 class (KnownNat (ProtocolId p), HasPeer e) => HasProtocol e p | p -> e  where
   type family ProtocolId p = (id :: Nat) | id -> p
   type family Encoded e :: Type
diff --git a/hbs2-core/test/TestUniqProtoId.hs b/hbs2-core/test/TestUniqProtoId.hs
index 20b85e6e..e0a198cb 100644
--- a/hbs2-core/test/TestUniqProtoId.hs
+++ b/hbs2-core/test/TestUniqProtoId.hs
@@ -1,34 +1,19 @@
 {-# Language TypeFamilyDependencies  #-}
-{-# Language FunctionalDependencies #-}
-{-# Language AllowAmbiguousTypes  #-}
+{-# Language UndecidableInstances #-}
 module TestUniqProtoId where
 
-import HBS2.Clock
-
 import HasProtocol
 import FakeMessaging
 
-import Data.Kind
 import GHC.TypeLits
 import Data.Proxy
 import Data.Map qualified as Map
-import Data.Map (Map)
 import Control.Monad.Reader
-import Data.ByteString (ByteString)
 
 import Control.Concurrent.Async
-import Control.Concurrent.STM
-import Control.Concurrent.STM.TChan as Chan
-import Data.Cache (Cache)
-import Data.Cache qualified as Cache
 import Data.Foldable
-import Data.Hashable
-import Data.List qualified as List
-import Data.Maybe
 import Safe
 
-import Control.Logger.Simple qualified as Log
-
 import Prettyprinter hiding (pipe)
 
 
@@ -41,11 +26,6 @@ data EngineEnv e = forall bus . (Messaging bus e (AnyMessage e))  =>
   , bus    :: bus
   }
 
--- makeLenses 'EngineEnv
-
-
-
-
 data AnyProtocol e m = forall p  . ( HasProtocol e p
                                    , KnownNat (ProtocolId p)
                                    , Response e p m
@@ -57,13 +37,6 @@ data AnyProtocol e m = forall p  . ( HasProtocol e p
   , handle      :: p -> m ()
   }
 
-
-class Response e p (m :: Type -> Type) where
-  response :: p -> m ()
-
-class Request e p (m :: Type -> Type) where
-  request :: Peer e -> p -> m ()
-
 makeResponse :: forall e p  m . ( MonadIO m
                                 , Response e p m
                                 , HasProtocol e p
@@ -136,47 +109,46 @@ runPeer env@(EngineEnv {self = me, bus = pipe}) hh = do
             Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) h (decoder msg)
             Nothing -> pure ()
 
-data PingPong  = Ping Int
-               | Pong Int
-               deriving stock (Show,Read)
+data PingPong e = Ping Int
+                | Pong Int
+                deriving stock (Show,Read)
 
-data PeekPoke  = Peek Int
-               | Poke Int
-               | Nop
-               deriving stock (Show,Read)
+data PeekPoke e = Peek Int
+                | Poke Int
+                | Nop
+                deriving stock (Show,Read)
 
 
-instance HasProtocol Fake PingPong where
-  type instance ProtocolId PingPong = 1
+instance HasProtocol Fake (PingPong Fake) where
+  type instance ProtocolId (PingPong Fake) = 1
   type instance Encoded Fake = String
   decode = readMay
   encode = show
 
-instance HasProtocol Fake PeekPoke where
-  type instance ProtocolId PeekPoke = 2
+instance HasProtocol Fake (PeekPoke Fake) where
+  type instance ProtocolId (PeekPoke Fake)  = 2
   type instance Encoded Fake = String
   decode = readMay
   encode = show
 
 
-pingPongHandler :: forall a m  . (MonadIO m, Response a PingPong  m, HasProtocol a PingPong) => PingPong -> m ()
-pingPongHandler =
+pingPongHandler :: forall e m  . (MonadIO m, Response e (PingPong e) m, HasProtocol e (PingPong e)) => PingPong e -> m ()
+pingPongHandler  =
   \case
-    Ping c -> liftIO (print $ "effect: PING" <+> pretty c) >> response @a (Pong c)
-    Pong c -> liftIO (print $ "effect: PONG" <+> pretty c) >> response @a (Ping (succ c))
+    Ping c -> liftIO (print $ "effect: PING" <+> pretty c) >> response (Pong @e c)
+    Pong c -> liftIO (print $ "effect: PONG" <+> pretty c) >> response (Ping @e (succ c))
 
-peekPokeHandler :: forall a m  . (MonadIO m, Response a PeekPoke m, HasProtocol a PeekPoke) => PeekPoke -> m ()
+peekPokeHandler :: forall e m  . (MonadIO m, Response e (PeekPoke e) m, HasProtocol e (PeekPoke e)) => PeekPoke e -> m ()
 peekPokeHandler =
   \case
-    Peek c -> liftIO (print $ "effect: Peek" <+> pretty c) >> response @a (Poke c)
-    Poke c -> liftIO (print $ "effect: Poke" <+> pretty c) >> response @a Nop
-    Nop    -> liftIO (print $ pretty "effect: Nop") >> response @a (Peek 1)
+    Peek c -> liftIO (print $ "effect: Peek" <+> pretty c) >> response (Poke @e c)
+    Poke c -> liftIO (print $ "effect: Poke" <+> pretty c) >> response (Nop @e)
+    Nop    -> liftIO (print $ pretty "effect: Nop") >> response (Peek @e 1)
 
 
 testUniqiProtoId :: IO ()
 testUniqiProtoId = do
 
-  -- setLogLevel
 
   fake <- newFakeP2P True
 
@@ -187,10 +159,10 @@ testUniqiProtoId = do
   env1 <- newEnv peer1 fake
 
   runEngineM env0 $ do
-    request peer1 (Ping 0)
+    request peer1 (Ping @Fake 0)
 
   runEngineM env1 $ do
-    request peer0 (Peek 0)
+    request peer0 (Peek @Fake 0)
 
   pip1 <- async $
     runPeer env0