diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index a715970..df2b958 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/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 diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs index 6b90b0f..ae4b277 100644 --- a/src/Affection/MessageBus/Message/KeyboardMessage.hs +++ b/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 diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs index 5833ae1..a28676a 100644 --- a/src/Affection/MessageBus/Message/MouseMessage.hs +++ b/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 diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs index d857ed2..410ac39 100644 --- a/src/Affection/MessageBus/Message/WindowMessage.hs +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -68,6 +68,7 @@ data WindowMessage { msgWCWhen :: Double , msgWCWindow :: SDL.Window } + | MsgWindowEmptyEvent deriving (Show) instance Message WindowMessage where