still compiles

hbs2-core/lib/HBS2/Net/Messaging/Fake.hs

@@ -1,7 +1,7 @@
 module HBS2.Net.Messaging.Fake
   ( FakeP2P
   , newFakeP2P
-  , Messaging(..)
+  -- , Messaging(..)
   ) where
 
 import Control.Concurrent.STM (atomically) -- as STM
@@ -17,11 +17,11 @@ import Data.Hashable
 import HBS2.Net.Proto
 import HBS2.Net.Messaging
 
-data FakeP2P peer msg =
+data FakeP2P proto msg =
   FakeP2P
   {
     blocking :: Bool
-  , fakeP2p  :: Cache (Peer peer) (TChan (From peer,msg))
+  , fakeP2p  :: Cache (Peer proto) (TChan (From proto,msg))
   }
 
 newFakeP2P :: Bool -> IO (FakeP2P peer msg)

hbs2-core/test/HasProtocol.hs

@@ -7,7 +7,7 @@ import Data.Proxy
 import GHC.TypeLits
 
 class HasPeer p where
-  type family (Peer p) :: Type
+  data family (Peer p) :: Type
 
 class HasPeer p => HasProtocol p a  | a -> p where
   type family ProtocolId a = (id :: Nat) | id -> a

hbs2-core/test/TestUniqProtoId.hs

@@ -1,4 +1,5 @@
 {-# Language TypeFamilyDependencies  #-}
+{-# Language FunctionalDependencies #-}
 {-# Language AllowAmbiguousTypes  #-}
 module TestUniqProtoId where
 
@@ -10,6 +11,52 @@ import Data.Proxy
 import Data.Map qualified as Map
 import Data.Map (Map)
 import Control.Monad.Reader
+import Data.ByteString (ByteString)
+
+import Data.List qualified as List
+import Data.Cache qualified as Cache
+import Data.Cache (Cache)
+import Control.Concurrent.STM.TChan as Chan
+import Control.Concurrent.STM
+import Data.Hashable
+import Data.Maybe
+
+
+newtype From a = From (Peer a)
+
+newtype To a = To (Peer a)
+
+class HasPeer proto => Messaging bus proto msg  | bus -> proto, bus -> msg where
+
+  sendTo  :: MonadIO m => bus -> To proto -> From proto -> msg -> m ()
+  receive :: MonadIO m => bus -> To proto -> m [(From proto, msg)]
+
+
+data FakeP2P proto msg =
+  FakeP2P
+  {
+    blocking :: Bool
+  , fakeP2p  :: Cache (Peer proto) (TChan (From proto,msg))
+  }
+
+newFakeP2P :: Bool -> IO (FakeP2P peer msg)
+newFakeP2P block = FakeP2P block <$> Cache.newCache Nothing
+
+instance ( (HasPeer proto, Hashable (Peer proto))
+         ) => Messaging (FakeP2P proto msg) proto msg where
+
+  sendTo bus (To whom) who msg = liftIO do
+    chan <- Cache.fetchWithCache (fakeP2p bus) whom $ const newTChanIO
+    atomically $ Chan.writeTChan chan (who, msg)
+
+  receive bus (To me) = liftIO do
+    readChan =<< Cache.fetchWithCache (fakeP2p bus) me (const newTChanIO)
+
+    where
+      readChan | blocking bus = atomically . (List.singleton <$>) . Chan.readTChan
+               | otherwise    = atomically . (maybeToList <$>) . Chan.tryReadTChan
+
+
 
 data AnyProtocol e m = forall p a . ( HasProtocol p a
                                     , KnownNat (ProtocolId a)
@@ -31,8 +78,11 @@ type family Encoding a :: Type
 
 data Fake
 
+
 instance HasPeer Fake where
-  type instance Peer Fake = Int
+  newtype instance Peer Fake = FakePeer Int
+                               deriving newtype (Hashable)
+                               deriving stock (Eq)
 
 instance HasProtocol Fake PingPong where
   type instance ProtocolId PingPong = 1
@@ -56,9 +106,12 @@ makeResponse h = AnyProtocol { getProtoId  = natVal (Proxy @(ProtocolId p))
                              , handle = h
                              }
 
-data EngineEnv = forall p . HasPeer p =>
+data AnyMessage = AnyMessage Integer ByteString
+
+data EngineEnv = forall p bus . (HasPeer p, Messaging bus p AnyMessage)  =>
   EngineEnv
-  { peer :: Maybe (Peer p)
+  { peer   :: Maybe (Peer p)
+  , bus    :: bus
   }
 
 newtype EngineM m a = EngineM { fromEngine :: ReaderT EngineEnv m a }
@@ -68,7 +121,7 @@ runEngineM :: EngineEnv -> EngineM m a -> m a
 runEngineM e f = runReaderT (fromEngine f) e
 
 instance (Monad m, HasProtocol e p) => Response e p (EngineM m) where
-  response _ = do
+  response resp = do
     -- TODO: get bus
     -- TODO: encode
     -- TODO: sendTo
@@ -83,7 +136,9 @@ pingPongHandler =
 testUniqiProtoId :: IO ()
 testUniqiProtoId = do
 
-  let env = EngineEnv @Fake Nothing
+  fake <- newFakeP2P True
+
+  let env = EngineEnv @Fake Nothing fake
 
   let pingpong = makeResponse pingPongHandler