still compiles

hbs2-core/test/HasProtocol.hs

@@ -1,18 +1,20 @@
 {-# Language TypeFamilyDependencies  #-}
+{-# Language FunctionalDependencies  #-}
 module HasProtocol where
 
 import Data.Kind
 import Data.Proxy
 import GHC.TypeLits
 
-class HasProtocol a where
+class HasProtocol p a  | a -> p where
-  type family ProtocolId  a = (id :: Nat) | id -> a
+  type family ProtocolId a = (id :: Nat) | id -> a
-  type family Encoded a :: Type
+  type family Encoded p :: Type
-  type family Peer a :: Type
+  type family (Peer p) :: Type
 
   protoId :: forall . KnownNat (ProtocolId a) => Proxy a -> Integer
   protoId _ = natVal (Proxy @(ProtocolId a))
 
-  decode :: Encoded a -> Maybe a
+  decode :: Encoded p -> Maybe a
-  encode :: a -> Encoded a
+  encode :: a -> Encoded p
+
 

hbs2-core/test/TestUniqProtoId.hs

@@ -12,42 +12,46 @@ import Data.Map (Map)
 import Control.Monad.Reader
 
 
-data AnyProtocol m = forall a . ( HasProtocol a
+data AnyProtocol e m = forall p a . ( HasProtocol p a
-                                , KnownNat (ProtocolId a)
+                                    , KnownNat (ProtocolId a)
-                                , Response a m
+                                    , Response p a m
-                                ) =>
+                                    , e ~ Encoded p
+                                    ) =>
   AnyProtocol
   { getProtoId  :: Integer
-  , protoDecode :: Encoded a -> Maybe a
+  , protoDecode :: Encoded p -> Maybe a
-  , protoEncode :: a -> Encoded a
+  , protoEncode :: a -> Encoded p
   , handle      :: a -> m ()
   }
 
 
-data PingPong = Ping Int
+data PingPong  = Ping Int
-              | Pong Int
+               | Pong Int
 
+type family Encoding a :: Type
 
-instance HasProtocol PingPong where
+data Fake
+
+instance HasProtocol Fake PingPong where
   type instance ProtocolId PingPong = 1
-  type instance Encoded PingPong = PingPong
+  type instance Encoded Fake = String
-  type instance Peer PingPong = Int
+  type instance Peer Fake = Int
-  decode = Just
+  decode = undefined
-  encode = id
+  encode = undefined
 
-class Response p (m :: Type -> Type) where
+class Response e p (m :: Type -> Type) where
   response :: p -> m ()
 
-makeProtocol :: forall p t m . ( MonadIO m
+makeProtocol :: forall a p t m . ( MonadIO m
-                               , Response p (t m)
+                                 , Response a p (t m)
-                               , HasProtocol p
+                                 , HasProtocol a p
-                               , KnownNat (ProtocolId p)
+                                 , KnownNat (ProtocolId p)
-                               )
+                                 )
-            => (p -> t m ()) -> AnyProtocol (t m)
+            => (p -> t m ()) -> AnyProtocol (Encoded a) (t m)
 
 makeProtocol h = AnyProtocol { getProtoId  = natVal (Proxy @(ProtocolId p))
-                             , protoDecode = decode @p
+                             , protoDecode = decode @a
-                             , protoEncode = encode @p
+                             , protoEncode = encode @a
                              , handle = h
                              }
 
@@ -57,7 +61,7 @@ newtype EngineM m a = EngineM { fromEngine :: ReaderT () m a }
 runEngineM :: EngineM m a -> m a
 runEngineM f = runReaderT (fromEngine f) ()
 
-instance (Monad m, HasProtocol p) => Response p (EngineM m) where
+instance (Monad m, HasProtocol e p) => Response e p (EngineM m) where
   response _ = do
     -- TODO: get bus
     -- TODO: encode
@@ -67,20 +71,24 @@ instance (Monad m, HasProtocol p) => Response p (EngineM m) where
 testUniqiProtoId :: IO ()
 testUniqiProtoId = do
 
-  let decoders = mempty :: Map Integer (AnyProtocol (EngineM IO))
+  let pingpong = makeProtocol @Fake @PingPong @EngineM
+        \case
+          Ping c -> lift (print "effect: PING") >> response (Pong c)
+          Pong _ -> lift (print "effect: PONG")
+
+
+  let decoders = mempty :: Map Integer (AnyProtocol String (EngineM IO))
+  let dec = Map.insert 1 pingpong decoders
 
   -- TODO: GET MESSAGE
   -- TODO: GET RECIPIENT
   -- TODO: GET PROTO-ID FROM MESSAGE
 
-  let pingpong = makeProtocol @PingPong @EngineM
+  let message = ""
-        \case
-          Ping c -> lift (print "effect: PING") >> response (Pong c)
-          Pong _ -> lift (print "effect: PONG")
 
   -- FIXME: dispatcher!
-  case Map.lookup 3 decoders of
+  case Map.lookup 1 dec of
-    Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) (runEngineM . h) (decoder undefined)
+    Just (AnyProtocol {protoDecode = decoder, handle = h}) -> maybe (pure ()) (runEngineM . h) (decoder message)
     Nothing -> pure ()
 
   pure ()