more message foo

affection.cabal

@@ -40,6 +40,7 @@ library
                      , Affection.StateMachine
                      , Affection.MouseInteractable
                      , Affection.Util
+                     , Affection.MessageBus
                      , Affection.MessageBus.Util
                      , Affection.MessageBus.Class
                      , Affection.MessageBus.Message
@@ -60,9 +61,9 @@ library
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.9
                      , sdl2
+                     , linear
                      , text
                      , mtl
-                     , time
                      , monad-loops
                      , monad-parallel
                      , containers

src/Affection/MessageBus.hs

@@ -1,4 +1,4 @@
-module Affection.Messagebus
+module Affection.MessageBus
   ( module M
   ) where
 

src/Affection/MessageBus/Class.hs

@@ -3,17 +3,15 @@ module Affection.MessageBus.Class where
 
 import Control.Concurrent.STM as STM
 
-import Data.IORef
-
 import Affection.MessageBus.Message
 
 newtype (Message msg) => Channel msg = Channel (TChan msg)
 
 class (Message msg) => Participant prt msg where
-  partChannel        :: prt -> IORef (Channel msg)
+  partChannel        :: prt -> Channel msg
 
-  partConnectChannel :: prt -> Channel msg -> IO ()
+  -- partConnectChannel :: prt -> Channel msg -> IO ()
 
-  partListen         :: prt -> IO msg
+  partListen         :: prt -> IO (Maybe msg)
 
   partEmit           :: prt -> msg -> IO ()

src/Affection/MessageBus/Message.hs

@@ -1,18 +1,95 @@
 {-# LANGUAGE RankNTypes #-}
 module Affection.MessageBus.Message where
 
-import Data.Time.Clock (UTCTime(..))
+import Data.Word (Word32(..))
+import Data.Int (Int32(..))
+
+import qualified SDL
+
+import Linear (V2(..))
 
 class Message msg where
-  msgTime :: msg -> UTCTime
+  msgTime :: msg -> Word32
 
 data SystemMessage m
   = MsgUserMessage
-    { msgPayload :: m
+    { msgUMWhen :: Word32
-    , msgWhen :: UTCTime
+    , msgUMPayload :: m
     }  -- ^ Generic user defined message with custom payload
-  | MsgEngineReady UTCTime
+  | MsgEngineReady Word32
+  | MsgWindowShown
+    { msgWSWhen :: Word32
+    , msgWSWindow :: SDL.Window
+    }
+  | MsgWindowHidden
+    { msgWHWhen :: Word32
+    , msgWHWindow :: SDL.Window
+    }
+  | MsgWindowExposed
+    { msgWEWhen :: Word32
+    , msgWEWindow :: SDL.Window
+    }
+  | MsgWindowMoved
+    { msgWMWhen :: Word32
+    , msgWMWindow :: SDL.Window
+    , msgWMNewPos :: V2 Int32
+    }
+  | MsgWindowResized
+    { msgWRWhen :: Word32
+    , msgWRWindow :: SDL.Window
+    , msgWRNewSize :: V2 Int32
+    }
+  | MsgWindowSizeChanged
+    { msgWSCWhen :: Word32
+    , msgWSCWindow :: SDL.Window
+    }
+  | MsgWindowMinimized
+    { msgWMinWhen :: Word32
+    , msgWMinWindow :: SDL.Window
+    }
+  | MsgWindowMaximized
+    { msgWMaxWhen :: Word32
+    , msgWMaxWindow :: SDL.Window
+    }
+  | MsgWindowRestored
+    { msgWRestWhen :: Word32
+    , msgWRestWindow :: SDL.Window
+    }
+  | MsgWindowGainedMouseFocus
+    { msgWGMFWhen :: Word32
+    , msgWGMFWindow :: SDL.Window
+    }
+  | MsgWindowLostMouseFocus
+    { msgWLMFWhen :: Word32
+    , msgWLMFWindow :: SDL.Window
+    }
+  | MsgWindowGainedKeyboardFocus
+    { msgWGKFWhen :: Word32
+    , msgWGKFWindow :: SDL.Window
+    }
+  | MsgWindowLostKeyboardFocus
+    { msgWLKFWhen :: Word32
+    , msgWLKFWindow :: SDL.Window
+    }
+  | MsgWindowClosed
+    { msgWCWhen :: Word32
+    , msgWCWindow :: SDL.Window
+    }
 
 instance Message (SystemMessage m) where
-  msgTime (MsgUserMessage _ t) = t
+  msgTime (MsgUserMessage t _) = t
   msgTime (MsgEngineReady t)   = t
+  msgTime (MsgWindowShown t _) = t
+  msgTime (MsgWindowHidden t _) = t
+  msgTime (MsgWindowExposed t _) = t
+  msgTime (MsgWindowMoved t _ _) = t
+  msgTime (MsgWindowResized t _ _) = t
+  msgTime (MsgWindowSizeChanged t _) = t
+  msgTime (MsgWindowMinimized t _) = t
+  msgTime (MsgWindowMaximized t _) = t
+  msgTime (MsgWindowRestored t _) = t
+  msgTime (MsgWindowGainedMouseFocus t _) = t
+  msgTime (MsgWindowLostMouseFocus t _) = t
+  msgTime (MsgWindowGainedKeyboardFocus t _) = t
+  msgTime (MsgWindowLostKeyboardFocus t _) = t
+  msgTime (MsgWindowClosed t _) = t

src/Affection/MessageBus/Util.hs

@@ -4,5 +4,27 @@ import Affection.MessageBus.Class
 import Affection.MessageBus.Message
 import Control.Concurrent.STM as STM
 
+-- | Build a new broadcast channel
 newBroadcastChannel :: (Message msg) => IO (Channel msg)
 newBroadcastChannel = atomically $ Channel <$> newBroadcastTChan
+
+-- | Duplicate a broadcast channel, so it can be accessed by subsystems
+dupChannel :: (Message msg)
+  => Channel msg      -- ^ Original 'Channel'
+  -> IO (Channel msg) -- ^ 'Channel' duplicate
+dupChannel (Channel c) = atomically $ Channel <$> dupTChan c
+
+-- | Try to read a 'Channel' wihtout deleting the message. Returns 'Nothing' on
+-- an empty 'Channel'
+tryPeekChannel :: (Message msg)
+  => Channel msg    -- ^ Channel to read from
+  -> IO (Maybe msg) -- ^ Resulting message (or not)
+tryPeekChannel (Channel c) = atomically $ tryPeekTChan c
+
+-- | Write a message to a 'Channel' and thus broadcast it to all connected
+-- subsystems
+writeChannel :: (Message msg)
+  => Channel msg -- ^ 'Channel' to write to
+  -> msg         -- ^ The Message to emit
+  -> IO ()
+writeChannel (Channel c) m = atomically $ writeTChan c m