event system works!

examples/example00.hs

@@ -1,21 +1,74 @@
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 import Affection
 import qualified SDL
 
 import Control.Concurrent.STM
+import Control.Monad.IO.Class (liftIO)
 
 data StateData = StateData
   { sdSubs :: Subsystems
   }
 
 data Subsystems = Subsystems
-  { subWindow :: AffectionWindow StateData
-  , subMouse :: AffectionMouse StateData
-  , subKeyboard :: AffectionKeyboard StateData
+  { subWindow :: Window
+  , subMouse :: Mouse
+  , subKeyboard :: Keyboard
   }
 
+data Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
+data Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
+data Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
+
+instance Participant Window WindowMessage StateData where
+  partSubscribers (Window t) = do
+    subTups <- liftIO $ readTVarIO $ t
+    return $ map snd subTups
+
+  partSubscribe (Window t) funct = do
+    uuid <- genUUID
+    liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+    return uuid
+
+  partUnSubscribe (Window t) uuid =
+    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
+
+instance SDLSubsystem Window StateData where
+  consumeSDLEvents = consumeSDLWindowEvents
+
+instance Participant Mouse MouseMessage StateData where
+  partSubscribers (Mouse t) = do
+    subTups <- liftIO $ readTVarIO $ t
+    return $ map snd subTups
+
+  partSubscribe (Mouse t) funct = do
+    uuid <- genUUID
+    liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+    return uuid
+
+  partUnSubscribe (Mouse t) uuid =
+    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
+
+instance SDLSubsystem Mouse StateData where
+  consumeSDLEvents = consumeSDLMouseEvents
+
+instance Participant Keyboard KeyboardMessage StateData where
+  partSubscribers (Keyboard t) = do
+    subTups <- liftIO $ readTVarIO $ t
+    return $ map snd subTups
+
+  partSubscribe (Keyboard t) funct = do
+    uuid <- genUUID
+    liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+    return uuid
+
+  partUnSubscribe (Keyboard t) uuid =
+    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
+
+instance SDLSubsystem Keyboard StateData where
+  consumeSDLEvents = consumeSDLKeyboardEvents
+
 main :: IO ()
 main = do
   logIO Debug "Starting"
@@ -23,6 +76,10 @@ main = do
         { initComponents = All
         , windowTitle = "affection: example00"
         , windowConfig = SDL.defaultWindow
+          { SDL.windowOpenGL = Just SDL.defaultOpenGL
+            { SDL.glProfile = SDL.Core SDL.Normal 3 3
+            }
+          }
         , initScreenMode = SDL.Windowed
         , canvasSize = Nothing
         , loadState = load
@@ -40,9 +97,9 @@ load = do
   empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
   empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
   return $ StateData $ Subsystems
-    (AffectionWindow empty1)
-    (AffectionMouse empty2)
-    (AffectionKeyboard empty3)
+    (Window empty1)
+    (Mouse empty2)
+    (Keyboard empty3)
 
 pre :: Affection StateData ()
 pre = do

src/Affection/MessageBus/Class.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE RankNTypes #-}
 module Affection.MessageBus.Class 
   ( Participant(..)
   , genUUID
@@ -17,34 +17,45 @@ import Data.UUID.V4
 
 import Affection.Logging
 
-class (Show m, Message m) => Participant prt m where
-  -- | Function to get the lsit of subscribers from the participant
+class (Show m, Message m) => Participant prt m us where
+
+  -- | Function to get the list of subscribers from the participant
   partSubscribers
-    :: prt                                   -- ^ the participant
-    -> forall us. Affection us [(m -> Affection us ())] -- ^ List of Subscriber functions
+    :: prt
+    -- ^ the 'Participant''s subscriber storage
+    -> Affection us [(m -> Affection us ())]
+    -- ^ List of Subscriber functions
 
   -- | Subscribe to the 'Participant''s events
   partSubscribe
-    :: prt               -- ^ The 'Participant' to subscribe to
-    -> (forall us. m -> Affection us ())      -- ^ What to do in case of a 'Message'
+    :: prt
+    -- ^ The 'Participant''s subscriber storage
+    -> (m -> Affection us ())
+    -- ^ What to do in case of a 'Message'
     -- (Subscriber function)
-    -> Affection us UUID -- ^ 'UUID' of the registered subscriber Function
+    -> Affection us UUID
+    -- ^ 'UUID' of the registered subscriber Function
 
   -- | Unsubscribe a Subscriber function from Participant
   partUnSubscribe
-    :: prt             -- ^ The 'Participant' to unsubscribe from
-    -> UUID            -- ^ The subscriber function's 'UUID'
+    :: prt
+    -- ^ The 'Participant''s subscriber storage to unsubscribe from
+    -> UUID
+    -- ^ The subscriber function's 'UUID'
     -> Affection us ()
 
   -- | Get the 'Participant' to emit a 'Message' on all of its subscribers
   partEmit
-    :: prt             -- ^ The 'Participant'
-    -> m               -- ^ The 'Message' to emit
+    :: prt
+    -- ^ The 'Participant''s subscriber storage
+    -> m
+    -- ^ The 'Message' to emit
     -> Affection us ()
   partEmit p m = do
     liftIO $ logIO Debug $ "Emitting message: " ++ show m
     l <- partSubscribers p
     mapM_ ($ m) l
 
+-- | Helper function to generate new 'UUID's
 genUUID :: Affection us UUID
 genUUID = liftIO $ nextRandom

src/Affection/Subsystems/AffectionKeyboard.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Affection.Subsystems.AffectionKeyboard where
 
 import Affection.Types
@@ -12,27 +12,14 @@ import Control.Monad.IO.Class (liftIO)
 
 import qualified SDL
 
-data AffectionKeyboard us = AffectionKeyboard
-  { keyboardSubscribers :: forall us. TVar [(UUID, KeyboardMessage -> Affection us ())]
-  }
-
-instance Participant (AffectionKeyboard us) KeyboardMessage where
-  partSubscribe p funct = do
-    uuid <- genUUID
-    liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :)
-    return uuid
-
-  partUnSubscribe p uuid =
-    liftIO $ atomically $ modifyTVar' (keyboardSubscribers p)
-      (filter (\(u, _) -> u /= uuid))
-
-  partSubscribers p = do
-    subTups <- liftIO $ readTVarIO $ keyboardSubscribers p
-    return $ map snd subTups
-
-instance SDLSubsystem (AffectionKeyboard us) KeyboardMessage where
-  consumeSDLEvents ak eps = doConsume eps
+consumeSDLKeyboardEvents
+  :: (Participant ak KeyboardMessage us)
+  => ak
+  -> [SDL.EventPayload]
+  -> Affection us [SDL.EventPayload]
+consumeSDLKeyboardEvents ak eps = doConsume eps
   where
+    doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime
       case e of

src/Affection/Subsystems/AffectionMouse.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Affection.Subsystems.AffectionMouse where
 
 import Affection.MessageBus
@@ -14,27 +14,14 @@ import Linear.Affine (unP)
 
 import qualified SDL
 
-data AffectionMouse sd = AffectionMouse
-  { mouseSubscribers :: forall sd. TVar [(UUID, MouseMessage -> Affection sd ())]
-  }
-
-instance Participant (AffectionMouse sd) MouseMessage where
-  partSubscribe p funct = do
-    uuid <- genUUID
-    liftIO $ atomically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :)
-    return uuid
-
-  partUnSubscribe p uuid =
-    liftIO $ atomically $ modifyTVar' (mouseSubscribers p)
-      (filter (\(u, _) -> u /= uuid))
-
-  partSubscribers p = do
-    subTups <- liftIO $ readTVarIO $ mouseSubscribers p
-    return $ map snd subTups
-
-instance SDLSubsystem (AffectionMouse sd) MouseMessage where
-  consumeSDLEvents am eps = doConsume eps
+consumeSDLMouseEvents
+  :: (Participant am MouseMessage us)
+  => am
+  -> [SDL.EventPayload]
+  -> Affection us [SDL.EventPayload]
+consumeSDLMouseEvents am eps = doConsume eps
   where
+    doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime
       case e of

src/Affection/Subsystems/AffectionWindow.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Affection.Subsystems.AffectionWindow where
 
 import Affection.Types
@@ -13,27 +13,14 @@ import Control.Monad.IO.Class (liftIO)
 
 import qualified SDL
 
-data AffectionWindow us = AffectionWindow
-  { windowSubscribers :: forall us. TVar [(UUID, WindowMessage -> Affection us ())]
-  }
-
-instance Participant (AffectionWindow us) WindowMessage where
-  partSubscribe p funct = do
-    uuid <- genUUID
-    liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :)
-    return uuid
-
-  partUnSubscribe p uuid =
-    liftIO $ atomically $ modifyTVar' (windowSubscribers p)
-      (filter (\(u, _) -> u /= uuid))
-
-  partSubscribers p = do
-    subTups <- liftIO $ readTVarIO $ windowSubscribers p
-    return $ map snd subTups
-
-instance SDLSubsystem (AffectionWindow us) WindowMessage where
-  consumeSDLEvents aw eps = doConsume eps
+consumeSDLWindowEvents
+  :: (Participant aw WindowMessage us)
+  => aw
+  -> [SDL.EventPayload]
+  -> Affection us [SDL.EventPayload]
+consumeSDLWindowEvents aw eps = doConsume eps
   where
+    doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime
       case e of

src/Affection/Subsystems/Class.hs

@@ -7,5 +7,5 @@ import Affection.MessageBus
 
 import qualified SDL
 
-class (Message m, Participant s m) => SDLSubsystem s m where
-  consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection sd [SDL.EventPayload]
+class SDLSubsystem s us where
+  consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]