diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 66e1815..9be0fb4 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -7,7 +7,7 @@ module Affection.MessageBus.Class ( Participant(..) , genUUID , UUID - , MsgId(..) + -- , MsgId(..) ) where import Affection.MessageBus.Message @@ -20,30 +20,31 @@ import Data.UUID.V4 import Affection.Logging -class (Message msg, Show msg) => Participant prt msg us where +class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where + type Mesg prt us :: * -- | Function to get the list of subscribers from the participant partSubscribers :: prt -- ^ the 'Participant''s subscriber storage - -> Affection us [msg -> Affection us ()] + -> Affection us [Mesg prt us -> Affection us ()] -- ^ List of Subscriber functions -- | Subscribe to the 'Participant''s events partSubscribe :: prt -- ^ The 'Participant''s subscriber storage - -> (msg -> Affection us ()) + -> (Mesg prt us -> Affection us ()) -- ^ What to do in case of a 'Message' -- (Subscriber function) - -> Affection us (MsgId msg) + -> Affection us UUID -- ^ 'UUID' of the registered subscriber Function -- | Unsubscribe a Subscriber function from Participant partUnSubscribe :: prt -- ^ The 'Participant''s subscriber storage to unsubscribe from - -> (MsgId msg) + -> UUID -- ^ The subscriber function's 'UUID' -> Affection us () @@ -51,7 +52,7 @@ class (Message msg, Show msg) => Participant prt msg us where partEmit :: prt -- ^ The 'Participant''s subscriber storage - -> msg + -> Mesg prt us -- ^ The 'Message' to emit -> Affection us () partEmit p m = do @@ -63,4 +64,4 @@ class (Message msg, Show msg) => Participant prt msg us where genUUID :: Affection us UUID genUUID = liftIO nextRandom -data MsgId msg = (Message msg, Show msg) => MsgId UUID msg +-- 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 ae4b277..c2af0f1 100644 --- a/src/Affection/MessageBus/Message/KeyboardMessage.hs +++ b/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -12,7 +12,6 @@ data KeyboardMessage , msgKbdKeyRepeat :: Bool , msgKbdKeysym :: SDL.Keysym } - | MsgKeyboardEmptyEvent deriving (Show) instance Message KeyboardMessage where diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs index ba56ae2..5833ae1 100644 --- a/src/Affection/MessageBus/Message/MouseMessage.hs +++ b/src/Affection/MessageBus/Message/MouseMessage.hs @@ -33,7 +33,6 @@ data MouseMessage , msgMWPos :: V2 Int32 , msgMWDIrection :: SDL.MouseScrollDirection } - | MsgMouseEmptyEvent deriving (Show) instance Message MouseMessage where diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs index 410ac39..d857ed2 100644 --- a/src/Affection/MessageBus/Message/WindowMessage.hs +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -68,7 +68,6 @@ data WindowMessage { msgWCWhen :: Double , msgWCWindow :: SDL.Window } - | MsgWindowEmptyEvent deriving (Show) instance Message WindowMessage where diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index 3df62fd..d73ec1e 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -1,5 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Affection.Subsystems.AffectionKeyboard where import Affection.Types @@ -13,7 +15,7 @@ import Control.Monad.IO.Class (liftIO) import qualified SDL consumeSDLKeyboardEvents - :: (Participant ak KeyboardMessage us) + :: forall ak us. (Participant ak us, Mesg ak us ~ KeyboardMessage) => ak -> [SDL.EventPayload] -> Affection us [SDL.EventPayload] diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs index dcbcf3a..7ff73c8 100644 --- a/src/Affection/Subsystems/AffectionMouse.hs +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -1,5 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Affection.Subsystems.AffectionMouse where import Affection.MessageBus @@ -15,12 +17,15 @@ import Linear.Affine (unP) import qualified SDL consumeSDLMouseEvents - :: (Participant am MouseMessage us) + :: forall am us. (Participant am us, Mesg am us ~ MouseMessage) => am -> [SDL.EventPayload] -> Affection us [SDL.EventPayload] consumeSDLMouseEvents am = doConsume where + doConsume + :: [SDL.EventPayload] + -> Affection us [SDL.EventPayload] doConsume [] = return [] doConsume (e:es) = do ts <- getElapsedTime diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 6aadf0d..6e28ff6 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -1,6 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Affection.Subsystems.AffectionWindow where import Affection.Types @@ -14,12 +17,16 @@ import Control.Monad.IO.Class (liftIO) import qualified SDL consumeSDLWindowEvents - :: (Participant aw WindowMessage us) + :: forall aw us. (Participant aw us, Mesg aw us ~ WindowMessage) => aw -> [SDL.EventPayload] -> Affection us [SDL.EventPayload] consumeSDLWindowEvents aw = doConsume where + doConsume + :: (Mesg aw us ~ WindowMessage) + => [SDL.EventPayload] + -> Affection us [SDL.EventPayload] doConsume [] = return [] doConsume (e:es) = do ts <- getElapsedTime