diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 3aa1fea..4ec6b7d 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} module Affection.MessageBus.Class ( Participant(..) , genUUID @@ -25,7 +26,7 @@ class (Show m, Message m) => Participant prt m where -- | Subscribe to the 'Participant''s events partSubscribe :: prt -- ^ The 'Participant' to subscribe to - -> (m -> IO ()) -- ^ What to do in case of a 'Message' + -> (forall sd. m -> Affection sd ()) -- ^ What to do in case of a 'Message' -- (Subscriber function) -> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs index a3c60d8..4ff12b6 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 } + deriving (Show) instance Message MouseMessage where msgTime (MsgMouseMotion t _ _ _ _ _) = t diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index 094b559..188099a 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} module Affection.Subsystems.AffectionKeyboard where import Affection.MessageBus @@ -10,11 +11,11 @@ import Control.Concurrent.STM as STM import qualified SDL -data AffectionKeyboard = AffectionKeyboard - { keyboardSubscribers :: TVar [(UUID, KeyboardMessage -> IO ())] +data AffectionKeyboard sd = AffectionKeyboard + { keyboardSubscribers :: forall sd. TVar [(UUID, KeyboardMessage -> Affection sd ())] } -instance Participant AffectionKeyboard KeyboardMessage where +instance Participant (AffectionKeyboard sd) KeyboardMessage where partSubscribe p funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :) @@ -28,7 +29,7 @@ instance Participant AffectionKeyboard KeyboardMessage where subTups <- liftIO $ readTVarIO $ keyboardSubscribers p return $ map snd subTups -instance SDLSubsystem AffectionKeyboard KeyboardMessage where +instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where consumeSDLEvents ak evs = doConsume evs where doConsume [] = return [] diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs index 8c9f144..ff47e06 100644 --- a/src/Affection/Subsystems/AffectionMouse.hs +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -1,47 +1,51 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} module Affection.Subsystems.AffectionMouse where import Affection.MessageBus -import Affection.Subsystem.Class +import Affection.Subsystems.Class import Affection.Types import Control.Monad.IO.Class (liftIO) import Control.Concurrent.STM +import Linear.Affine (unP) + import qualified SDL -data AffectionMouse = AffectionMouse - { mouseSubscribers :: TVar (UUID, MouseMessage -> IO ()) +data AffectionMouse sd = AffectionMouse + { mouseSubscribers :: forall sd. TVar [(UUID, MouseMessage -> Affection sd ())] } -instance Participant AffectionMouse MouseMessage where +instance Participant (AffectionMouse sd) MouseMessage where partSubscribe p funct = do uuid <- genUUID - liftIO $ atmoically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :) + liftIO $ atomically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :) return uuid partUnSubscribe p uuid = liftIO $ atomically $ modifyTVar' (mouseSubscribers p) (filter (\(u, _) -> u /= uuid)) - partSubscribers p = + partSubscribers p = do subTups <- liftIO $ readTVarIO $ mouseSubscribers p return $ map snd subTups -instance SDLSubsystem AffectionMouse where - consumeSDLEvents am evs = doComsume evs +instance SDLSubsystem (AffectionMouse sd) MouseMessage where + consumeSDLEvents am evs = doConsume evs where doConsume [] = return [] - doConsume (e:es) = case SDL.EventPayload e of + doConsume (e:es) = case SDL.eventPayload e of SDL.MouseMotionEvent dat -> do partEmit am (MsgMouseMotion - (SDL.eventTimestamp dat) + (SDL.eventTimestamp e) (SDL.mouseMotionEventWindow dat) (SDL.mouseMotionEventWhich dat) (SDL.mouseMotionEventState dat) - (SDL.mouseMotionEventPos dat) + (unP $ SDL.mouseMotionEventPos dat) (SDL.mouseMotionEventRelMotion dat) ) - doComsume es + doConsume es SDL.MouseButtonEvent dat -> do partEmit am (MsgMouseButton (SDL.eventTimestamp e) @@ -49,16 +53,16 @@ instance SDLSubsystem AffectionMouse where (SDL.mouseButtonEventWhich dat) (SDL.mouseButtonEventButton dat) (SDL.mouseButtonEventClicks dat) - (SDL.mouseButtonEventPos dat) + (unP $ SDL.mouseButtonEventPos dat) ) doConsume es SDL.MouseWheelEvent dat -> do partEmit am (MsgMouseWheel (SDL.eventTimestamp e) (SDL.mouseWheelEventWindow dat) - (SDL.mouseWheelEvntWhich dat) + (SDL.mouseWheelEventWhich dat) (SDL.mouseWheelEventPos dat) (SDL.mouseWheelEventDirection dat) ) doConsume es - _ -> fmap (e :) (doComsume es) + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 90b560a..aebe2ee 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} module Affection.Subsystems.AffectionWindow where import Affection.Types @@ -11,10 +12,10 @@ import Control.Monad.IO.Class (liftIO) import qualified SDL data AffectionWindow sd = AffectionWindow - { windowSubscribers :: TVar [(UUID, WindowMessage -> Affection sd ())] + { windowSubscribers :: forall sd. TVar [(UUID, WindowMessage -> Affection sd ())] } -instance Participant AffectionWindow WindowMessage where +instance Participant (AffectionWindow sd) WindowMessage where partSubscribe p funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :) @@ -28,7 +29,7 @@ instance Participant AffectionWindow WindowMessage where subTups <- liftIO $ readTVarIO $ windowSubscribers p return $ map snd subTups -instance SDLSubsystem AffectionWindow WindowMessage where +instance SDLSubsystem (AffectionWindow sd) WindowMessage where consumeSDLEvents aw evs = doConsume evs where doConsume [] = return []