rebuilding participant system

src/Affection/MessageBus/Class.hs

@@ -1,10 +1,13 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ExistentialQuantification #-}
 module Affection.MessageBus.Class 
   ( Participant(..)
   , genUUID
   , UUID
+  , MsgId(..)
   ) where
 
 import Affection.MessageBus.Message
@@ -17,30 +20,30 @@ import Data.UUID.V4
 
 import Affection.Logging
 
-class (Show m, Message m) => Participant prt m us where
+class (Message msg, Show msg) => Participant prt msg us where
 
   -- | Function to get the list of subscribers from the participant
   partSubscribers
     :: prt
     -- ^ the 'Participant''s subscriber storage
-    -> Affection us [m -> Affection us ()]
+    -> Affection us [msg -> Affection us ()]
     -- ^ List of Subscriber functions
 
   -- | Subscribe to the 'Participant''s events
   partSubscribe
     :: prt
     -- ^ The 'Participant''s subscriber storage
-    -> (m -> Affection us ())
+    -> (msg -> Affection us ())
     -- ^ What to do in case of a 'Message'
     -- (Subscriber function)
-    -> Affection us UUID
+    -> Affection us (MsgId msg)
     -- ^ 'UUID' of the registered subscriber Function
 
   -- | Unsubscribe a Subscriber function from Participant
   partUnSubscribe
     :: prt
     -- ^ The 'Participant''s subscriber storage to unsubscribe from
-    -> UUID
+    -> (MsgId msg)
     -- ^ The subscriber function's 'UUID'
     -> Affection us ()
 
@@ -48,7 +51,7 @@ class (Show m, Message m) => Participant prt m us where
   partEmit
     :: prt
     -- ^ The 'Participant''s subscriber storage
-    -> m
+    -> msg
     -- ^ The 'Message' to emit
     -> Affection us ()
   partEmit p m = do
@@ -59,3 +62,5 @@ class (Show m, Message m) => Participant prt m us where
 -- | Helper function to generate new 'UUID's
 genUUID :: Affection us UUID
 genUUID = liftIO nextRandom
+
+data MsgId msg = (Message msg, Show msg) => MsgId UUID msg

src/Affection/MessageBus/Message/KeyboardMessage.hs

@@ -4,13 +4,16 @@ import Affection.MessageBus.Message.Class
 
 import qualified SDL
 
-data KeyboardMessage = MsgKeyboardEvent
-  { msgKbdWhen :: Double
-  , msgKbdWindow :: Maybe SDL.Window
-  , msgKbdKeyMotion :: SDL.InputMotion
-  , msgKbdKeyRepeat :: Bool
-  , msgKbdKeysym :: SDL.Keysym
-  } deriving (Show)
+data KeyboardMessage
+  = MsgKeyboardEvent
+    { msgKbdWhen :: Double
+    , msgKbdWindow :: Maybe SDL.Window
+    , msgKbdKeyMotion :: SDL.InputMotion
+    , msgKbdKeyRepeat :: Bool
+    , msgKbdKeysym :: SDL.Keysym
+    }
+  | MsgKeyboardEmptyEvent
+  deriving (Show)
 
 instance Message KeyboardMessage where
   msgTime (MsgKeyboardEvent t _ _ _ _) = t

src/Affection/MessageBus/Message/MouseMessage.hs

@@ -33,6 +33,7 @@ data MouseMessage
     , msgMWPos :: V2 Int32
     , msgMWDIrection :: SDL.MouseScrollDirection
     }
+  | MsgMouseEmptyMessage
   deriving (Show)
 
 instance Message MouseMessage where

src/Affection/MessageBus/Message/WindowMessage.hs

@@ -68,6 +68,7 @@ data WindowMessage
     { msgWCWhen :: Double
     , msgWCWindow :: SDL.Window
     }
+  | MsgWindowEmptyEvent
   deriving (Show)
 
 instance Message WindowMessage where