Merge pull request #6 from nek0/messages

Messages

.gitignore

@@ -10,3 +10,4 @@ dist/
 *.aux
 *.hp
 *.ps
+*.swp

affection.cabal

@@ -30,25 +30,51 @@ source-repository head
   type:     git
   location: https://github.com/nek0/affection
 
+flag debug
+  description:       Enable debug messages
+  default:           False
+  manual:            True
+
+flag warn
+  description:       Enable warning messages
+  default:           False
+  manual:            True
+
+flag error
+  description:       Enable error messages
+  default:           False
+  manual:            True
+
 flag examples
   description:       Build example programs
   default:           False
 
 library
+  if flag(debug)
+    cpp-options:       -DDEBUG
+  if flag(warn)
+    cpp-options:       -DWARN
+  if flag(error)
+    cpp-options:       -DERROR
   exposed-modules:     Affection
-                     -- , Affection.Draw
+                     , Affection.Logging
-                     -- , Affection.Particle
                      , Affection.Types
                      , Affection.StateMachine
                      , Affection.MouseInteractable
-                     -- , Affection.Property
-                     -- , Affection.Actor
-                     -- , Affection.Animation
                      , Affection.Util
+                     , Affection.MessageBus
                      , Affection.MessageBus.Util
                      , Affection.MessageBus.Class
-                     , Affection.MessageBus.Engine
                      , Affection.MessageBus.Message
+                     , Affection.MessageBus.Message.Class
+                     , Affection.MessageBus.Message.WindowMessage
+                     , Affection.MessageBus.Message.KeyboardMessage
+                     , Affection.MessageBus.Message.MouseMessage
+                     , Affection.Subsystems
+                     , Affection.Subsystems.Class
+                     , Affection.Subsystems.AffectionWindow
+                     , Affection.Subsystems.AffectionKeyboard
+                     , Affection.Subsystems.AffectionMouse
   default-extensions:  OverloadedStrings
 
   -- Modules included in this library but not exported.
@@ -66,11 +92,9 @@ library
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.9
                      , sdl2
+                     , linear
                      , text
                      , mtl
-                     , time
-                     -- , gegl
-                     -- , babl
                      , monad-loops
                      , monad-parallel
                      , containers
@@ -79,25 +103,28 @@ library
                      , bytestring
                      , OpenGL
                      , stm
-                     -- , sdl2-image
+                     , uuid
+
+executable example00
+  if flag(debug)
+    cpp-options:       -DDEBUG
+  if flag(warn)
+    cpp-options:       -DWARN
+  if flag(error)
+    cpp-options:       -DERROR
+  hs-source-dirs:    examples
+  main-is:           example00.hs
+  ghc-options:       -threaded -Wall
+  default-language:  Haskell2010
+  default-extensions: OverloadedStrings
+  if flag(examples)
+    build-depends:     base
+                     , affection
+                     , sdl2
+                     , stm
+  else
+    buildable:       False
 
--- executable example00
---   hs-source-dirs:    examples
---   main-is:           example00.hs
---   ghc-options:       -threaded -Wall
---   default-language:  Haskell2010
---   default-extensions: OverloadedStrings
---   if flag(examples)
---     build-depends:     base
---                      , affection
---                      , sdl2
---                      , gegl
---                      , babl
---                      , containers
---                      , mtl
---   else
---     buildable:       False
--- 
 -- executable example01
 --   hs-source-dirs:    examples
 --   main-is:           example01.hs
@@ -186,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,125 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 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 Control.Monad.IO.Class (liftIO)
 
-import Foreign.Storable (peek)
+newtype StateData = StateData
-import Foreign.C.Types  (CInt(..))
+  { sdSubs :: Subsystems
+  }
 
-import Debug.Trace
+data Subsystems = Subsystems
+  { subWindow :: Window
+  , subMouse :: Mouse
+  , subKeyboard :: Keyboard
+  }
 
--- main :: IO ()
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
--- main = withAllAffection $
+newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
---   withDefaultWindow "test" $ do
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
---     changeColor $ RGBA 255 255 255 255
+
---     clear
+instance Participant Window WindowMessage StateData where
---     present
+  partSubscribers (Window t) = do
---     liftIO $ delaySec 2
+    subTups <- liftIO $ readTVarIO t
+    return $ map snd subTups
+
+  partSubscribe (Window t) = generalSubscribe t
+
+  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) = generalSubscribe t
+
+  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) = generalSubscribe t
+
+  partUnSubscribe (Keyboard t) uuid =
+    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
+
+instance SDLSubsystem Keyboard StateData where
+  consumeSDLEvents = consumeSDLKeyboardEvents
+
+generalSubscribe t funct = do
+  uuid <- genUUID
+  liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+  return uuid
 
 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
+          { SDL.windowOpenGL = Just SDL.defaultOpenGL
-    , updateLoop     = update
+            { SDL.glProfile = SDL.Core SDL.Normal 3 3
-    , drawLoop       = draw
+            }
-    , loadState      = load
+          }
-    , cleanUp        = clean
+        , initScreenMode = SDL.Windowed
-    }
+        , canvasSize = Nothing
+        , loadState = load
+        , preLoop = pre
+        , 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
+    (Window empty1)
-        prop "color1" $ G.RGBA 0.4 0.4 0.4 1
+    (Mouse empty2)
-        prop "color2" $ G.RGBA 0.6 0.6 0.6 1
+    (Keyboard 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 -> do
+      liftIO $ logIO Debug "Yo dog I heard..."
+      quit
+    _ -> 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

@@ -3,24 +3,12 @@
 module Affection
     ( withAffection
     , get
-    , getAffection
-    , putAffection
-    -- , withWindow
-    -- , withDefaultWindow
-    , delaySec
-    , get
     , put
     , module A
     ) where
 
 import SDL (($=))
 import qualified SDL
-import qualified SDL.Internal.Numbered as SDL (toNumber)
-import qualified SDL.Raw as Raw
--- import qualified GEGL as G
-
-import Data.Maybe
-import Data.IORef
 
 import System.Clock
 
@@ -28,27 +16,20 @@ import Control.Monad.Loops
 import Control.Monad.State
 
 import Foreign.C.Types (CInt(..))
-import Foreign.Storable (peek)
 
 import Debug.Trace
 
 import Affection.Types as A
--- import Affection.Draw as A
--- import Affection.Particle as A
 import Affection.StateMachine as A
 import Affection.MouseInteractable as A
--- import Affection.Property as A
--- import Affection.Actor as A
--- import Affection.Animation as A
 import Affection.Util as A
-import Affection.MessageBus.Class as A
+import Affection.MessageBus as A
-import Affection.MessageBus.Message as A
+import Affection.Subsystems as A
-import Affection.MessageBus.Engine as A
+
-import Affection.MessageBus.Util as A
+import Affection.Logging as A
 
 import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
 
--- import qualified BABL as B
 
 -- | Main function which bootstraps everything else.
 withAffection
@@ -61,66 +42,34 @@ withAffection AffectionConfig{..} = do
       SDL.initializeAll
     Only is ->
       SDL.initialize is
-  -- G.gegl_init
   -- give SDL render quality
   SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
   -- just checking…
   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
-  context <- SDL.glCreateContext(window)
+  context <- SDL.glCreateContext window
-  -- -- create renderer
-  -- renderer <- SDL.createRenderer
-  --   window
-  --   (-1)
-  --   SDL.defaultRenderer
-  -- -- make draw texture
-  -- texture <- SDL.createTexture
-  --   renderer
-  --   SDL.ABGR8888
-  --   SDL.TextureAccessStreaming
-  --   (case canvasSize of
-  --     Just (cw, ch) -> (SDL.V2
-  --       (CInt $ fromIntegral cw)
-  --       (CInt $ fromIntegral ch)
-  --       )
-  --     Nothing ->
-  --       SDL.windowInitialSize windowConfig
-  --     )
-  -- -- make draw surface
-  -- -- pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr
   let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig
       (w, h) = case canvasSize of
         Just (cw, ch) -> (cw, ch)
         Nothing       -> (fromIntegral rw, fromIntegral rh)
-  --     -- stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w
-  --     bablFormat = B.PixelFormat B.RGBA B.CFu8
-  --     cpp        = B.babl_components_per_pixel bablFormat
-  --     !stride    = cpp * w
-  -- format <- B.babl_format bablFormat
-  -- get current time
   SDL.setWindowMode window initScreenMode
   SDL.swapInterval $= SDL.SynchronizedUpdates
+  -- get current time
   execTime <- getTime Monotonic
   initContainer <- (\x -> AffectionData
     { quitEvent       = False
     , userState       = x
     , drawWindow      = window
     , glContext       = context
-    -- , windowRenderer  = renderer
-    -- , drawTexture     = texture
-    -- , drawFormat      = format
     , drawDimensions  = case canvasSize of
         Just (cw, ch) -> (cw, ch)
         Nothing       -> (w, h)
     , screenMode      = initScreenMode
-    -- , drawStride      = stride
-    -- , drawCPP         = cpp
-    -- , drawStack       = []
     , elapsedTime     = 0
     , deltaTime       = 0
     , sysTime         = execTime
@@ -138,37 +87,28 @@ withAffection AffectionConfig{..} = do
         -- Measure time difference form last run
         now      <- liftIO $ getTime Monotonic
         let lastTime = sysTime ad
-        -- -- clean draw requests from last run
-        -- MP.mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad)
-        -- clean the renderer form last time
-        -- SDL.clear renderer
         -- compute dt and update elapsedTime
-        let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9)
+        let !dt = fromIntegral
+               (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
             !ne = elapsedTime ad + dt
         put $ ad
-          -- { drawStack = []
           { elapsedTime = ne
           , deltaTime = dt
           }
         -- 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
         liftIO $ GL.clear [ColorBuffer, DepthBuffer]
         drawLoop
-        liftIO $ flush
+        liftIO flush
         -- handle all new draw requests
         ad2 <- get
-        -- clear <- catMaybes <$>
-        --   mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2)
-        -- -- save all draw requests to clear in next run
-        -- put $ ad2
-        --   { drawStack = clear }
         -- actual drawing
         SDL.glSwapWindow window
-        -- SDL.present (windowRenderer ad2)
         -- save new time
         ad3 <- get
         when (sysTime ad == sysTime ad3) (
@@ -178,7 +118,6 @@ withAffection AffectionConfig{..} = do
           )
       )
     ) initContainer
-  -- G.gegl_exit
   cleanUp $ userState nState
   SDL.destroyWindow window
   SDL.quit

src/Affection/Actor.hs

@@ -48,7 +48,7 @@ updateProperties ps act@Actor{..} =
 
 applyProperties :: (Show a, Ord a) => Actor a -> Affection us ()
 applyProperties Actor{..} =
-  MP.mapM_ (\(ActorProperty{..}) ->
+  MP.mapM_ (\ActorProperty{..} ->
     maybe (return ()) (\m ->
       liftIO $ G.gegl_node_set (actorNodes M.! fst m) $ G.Operation "" $
         (G.Property (snd m) apValue) : []

src/Affection/Logging.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE CPP #-}
+module Affection.Logging where
+
+import Debug.Trace
+
+data LogLevel
+  = Debug
+  | Warn
+  | Error
+
+log :: LogLevel -> String -> a -> a
+#if defined(DEBUG)
+log Debug s = trace ("DEBUG: " ++ s)
+#endif
+#if defined(WARN) || defined(DEBUG)
+log Warn s = trace ("WARN: " ++ s)
+#endif
+#if defined(ERROR) || defined(WARN) || defined(DEBUG)
+log Error s = trace ("ERROR: " ++ s)
+#endif
+log _ _ = id
+
+logIO :: LogLevel -> String -> IO ()
+#if defined(DEBUG)
+logIO Debug s = traceIO ("DEBUG: " ++ s)
+#endif
+#if defined(WARN) || defined(DEBUG)
+logIO Warn s = traceIO ("WARN: " ++ s)
+#endif
+#if defined(ERROR) || defined(WARN) || defined(DEBUG)
+logIO Error s = traceIO ("ERROR: " ++ s)
+#endif
+logIO _ _ = return ()

src/Affection/MessageBus.hs

@@ -0,0 +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,19 +1,61 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
-module Affection.MessageBus.Class where
+{-# LANGUAGE TypeFamilies #-}
-
+{-# LANGUAGE AllowAmbiguousTypes #-}
-import Control.Concurrent.STM as STM
+module Affection.MessageBus.Class 
-
+  ( Participant(..)
-import Data.IORef
+  , genUUID
+  , UUID
+  ) where
 
 import Affection.MessageBus.Message
+import Affection.Types
 
-newtype (Message msg) => Channel msg = Channel (TChan msg)
+import Control.Monad.IO.Class (liftIO)
 
-class (Message msg) => Participant prt msg where
+import Data.UUID
-  partChannel        :: prt -> IORef (Channel msg)
+import Data.UUID.V4
 
-  partConnectChannel :: prt -> Channel msg -> IO ()
+import Affection.Logging
 
-  partListen         :: prt -> IO msg
+class (Show m, Message m) => Participant prt m us where
 
-  partBroadcast      :: prt -> msg -> IO ()
+  -- | Function to get the list of subscribers from the participant
+  partSubscribers
+    :: 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''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
+
+  -- | Unsubscribe a Subscriber function from Participant
+  partUnSubscribe
+    :: 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''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/MessageBus/Engine.hs

@@ -1,3 +0,0 @@
-module Affection.MessageBus.Engine where
-
-import Affection.MessageBus.Class

src/Affection/MessageBus/Message.hs

@@ -1,18 +1,8 @@
-{-# LANGUAGE RankNTypes #-}
+module Affection.MessageBus.Message
-module Affection.MessageBus.Message where
+  ( module M
+  ) where
 
-import Data.Time.Clock (UTCTime(..))
+import Affection.MessageBus.Message.Class as M
-
+import Affection.MessageBus.Message.WindowMessage as M
-class Message msg where
+import Affection.MessageBus.Message.KeyboardMessage as M
-  msgTime :: msg -> UTCTime
+import Affection.MessageBus.Message.MouseMessage as M
-
-data EngineMessage m
-  = MsgUserMessage
-    { msgPayload :: m
-    , msgWhen :: UTCTime
-    }  -- ^ Generic user defined message with custom payload
-  | MsgEngineReady UTCTime
-
-instance Message (EngineMessage m) where
-  msgTime (MsgUserMessage _ t) = t
-  msgTime (MsgEngineReady t)   = t

src/Affection/MessageBus/Message/Class.hs

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

src/Affection/MessageBus/Message/KeyboardMessage.hs

@@ -0,0 +1,16 @@
+module Affection.MessageBus.Message.KeyboardMessage where
+
+import Affection.MessageBus.Message.Class
+
+import qualified SDL
+
+data KeyboardMessage = MsgKeyboardEvent
+  { msgKbdWhen :: Double
+  , msgKbdWindow :: Maybe SDL.Window
+  , msgKbdKeyMotion :: SDL.InputMotion
+  , msgKbdKeyRepeat :: Bool
+  , msgKbdKeysym :: SDL.Keysym
+  } deriving (Show)
+
+instance Message KeyboardMessage where
+  msgTime (MsgKeyboardEvent t _ _ _ _) = t

src/Affection/MessageBus/Message/MouseMessage.hs

@@ -0,0 +1,41 @@
+module Affection.MessageBus.Message.MouseMessage where
+
+import Affection.MessageBus.Message.Class
+
+import Data.Word (Word8(..))
+import Data.Int (Int32(..))
+
+import qualified SDL
+
+import Linear (V2(..))
+
+data MouseMessage
+  = MsgMouseMotion
+    { msgMMWhen :: Double
+    , msgMMWindow :: Maybe SDL.Window
+    , msgMMWhich :: SDL.MouseDevice
+    , msgMMState :: [SDL.MouseButton]
+    , msgMMPos :: V2 Int32
+    , msgMMRelMotion :: V2 Int32
+    }
+  | MsgMouseButton
+    { msgMBWhen :: Double
+    , msgMBWindow :: Maybe SDL.Window
+    , msgMBWhich :: SDL.MouseDevice
+    , msgMBButton :: SDL.MouseButton
+    , msgMBClicks :: Word8
+    , msgMBPos :: V2 Int32
+    }
+  | MsgMouseWheel
+    { msgMWWhen :: Double
+    , msgMWWhindow :: Maybe SDL.Window
+    , msgMWWhich :: SDL.MouseDevice
+    , msgMWPos :: V2 Int32
+    , msgMWDIrection :: SDL.MouseScrollDirection
+    }
+  deriving (Show)
+
+instance Message MouseMessage where
+  msgTime (MsgMouseMotion t _ _ _ _ _) = t
+  msgTime (MsgMouseButton t _ _ _ _ _) = t
+  msgTime (MsgMouseWheel t _ _ _ _) = t

src/Affection/MessageBus/Message/WindowMessage.hs

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

src/Affection/MessageBus/Util.hs

@@ -1,8 +1,3 @@
 module Affection.MessageBus.Util where
 
-import Affection.MessageBus.Class
+-- zuru zuru
-import Affection.MessageBus.Message
-import Control.Concurrent.STM as STM
-
-newBroadcastChannel :: (Message msg) => IO (Channel msg)
-newBroadcastChannel = atomically $ Channel <$> newBroadcastTChan

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

@@ -0,0 +1,35 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Affection.Subsystems.AffectionKeyboard where
+
+import Affection.Types
+import Affection.Util
+import Affection.MessageBus
+import Affection.Subsystems.Class
+
+import Control.Concurrent.STM as STM
+import Control.Monad.IO.Class (liftIO)
+
+import qualified SDL
+
+consumeSDLKeyboardEvents
+  :: (Participant ak KeyboardMessage us)
+  => ak
+  -> [SDL.EventPayload]
+  -> Affection us [SDL.EventPayload]
+consumeSDLKeyboardEvents ak = doConsume
+  where
+    doConsume [] = return []
+    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

@@ -0,0 +1,57 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+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
+
+import Linear.Affine (unP)
+
+import qualified SDL
+
+consumeSDLMouseEvents
+  :: (Participant am MouseMessage us)
+  => am
+  -> [SDL.EventPayload]
+  -> Affection us [SDL.EventPayload]
+consumeSDLMouseEvents am = doConsume
+  where
+    doConsume [] = return []
+    doConsume (e:es) = do
+      ts <- getElapsedTime
+      case e of
+        SDL.MouseMotionEvent dat -> do
+          partEmit am (MsgMouseMotion
+            ts
+            (SDL.mouseMotionEventWindow dat)
+            (SDL.mouseMotionEventWhich dat)
+            (SDL.mouseMotionEventState dat)
+            (unP $ SDL.mouseMotionEventPos dat)
+            (SDL.mouseMotionEventRelMotion dat)
+            )
+          doConsume es
+        SDL.MouseButtonEvent dat -> do
+          partEmit am (MsgMouseButton
+            ts
+            (SDL.mouseButtonEventWindow dat)
+            (SDL.mouseButtonEventWhich dat)
+            (SDL.mouseButtonEventButton dat)
+            (SDL.mouseButtonEventClicks dat)
+            (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

@@ -0,0 +1,69 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Affection.Subsystems.AffectionWindow where
+
+import Affection.Types
+import Affection.Util
+import Affection.MessageBus
+import Affection.Subsystems.Class
+
+import Control.Concurrent.STM as STM
+import Control.Monad.IO.Class (liftIO)
+
+import qualified SDL
+
+consumeSDLWindowEvents
+  :: (Participant aw WindowMessage us)
+  => aw
+  -> [SDL.EventPayload]
+  -> Affection us [SDL.EventPayload]
+consumeSDLWindowEvents aw = doConsume
+  where
+    doConsume [] = return []
+    doConsume (e:es) = do
+      ts <- getElapsedTime
+      case e of
+        SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
+          partEmit aw (MsgWindowShow ts window)
+          doConsume es
+        SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
+          partEmit aw (MsgWindowHide ts window)
+          doConsume es
+        SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
+          partEmit aw (MsgWindowExpose ts window)
+          doConsume es
+        SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
+          partEmit aw (MsgWindowMove ts window newPos)
+          doConsume es
+        SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
+          partEmit aw (MsgWindowResize ts window newSize)
+          doConsume es
+        SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
+          partEmit aw (MsgWindowSizeChange ts window)
+          doConsume es
+        SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
+          partEmit aw (MsgWindowMinimize ts window)
+          doConsume es
+        SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
+          partEmit aw (MsgWindowMaximize ts window)
+          doConsume es
+        SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
+          partEmit aw (MsgWindowRestore ts window)
+          doConsume es
+        SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
+          partEmit aw (MsgWindowGainMouseFocus ts window)
+          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

@@ -0,0 +1,11 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Affection.Subsystems.Class where
+
+import Affection.Types
+import Affection.MessageBus
+
+import qualified SDL
+
+class SDLSubsystem s us where
+  consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]

src/Affection/Types.hs

@@ -50,6 +50,8 @@ import System.Clock (TimeSpec)
 
 import Foreign.Ptr (Ptr)
 
+import Affection.MessageBus.Message
+
 -- | Configuration for the aplication. needed at startup.
 data AffectionConfig us = AffectionConfig
   { initComponents :: InitComponents
@@ -62,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.
   }
@@ -100,6 +102,7 @@ data AffectionData us = AffectionData
   , deltaTime       :: Double             -- ^ Elapsed time in seconds since last tick
   , sysTime         :: TimeSpec           -- ^ System time (NOT the time on the clock)
   , pausedTime      :: Bool               -- ^ Should the update loop be executed?
+  -- , messageChannel  :: Channel msg        -- ^ The main broadcast channel to duplicate all others from
   }
 
 -- -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated
@@ -118,7 +121,7 @@ data AffectionData us = AffectionData
 
 -- | Inner 'StateT' monad for the update state
 -- type AffectionStateInner us m a = StateT (AffectionData us) m a
-type AffectionStateInner us m a = StateT us m a
+type AffectionStateInner us a = StateT us a
 
 -- | Affection's state monad
 newtype AffectionState us m a = AffectionState