fixing things up

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
 

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

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
+data AffectionKeyboard sd = AffectionKeyboard
-  { keyboardSubscribers :: TVar [(UUID, KeyboardMessage -> IO ())]
+  { 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 []

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
+data AffectionMouse sd = AffectionMouse
-  { mouseSubscribers :: TVar (UUID, MouseMessage -> IO ())
+  { 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
+instance SDLSubsystem (AffectionMouse sd) MouseMessage where
-  consumeSDLEvents am evs = doComsume evs
+  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)

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 []