still won't work

affection.cabal

@@ -70,6 +70,7 @@ library
                      , Affection.MessageBus.Message.WindowMessage
                      , Affection.MessageBus.Message.KeyboardMessage
                      , Affection.MessageBus.Message.MouseMessage
+                     , Affection.Subsystems
                      , Affection.Subsystems.Class
                      , Affection.Subsystems.AffectionWindow
                      , Affection.Subsystems.AffectionKeyboard
@@ -104,23 +105,26 @@ library
                      , stm
                      , uuid
 
--- executable example00
+executable example00
---   hs-source-dirs:    examples
+  if flag(debug)
---   main-is:           example00.hs
+    cpp-options:       -DDEBUG
---   ghc-options:       -threaded -Wall
+  if flag(warn)
---   default-language:  Haskell2010
+    cpp-options:       -DWARN
---   default-extensions: OverloadedStrings
+  if flag(error)
---   if flag(examples)
+    cpp-options:       -DERROR
---     build-depends:     base
+  hs-source-dirs:    examples
---                      , affection
+  main-is:           example00.hs
---                      , sdl2
+  ghc-options:       -threaded -Wall
---                      , gegl
+  default-language:  Haskell2010
---                      , babl
+  default-extensions: OverloadedStrings
---                      , containers
+  if flag(examples)
---                      , mtl
+    build-depends:     base
---   else
+                     , affection
---     buildable:       False
+                     , sdl2
--- 
+                     , stm
+  else
+    buildable:       False
+
 -- executable example01
 --   hs-source-dirs:    examples
 --   main-is:           example01.hs
@@ -209,26 +213,26 @@ library
 --                      , monad-parallel
 --   else
 --     buildable:       False
-
+-- 
-executable example05
+-- executable example05
-  hs-source-dirs:    examples
+--   hs-source-dirs:    examples
-  main-is:           example05.hs
+--   main-is:           example05.hs
-  ghc-options:       -threaded -Wall -auto-all -caf-all -rtsopts
+--   ghc-options:       -threaded -Wall -auto-all -caf-all -rtsopts
-  default-language:  Haskell2010
+--   default-language:  Haskell2010
-  default-extensions: OverloadedStrings
+--   default-extensions: OverloadedStrings
-  if flag(examples)
+--   if flag(examples)
-    build-depends:     base
+--     build-depends:     base
-                     , affection
+--                      , affection
-                     , sdl2
+--                      , sdl2
-                     , gegl
+--                      , gegl
-                     , babl
+--                      , babl
-                     , containers
+--                      , containers
-                     , unordered-containers
+--                      , unordered-containers
-                     , mtl
+--                      , mtl
-                     , random
+--                      , random
-                     , matrix
+--                      , matrix
-                     , random
+--                      , random
-                     , monad-parallel
+--                      , monad-parallel
-                     , parallel
+--                      , parallel
-  else
+--   else
-    buildable:       False
+--     buildable:       False

examples/example00.hs

@@ -1,117 +1,71 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RankNTypes #-}
 
 import Affection
 import qualified SDL
-import qualified SDL.Raw as Raw
-import qualified GEGL as G
-import qualified BABL as B
-import qualified Data.Map.Strict as M
 
-import Control.Monad (when)
+import Control.Concurrent.STM
 
-import Foreign.Storable (peek)
+data StateData = StateData
-import Foreign.C.Types  (CInt(..))
+  { sdSubs :: Subsystems
+  }
 
-import Debug.Trace
+data Subsystems = Subsystems
-
+  { subWindow :: AffectionWindow StateData
--- main :: IO ()
+  , subMouse :: AffectionMouse StateData
--- main = withAllAffection $
+  , subKeyboard :: AffectionKeyboard StateData
---   withDefaultWindow "test" $ do
+  }
---     changeColor $ RGBA 255 255 255 255
---     clear
---     present
---     liftIO $ delaySec 2
 
 main :: IO ()
 main = do
-  conf <- return $ AffectionConfig
+  logIO Debug "Starting"
-    { initComponents = All
+  let conf = AffectionConfig
-    , windowTitle    = "Affection: example00"
+        { initComponents = All
-    , windowConfig   = SDL.defaultWindow
+        , windowTitle = "affection: example00"
-    , preLoop        = return ()
+        , windowConfig = SDL.defaultWindow
-    , eventLoop      = handle
+        , initScreenMode = SDL.Windowed
-    , updateLoop     = update
+        , canvasSize = Nothing
-    , drawLoop       = draw
+        , loadState = load
-    , loadState      = load
+        , preLoop = pre
-    , cleanUp        = clean
+        , eventLoop = handle
-    }
+        , updateLoop = update
+        , drawLoop = draw
+        , cleanUp = clean
+        }
   withAffection conf
 
-data UserData = UserData
+load :: IO StateData
-  { nodeGraph   :: M.Map String G.GeglNode
-  }
-
-load :: IO UserData
 load = do
-  traceM "loading"
+  empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())])
-  root <- G.gegl_node_new
+  empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
-  traceM "new root node"
+  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
-  checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $
+  return $ StateData $ Subsystems
-    props $ do
+    (AffectionWindow empty1)
-        prop "color1" $ G.RGBA 0.4 0.4 0.4 1
+    (AffectionMouse empty2)
-        prop "color2" $ G.RGBA 0.6 0.6 0.6 1
+    (AffectionKeyboard empty3)
-  traceM "checkerboard"
-  over <- G.gegl_node_new_child root G.defaultOverOperation
-  traceM "over"
-  text <- G.gegl_node_new_child root $ G.textOperation $
-    props $ do
-        prop "string" ("Hello world!"::String)
-        prop "color" $ G.RGBA 0 0 1 0.5
-        prop "size" (40::Int)
-  traceM "text"
-  G.gegl_node_link checkerboard over
-  G.gegl_node_connect_to text "output" over "aux"
-  traceM "connections made"
-  myMap <- return $ M.fromList
-    [ ("root"        , root)
-    , ("over"        , over)
-    , ("checkerboard", checkerboard)
-    , ("text"        , text)
-    ]
-  traceM "loading complete"
-  return $ UserData
-    { nodeGraph = myMap
-    }
 
-draw :: Affection UserData ()
+pre :: Affection StateData ()
-draw = do
+pre = do
-  traceM "drawing"
+  sd <- getAffection
-  AffectionData{..} <- get
+  _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
-  let UserData{..} = userState
+  return ()
-  liftIO $ SDL.lockSurface drawSurface
-  pixels <- liftIO $ SDL.surfacePixels drawSurface
-  let SDL.Surface rawSurfacePtr _ = drawSurface
-  rawSurface <- liftIO $ peek rawSurfacePtr
-  pixelFormat <- liftIO $ peek $ Raw.surfaceFormat rawSurface
-  format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8)
-  SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface
-  let (w, h) = (fromIntegral rw, fromIntegral rh)
-  liftIO $ G.gegl_node_blit
-    (nodeGraph M.! "over" :: G.GeglNode)
-    1
-    (G.GeglRectangle 0 0 w h)
-    format
-    pixels
-    (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w)
-    [G.GeglBlitDefault]
-  liftIO $ SDL.unlockSurface drawSurface
-  liftIO $ SDL.updateWindowSurface drawWindow
 
-handle :: SDL.EventPayload -> Affection UserData ()
+exitOnQ :: KeyboardMessage -> Affection StateData ()
-handle = const $ return ()
+exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
+  case SDL.keysymKeycode sym of
+    SDL.KeycodeQ -> quit
+    otherwise -> return ()
 
-update :: Double -> Affection UserData ()
+handle :: [SDL.EventPayload] -> Affection StateData ()
-update sec = do
+handle es = do
-  traceM "updating"
+  (Subsystems a b c) <- sdSubs <$> getAffection
-  ad <- get
+  _ <- consumeSDLEvents a es
-  ud@UserData{..} <- getAffection
+  _ <- consumeSDLEvents b es
+  _ <- consumeSDLEvents c es
+  return ()
 
-  -- sec <- getDelta
+update _ = return ()
-  traceM $ (show $ 1 / sec) ++ " FPS"
+
-  when (elapsedTime ad > 5) $
+draw = return ()
-    put $ ad
-      { quitEvent = True
-      }
 
-clean :: UserData -> IO ()
 clean _ = return ()

src/Affection.hs

@@ -24,6 +24,9 @@ import Affection.StateMachine as A
 import Affection.MouseInteractable as A
 import Affection.Util as A
 import Affection.MessageBus as A
+import Affection.Subsystems as A
+
+import Affection.Logging as A
 
 import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
 
@@ -45,7 +48,7 @@ withAffection AffectionConfig{..} = do
   do
     renderQuality <- SDL.get SDL.HintRenderScaleQuality
     when (renderQuality /= SDL.ScaleLinear) $
-      putStrLn "Warning: Linear texture filtering not enabled!"
+      logIO Warn "Linear texture filtering not enabled!"
   -- construct window
   window <- SDL.createWindow windowTitle windowConfig
   SDL.showWindow window
@@ -94,7 +97,8 @@ withAffection AffectionConfig{..} = do
           }
         -- poll events
         evs <- preHandleEvents =<< liftIO SDL.pollEvents
-        mapM_ eventLoop evs
+        -- mapM_ eventLoop evs
+        eventLoop evs
         -- execute user defined update loop
         unless (pausedTime ad) (updateLoop dt)
         -- execute user defined draw loop

src/Affection/MessageBus.hs

@@ -1,7 +1,10 @@
 module Affection.MessageBus
   ( module M
+  , module Msg
   ) where
 
 import Affection.MessageBus.Class as M
 import Affection.MessageBus.Message as M
 import Affection.MessageBus.Util as M
+
+import Affection.MessageBus.Message as Msg

src/Affection/MessageBus/Class.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE Rank2Types #-}
 module Affection.MessageBus.Class 
   ( Participant(..)
   , genUUID
@@ -20,13 +20,13 @@ import Affection.Logging
 class (Show m, Message m) => Participant prt m where
   -- | Function to get the lsit of subscribers from the participant
   partSubscribers
-    :: prt                         -- ^ the participant
+    ::  prt                                  -- ^ the participant
     -> Affection sd [(m -> Affection sd ())] -- ^ List of Subscriber functions
 
   -- | Subscribe to the 'Participant''s events
   partSubscribe
     :: prt               -- ^ The 'Participant' to subscribe to
-    -> (forall sd. m -> Affection sd ())      -- ^ What to do in case of a 'Message'
+    -> (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/Class.hs

@@ -3,4 +3,4 @@ module Affection.MessageBus.Message.Class where
 import Data.Word (Word32(..))
 
 class Message msg where
-  msgTime :: msg -> Word32
+  msgTime :: msg -> Double

src/Affection/MessageBus/Message/KeyboardMessage.hs

@@ -2,12 +2,10 @@ module Affection.MessageBus.Message.KeyboardMessage where
 
 import Affection.MessageBus.Message.Class
 
-import Data.Word (Word32(..))
-
 import qualified SDL
 
 data KeyboardMessage = MsgKeyboardEvent
-  { msgKbdWhen :: Word32
+  { msgKbdWhen :: Double
   , msgKbdWindow :: Maybe SDL.Window
   , msgKbdKeyMotion :: SDL.InputMotion
   , msgKbdLeyRepeat :: Bool

src/Affection/MessageBus/Message/MouseMessage.hs

@@ -2,7 +2,7 @@ module Affection.MessageBus.Message.MouseMessage where
 
 import Affection.MessageBus.Message.Class
 
-import Data.Word (Word32(..), Word8(..))
+import Data.Word (Word8(..))
 import Data.Int (Int32(..))
 
 import qualified SDL
@@ -11,7 +11,7 @@ import Linear (V2(..))
 
 data MouseMessage
   = MsgMouseMotion
-    { msgMMWhen :: Word32
+    { msgMMWhen :: Double
     , msgMMWindow :: Maybe SDL.Window
     , msgMMWhich :: SDL.MouseDevice
     , msgMMState :: [SDL.MouseButton]
@@ -19,7 +19,7 @@ data MouseMessage
     , msgMMRelMotion :: V2 Int32
     }
   | MsgMouseButton
-    { msgMBWhen :: Word32
+    { msgMBWhen :: Double
     , msgMBWindow :: Maybe SDL.Window
     , msgMBWhich :: SDL.MouseDevice
     , msgMBButton :: SDL.MouseButton
@@ -27,7 +27,7 @@ data MouseMessage
     , msgMBPos :: V2 Int32
     }
   | MsgMouseWheel
-    { msgMWWhen :: Word32
+    { msgMWWhen :: Double
     , msgMWWhindow :: Maybe SDL.Window
     , msgMWWhich :: SDL.MouseDevice
     , msgMWPos :: V2 Int32

src/Affection/MessageBus/Message/WindowMessage.hs

@@ -2,7 +2,6 @@ module Affection.MessageBus.Message.WindowMessage where
 
 import Affection.MessageBus.Message.Class
 
-import Data.Word (Word32(..))
 import Data.Int (Int32(..))
 
 import qualified SDL
@@ -10,63 +9,63 @@ import qualified SDL
 import Linear (V2(..))
 
 data WindowMessage
-  -- = MsgEngineReady Word32
+  -- = MsgEngineReady Double
   = MsgWindowShow
-    { msgWSWhen :: Word32
+    { msgWSWhen :: Double
     , msgWSWindow :: SDL.Window
     }
   | MsgWindowHide
-    { msgWHWhen :: Word32
+    { msgWHWhen :: Double
     , msgWHWindow :: SDL.Window
     }
   | MsgWindowExpose
-    { msgWEWhen :: Word32
+    { msgWEWhen :: Double
     , msgWEWindow :: SDL.Window
     }
   | MsgWindowMove
-    { msgWMWhen :: Word32
+    { msgWMWhen :: Double
     , msgWMWindow :: SDL.Window
     , msgWMNewPos :: V2 Int32
     }
   | MsgWindowResize
-    { msgWRWhen :: Word32
+    { msgWRWhen :: Double
     , msgWRWindow :: SDL.Window
     , msgWRNewSize :: V2 Int32
     }
   | MsgWindowSizeChange
-    { msgWSCWhen :: Word32
+    { msgWSCWhen :: Double
     , msgWSCWindow :: SDL.Window
     }
   | MsgWindowMinimize
-    { msgWMinWhen :: Word32
+    { msgWMinWhen :: Double
     , msgWMinWindow :: SDL.Window
     }
   | MsgWindowMaximize
-    { msgWMaxWhen :: Word32
+    { msgWMaxWhen :: Double
     , msgWMaxWindow :: SDL.Window
     }
   | MsgWindowRestore
-    { msgWRestWhen :: Word32
+    { msgWRestWhen :: Double
     , msgWRestWindow :: SDL.Window
     }
   | MsgWindowGainMouseFocus
-    { msgWGMFWhen :: Word32
+    { msgWGMFWhen :: Double
     , msgWGMFWindow :: SDL.Window
     }
   | MsgWindowLoseMouseFocus
-    { msgWLMFWhen :: Word32
+    { msgWLMFWhen :: Double
     , msgWLMFWindow :: SDL.Window
     }
   | MsgWindowGainKeyboardFocus
-    { msgWGKFWhen :: Word32
+    { msgWGKFWhen :: Double
     , msgWGKFWindow :: SDL.Window
     }
   | MsgWindowLoseKeyboardFocus
-    { msgWLKFWhen :: Word32
+    { msgWLKFWhen :: Double
     , msgWLKFWindow :: SDL.Window
     }
   | MsgWindowClose
-    { msgWCWhen :: Word32
+    { msgWCWhen :: Double
     , msgWCWindow :: SDL.Window
     }
   deriving (Show)

src/Affection/Subsystems.hs

@@ -0,0 +1,8 @@
+module Affection.Subsystems
+  ( module S
+  ) where
+
+import Affection.Subsystems.Class as S
+import Affection.Subsystems.AffectionKeyboard as S
+import Affection.Subsystems.AffectionWindow as S
+import Affection.Subsystems.AffectionMouse as S

src/Affection/Subsystems/AffectionKeyboard.hs

@@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionKeyboard where
 import Affection.MessageBus
 import Affection.Subsystems.Class
 import Affection.Types
+import Affection.Util
 
 import Control.Monad.IO.Class (liftIO)
 import Control.Concurrent.STM as STM
@@ -30,17 +31,18 @@ instance Participant (AffectionKeyboard sd) KeyboardMessage where
     return $ map snd subTups
 
 instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where
-  consumeSDLEvents ak evs = doConsume evs
+  consumeSDLEvents ak eps = doConsume eps
     where
-      doConsume [] = return []
+      doConsume (e:es) = do
-      doConsume (e:es) = case SDL.eventPayload e of
+        ts <- getElapsedTime
-        SDL.KeyboardEvent dat -> do
+        case e of
-          partEmit ak (MsgKeyboardEvent
+          SDL.KeyboardEvent dat -> do
-            (SDL.eventTimestamp e)
+            partEmit ak (MsgKeyboardEvent
-            (SDL.keyboardEventWindow dat)
+              ts
-            (SDL.keyboardEventKeyMotion dat)
+              (SDL.keyboardEventWindow dat)
-            (SDL.keyboardEventRepeat dat)
+              (SDL.keyboardEventKeyMotion dat)
-            (SDL.keyboardEventKeysym dat)
+              (SDL.keyboardEventRepeat dat)
-            )
+              (SDL.keyboardEventKeysym dat)
-          doConsume es
+              )
-        _ -> fmap (e :) (doConsume es)
+            doConsume es
+          _ -> fmap (e :) (doConsume es)

src/Affection/Subsystems/AffectionMouse.hs

@@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionMouse where
 import Affection.MessageBus
 import Affection.Subsystems.Class
 import Affection.Types
+import Affection.Util
 
 import Control.Monad.IO.Class (liftIO)
 import Control.Concurrent.STM
@@ -32,37 +33,38 @@ instance Participant (AffectionMouse sd) MouseMessage where
     return $ map snd subTups
 
 instance SDLSubsystem (AffectionMouse sd) MouseMessage where
-  consumeSDLEvents am evs = doConsume evs
+  consumeSDLEvents am eps = doConsume eps
     where
-      doConsume [] = return []
+      doConsume (e:es) = do
-      doConsume (e:es) = case SDL.eventPayload e of
+        ts <- getElapsedTime
-        SDL.MouseMotionEvent dat -> do
+        case e of
-          partEmit am (MsgMouseMotion
+          SDL.MouseMotionEvent dat -> do
-            (SDL.eventTimestamp e)
+            partEmit am (MsgMouseMotion
-            (SDL.mouseMotionEventWindow dat)
+              ts
-            (SDL.mouseMotionEventWhich dat)
+              (SDL.mouseMotionEventWindow dat)
-            (SDL.mouseMotionEventState dat)
+              (SDL.mouseMotionEventWhich dat)
-            (unP $ SDL.mouseMotionEventPos dat)
+              (SDL.mouseMotionEventState dat)
-            (SDL.mouseMotionEventRelMotion dat)
+              (unP $ SDL.mouseMotionEventPos dat)
-            )
+              (SDL.mouseMotionEventRelMotion dat)
-          doConsume es
+              )
-        SDL.MouseButtonEvent dat -> do
+            doConsume es
-          partEmit am (MsgMouseButton
+          SDL.MouseButtonEvent dat -> do
-            (SDL.eventTimestamp e)
+            partEmit am (MsgMouseButton
-            (SDL.mouseButtonEventWindow dat)
+              ts
-            (SDL.mouseButtonEventWhich dat)
+              (SDL.mouseButtonEventWindow dat)
-            (SDL.mouseButtonEventButton dat)
+              (SDL.mouseButtonEventWhich dat)
-            (SDL.mouseButtonEventClicks dat)
+              (SDL.mouseButtonEventButton dat)
-            (unP $ SDL.mouseButtonEventPos dat)
+              (SDL.mouseButtonEventClicks dat)
-            )
+              (unP $ SDL.mouseButtonEventPos dat)
-          doConsume es
+              )
-        SDL.MouseWheelEvent dat -> do
+            doConsume es
-          partEmit am (MsgMouseWheel
+          SDL.MouseWheelEvent dat -> do
-            (SDL.eventTimestamp e)
+            partEmit am (MsgMouseWheel
-            (SDL.mouseWheelEventWindow dat)
+              ts
-            (SDL.mouseWheelEventWhich dat)
+              (SDL.mouseWheelEventWindow dat)
-            (SDL.mouseWheelEventPos dat)
+              (SDL.mouseWheelEventWhich dat)
-            (SDL.mouseWheelEventDirection dat)
+              (SDL.mouseWheelEventPos dat)
-            )
+              (SDL.mouseWheelEventDirection dat)
-          doConsume es
+              )
-        _ -> fmap (e :) (doConsume es)
+            doConsume es
+          _ -> fmap (e :) (doConsume es)

src/Affection/Subsystems/AffectionWindow.hs

@@ -3,6 +3,7 @@
 module Affection.Subsystems.AffectionWindow where
 
 import Affection.Types
+import Affection.Util
 import Affection.MessageBus
 import Affection.Subsystems.Class
 
@@ -30,50 +31,51 @@ instance Participant (AffectionWindow sd) WindowMessage where
     return $ map snd subTups
 
 instance SDLSubsystem (AffectionWindow sd) WindowMessage where
-  consumeSDLEvents aw evs = doConsume evs
+  consumeSDLEvents aw eps = doConsume eps
     where
-      doConsume [] = return []
+      doConsume (e:es) = do
-      doConsume (e:es) = case SDL.eventPayload e of
+        ts <- getElapsedTime
-        SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
+        case e of
-          partEmit aw (MsgWindowShow (SDL.eventTimestamp e) window)
+          SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowShow ts window)
-        SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowHide (SDL.eventTimestamp e) window)
+          SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowHide ts window)
-        SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowExpose (SDL.eventTimestamp e) window)
+          SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowExpose ts window)
-        SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
+            doConsume es
-          partEmit aw (MsgWindowMove (SDL.eventTimestamp e) window newPos)
+          SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
-          doConsume es
+            partEmit aw (MsgWindowMove ts window newPos)
-        SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
+            doConsume es
-          partEmit aw (MsgWindowResize (SDL.eventTimestamp e) window newSize)
+          SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
-          doConsume es
+            partEmit aw (MsgWindowResize ts window newSize)
-        SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowSizeChange (SDL.eventTimestamp e) window)
+          SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowSizeChange ts window)
-        SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowMinimize (SDL.eventTimestamp e) window)
+          SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowMinimize ts window)
-        SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowMaximize (SDL.eventTimestamp e) window)
+          SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowMaximize ts window)
-        SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowRestore (SDL.eventTimestamp e) window)
+          SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowRestore ts window)
-        SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowGainMouseFocus (SDL.eventTimestamp e) window)
+          SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowGainMouseFocus ts window)
-        SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowLoseMouseFocus (SDL.eventTimestamp e) window)
+          SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowLoseMouseFocus ts window)
-        SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowGainKeyboardFocus (SDL.eventTimestamp e) window)
+          SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowGainKeyboardFocus ts window)
-        SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowLoseKeyboardFocus (SDL.eventTimestamp e) window)
+          SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowLoseKeyboardFocus ts window)
-        SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
+            doConsume es
-          partEmit aw (MsgWindowClose (SDL.eventTimestamp e) window)
+          SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
-          doConsume es
+            partEmit aw (MsgWindowClose ts window)
-        _ -> fmap (e :) (doConsume es)
+            doConsume es
+          _ -> fmap (e :) (doConsume es)

src/Affection/Subsystems/Class.hs

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

src/Affection/Types.hs

@@ -64,16 +64,16 @@ data AffectionConfig us = AffectionConfig
       -- ^ size of the texture canvas
   , initScreenMode :: SDL.WindowMode
       -- ^ Window mode to start in
+  , loadState      :: IO us
+      -- ^ Provide your own load function to create this data.
   , preLoop        :: Affection us ()
       -- ^ Actions to be performed, before loop starts
-  , eventLoop      :: SDL.EventPayload -> Affection us ()
+  , eventLoop      :: [SDL.EventPayload] -> Affection us ()
       -- ^ Main update function. Takes fractions of a second as input.
   , updateLoop     :: Double -> Affection us ()
       -- ^ Main update function. Takes fractions of a second as input.
   , drawLoop       :: Affection us ()
       -- ^ Function for updating graphics.
-  , loadState      :: IO us
-      -- ^ Provide your own load function to create this data.
   , cleanUp        :: us -> IO ()
       -- ^ Provide your own finisher function to clean your data.
   }