diff --git a/affection.cabal b/affection.cabal index 5f4a95e..74f1fb7 100644 --- a/affection.cabal +++ b/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 diff --git a/src/Affection/MessageBus.hs b/src/Affection/MessageBus.hs index ea372ec..28d1bfa 100644 --- a/src/Affection/MessageBus.hs +++ b/src/Affection/MessageBus.hs @@ -1,4 +1,4 @@ -module Affection.Messagebus +module Affection.MessageBus ( module M ) where diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 880abac..1c0a526 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/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 () diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index 8b108ee..bedf10c 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/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 - , msgWhen :: UTCTime + { msgUMWhen :: Word32 + , 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 diff --git a/src/Affection/MessageBus/Util.hs b/src/Affection/MessageBus/Util.hs index ed7c551..501e9ab 100644 --- a/src/Affection/MessageBus/Util.hs +++ b/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