more message foo

This commit is contained in:
nek0 2017-11-27 05:27:52 +01:00
parent d8d29ec7df
commit a5ca89f93c
5 changed files with 111 additions and 13 deletions

View file

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

View file

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

View file

@ -3,17 +3,15 @@ module Affection.MessageBus.Class where
import Control.Concurrent.STM as STM import Control.Concurrent.STM as STM
import Data.IORef
import Affection.MessageBus.Message import Affection.MessageBus.Message
newtype (Message msg) => Channel msg = Channel (TChan msg) newtype (Message msg) => Channel msg = Channel (TChan msg)
class (Message msg) => Participant prt msg where 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 () partEmit :: prt -> msg -> IO ()

View file

@ -1,18 +1,95 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
module Affection.MessageBus.Message where 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 class Message msg where
msgTime :: msg -> UTCTime msgTime :: msg -> Word32
data SystemMessage m data SystemMessage m
= MsgUserMessage = MsgUserMessage
{ msgPayload :: m { msgUMWhen :: Word32
, msgWhen :: UTCTime , msgUMPayload :: m
} -- ^ Generic user defined message with custom payload } -- ^ 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 instance Message (SystemMessage m) where
msgTime (MsgUserMessage _ t) = t msgTime (MsgUserMessage t _) = t
msgTime (MsgEngineReady 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

View file

@ -4,5 +4,27 @@ import Affection.MessageBus.Class
import Affection.MessageBus.Message import Affection.MessageBus.Message
import Control.Concurrent.STM as STM import Control.Concurrent.STM as STM
-- | Build a new broadcast channel
newBroadcastChannel :: (Message msg) => IO (Channel msg) newBroadcastChannel :: (Message msg) => IO (Channel msg)
newBroadcastChannel = atomically $ Channel <$> newBroadcastTChan 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