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
+  { subWindow :: Window
-  , subMouse :: AffectionMouse StateData
+  , subMouse :: Mouse
-  , subKeyboard :: AffectionKeyboard StateData
+  , 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)
+    (Window empty1)
-    (AffectionMouse empty2)
+    (Mouse empty2)
-    (AffectionKeyboard empty3)
+    (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
+class (Show m, Message m) => Participant prt m us where
-  -- | Function to get the lsit of subscribers from the participant
+
+  -- | Function to get the list of subscribers from the participant
   partSubscribers
-    :: prt                                   -- ^ the participant
+    :: prt
-    -> forall us. Affection us [(m -> Affection us ())] -- ^ List of Subscriber functions
+    -- ^ 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
+    :: prt
-    -> (forall us. m -> Affection us ())      -- ^ What to do in case of a 'Message'
+    -- ^ The 'Participant''s subscriber storage
-                         -- (Subscriber function)
+    -> (m -> Affection us ())
-    -> Affection us UUID -- ^ 'UUID' of the registered subscriber Function
+    -- ^ What to do in case of a 'Message'
+    -- (Subscriber function)
+    -> Affection us UUID
+    -- ^ 'UUID' of the registered subscriber Function
 
   -- | Unsubscribe a Subscriber function from Participant
   partUnSubscribe
-    :: prt             -- ^ The 'Participant' to unsubscribe from
+    :: prt
-    -> UUID            -- ^ The subscriber function's 'UUID'
+    -- ^ 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'
+    :: prt
-    -> m               -- ^ The 'Message' to emit
+    -- ^ 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,37 +12,24 @@ import Control.Monad.IO.Class (liftIO)
 
 import qualified SDL
 
-data AffectionKeyboard us = AffectionKeyboard
+consumeSDLKeyboardEvents
-  { keyboardSubscribers :: forall us. TVar [(UUID, KeyboardMessage -> Affection us ())]
+  :: (Participant ak KeyboardMessage us)
-  }
+  => ak
-
+  -> [SDL.EventPayload]
-instance Participant (AffectionKeyboard us) KeyboardMessage where
+  -> Affection us [SDL.EventPayload]
-  partSubscribe p funct = do
+consumeSDLKeyboardEvents ak eps = doConsume eps
-    uuid <- genUUID
+  where
-    liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :)
+    doConsume [] = return []
-    return uuid
+    doConsume (e:es) = do
-
+      ts <- getElapsedTime
-  partUnSubscribe p uuid =
+      case e of
-    liftIO $ atomically $ modifyTVar' (keyboardSubscribers p)
+        SDL.KeyboardEvent dat -> do
-      (filter (\(u, _) -> u /= uuid))
+          partEmit ak (MsgKeyboardEvent
-
+            ts
-  partSubscribers p = do
+            (SDL.keyboardEventWindow dat)
-    subTups <- liftIO $ readTVarIO $ keyboardSubscribers p
+            (SDL.keyboardEventKeyMotion dat)
-    return $ map snd subTups
+            (SDL.keyboardEventRepeat dat)
-
+            (SDL.keyboardEventKeysym dat)
-instance SDLSubsystem (AffectionKeyboard us) KeyboardMessage where
+            )
-  consumeSDLEvents ak eps = doConsume eps
+          doConsume es
-    where
+        _ -> fmap (e :) (doConsume es)
-      doConsume (e:es) = do
-        ts <- getElapsedTime
-        case e of
-          SDL.KeyboardEvent dat -> do
-            partEmit ak (MsgKeyboardEvent
-              ts
-              (SDL.keyboardEventWindow dat)
-              (SDL.keyboardEventKeyMotion dat)
-              (SDL.keyboardEventRepeat dat)
-              (SDL.keyboardEventKeysym dat)
-              )
-            doConsume es
-          _ -> fmap (e :) (doConsume es)

src/Affection/Subsystems/AffectionMouse.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Affection.Subsystems.AffectionMouse where
 
 import Affection.MessageBus
@@ -14,57 +14,44 @@ import Linear.Affine (unP)
 
 import qualified SDL
 
-data AffectionMouse sd = AffectionMouse
+consumeSDLMouseEvents
-  { mouseSubscribers :: forall sd. TVar [(UUID, MouseMessage -> Affection sd ())]
+  :: (Participant am MouseMessage us)
-  }
+  => am
-
+  -> [SDL.EventPayload]
-instance Participant (AffectionMouse sd) MouseMessage where
+  -> Affection us [SDL.EventPayload]
-  partSubscribe p funct = do
+consumeSDLMouseEvents am eps = doConsume eps
-    uuid <- genUUID
+  where
-    liftIO $ atomically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :)
+    doConsume [] = return []
-    return uuid
+    doConsume (e:es) = do
-
+      ts <- getElapsedTime
-  partUnSubscribe p uuid =
+      case e of
-    liftIO $ atomically $ modifyTVar' (mouseSubscribers p)
+        SDL.MouseMotionEvent dat -> do
-      (filter (\(u, _) -> u /= uuid))
+          partEmit am (MsgMouseMotion
-
+            ts
-  partSubscribers p = do
+            (SDL.mouseMotionEventWindow dat)
-    subTups <- liftIO $ readTVarIO $ mouseSubscribers p
+            (SDL.mouseMotionEventWhich dat)
-    return $ map snd subTups
+            (SDL.mouseMotionEventState dat)
-
+            (unP $ SDL.mouseMotionEventPos dat)
-instance SDLSubsystem (AffectionMouse sd) MouseMessage where
+            (SDL.mouseMotionEventRelMotion dat)
-  consumeSDLEvents am eps = doConsume eps
+            )
-    where
+          doConsume es
-      doConsume (e:es) = do
+        SDL.MouseButtonEvent dat -> do
-        ts <- getElapsedTime
+          partEmit am (MsgMouseButton
-        case e of
+            ts
-          SDL.MouseMotionEvent dat -> do
+            (SDL.mouseButtonEventWindow dat)
-            partEmit am (MsgMouseMotion
+            (SDL.mouseButtonEventWhich dat)
-              ts
+            (SDL.mouseButtonEventButton dat)
-              (SDL.mouseMotionEventWindow dat)
+            (SDL.mouseButtonEventClicks dat)
-              (SDL.mouseMotionEventWhich dat)
+            (unP $ SDL.mouseButtonEventPos dat)
-              (SDL.mouseMotionEventState dat)
+            )
-              (unP $ SDL.mouseMotionEventPos dat)
+          doConsume es
-              (SDL.mouseMotionEventRelMotion dat)
+        SDL.MouseWheelEvent dat -> do
-              )
+          partEmit am (MsgMouseWheel
-            doConsume es
+            ts
-          SDL.MouseButtonEvent dat -> do
+            (SDL.mouseWheelEventWindow dat)
-            partEmit am (MsgMouseButton
+            (SDL.mouseWheelEventWhich dat)
-              ts
+            (SDL.mouseWheelEventPos dat)
-              (SDL.mouseButtonEventWindow dat)
+            (SDL.mouseWheelEventDirection dat)
-              (SDL.mouseButtonEventWhich dat)
+            )
-              (SDL.mouseButtonEventButton dat)
+          doConsume es
-              (SDL.mouseButtonEventClicks dat)
+        _ -> fmap (e :) (doConsume es)
-              (unP $ SDL.mouseButtonEventPos dat)
-              )
-            doConsume es
-          SDL.MouseWheelEvent dat -> do
-            partEmit am (MsgMouseWheel
-              ts
-              (SDL.mouseWheelEventWindow dat)
-              (SDL.mouseWheelEventWhich dat)
-              (SDL.mouseWheelEventPos dat)
-              (SDL.mouseWheelEventDirection dat)
-              )
-            doConsume es
-          _ -> fmap (e :) (doConsume es)

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,70 +13,57 @@ import Control.Monad.IO.Class (liftIO)
 
 import qualified SDL
 
-data AffectionWindow us = AffectionWindow
+consumeSDLWindowEvents
-  { windowSubscribers :: forall us. TVar [(UUID, WindowMessage -> Affection us ())]
+  :: (Participant aw WindowMessage us)
-  }
+  => aw
-
+  -> [SDL.EventPayload]
-instance Participant (AffectionWindow us) WindowMessage where
+  -> Affection us [SDL.EventPayload]
-  partSubscribe p funct = do
+consumeSDLWindowEvents aw eps = doConsume eps
-    uuid <- genUUID
+  where
-    liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :)
+    doConsume [] = return []
-    return uuid
+    doConsume (e:es) = do
-
+      ts <- getElapsedTime
-  partUnSubscribe p uuid =
+      case e of
-    liftIO $ atomically $ modifyTVar' (windowSubscribers p)
+        SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
-      (filter (\(u, _) -> u /= uuid))
+          partEmit aw (MsgWindowShow ts window)
-
+          doConsume es
-  partSubscribers p = do
+        SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
-    subTups <- liftIO $ readTVarIO $ windowSubscribers p
+          partEmit aw (MsgWindowHide ts window)
-    return $ map snd subTups
+          doConsume es
-
+        SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
-instance SDLSubsystem (AffectionWindow us) WindowMessage where
+          partEmit aw (MsgWindowExpose ts window)
-  consumeSDLEvents aw eps = doConsume eps
+          doConsume es
-    where
+        SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
-      doConsume (e:es) = do
+          partEmit aw (MsgWindowMove ts window newPos)
-        ts <- getElapsedTime
+          doConsume es
-        case e of
+        SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
-          SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
+          partEmit aw (MsgWindowResize ts window newSize)
-            partEmit aw (MsgWindowShow ts window)
+          doConsume es
-            doConsume es
+        SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
-          SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
+          partEmit aw (MsgWindowSizeChange ts window)
-            partEmit aw (MsgWindowHide ts window)
+          doConsume es
-            doConsume es
+        SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
-          SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
+          partEmit aw (MsgWindowMinimize ts window)
-            partEmit aw (MsgWindowExpose ts window)
+          doConsume es
-            doConsume es
+        SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
-          SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
+          partEmit aw (MsgWindowMaximize ts window)
-            partEmit aw (MsgWindowMove ts window newPos)
+          doConsume es
-            doConsume es
+        SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
-          SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
+          partEmit aw (MsgWindowRestore ts window)
-            partEmit aw (MsgWindowResize ts window newSize)
+          doConsume es
-            doConsume es
+        SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
-          SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
+          partEmit aw (MsgWindowGainMouseFocus ts window)
-            partEmit aw (MsgWindowSizeChange ts window)
+          doConsume es
-            doConsume es
+        SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
-          SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
+          partEmit aw (MsgWindowLoseMouseFocus ts window)
-            partEmit aw (MsgWindowMinimize ts window)
+          doConsume es
-            doConsume es
+        SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
-          SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
+          partEmit aw (MsgWindowGainKeyboardFocus ts window)
-            partEmit aw (MsgWindowMaximize ts window)
+          doConsume es
-            doConsume es
+        SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
-          SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
+          partEmit aw (MsgWindowLoseKeyboardFocus ts window)
-            partEmit aw (MsgWindowRestore ts window)
+          doConsume es
-            doConsume es
+        SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
-          SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
+          partEmit aw (MsgWindowClose ts window)
-            partEmit aw (MsgWindowGainMouseFocus ts window)
+          doConsume es
-            doConsume es
+        _ -> fmap (e :) (doConsume es)
-          SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
-            partEmit aw (MsgWindowLoseMouseFocus ts window)
-            doConsume es
-          SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
-            partEmit aw (MsgWindowGainKeyboardFocus ts window)
-            doConsume es
-          SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
-            partEmit aw (MsgWindowLoseKeyboardFocus ts window)
-            doConsume es
-          SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
-            partEmit aw (MsgWindowClose ts window)
-            doConsume es
-          _ -> fmap (e :) (doConsume es)

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
+class SDLSubsystem s us where
-  consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection sd [SDL.EventPayload]
+  consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]