nek0/affection
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

it compiles now. messagebus will have multiple channels

Browse source
This commit is contained in:
nek0 2017-11-29 08:29:44 +01:00
parent 4ae117aa48
commit c40cd04d99
3 changed files with 22 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
src/Affection/MessageBus/Class.hs
View file

@ -5,11 +5,11 @@ module Affection.MessageBus.Class where
import Affection.MessageBus.Message import Affection.MessageBus.Message
import Affection.Types import Affection.Types
class (Message msg) => Participant prt msg where class Participant prt m where
partChannel :: prt -> Channel msg partChannel :: prt -> Channel m
partInit :: Affection sd msg prt partInit :: Affection sd m prt
partListen :: prt -> IO (Maybe msg) partListen :: prt -> IO (Maybe m)
partEmit :: prt -> msg -> IO () partEmit :: prt -> m -> IO ()

16
src/Affection/MessageBus/Message.hs
View file

@ -11,12 +11,12 @@ import Linear (V2(..))
class Message msg where class Message msg where
msgTime :: msg -> Word32 msgTime :: msg -> Word32
data SystemMessage m data SystemMessage
= MsgUserMessage -- = MsgUserMessage
{ msgUMWhen :: Word32 -- { msgUMWhen :: Word32
, msgUMPayload :: m -- , msgUMPayload :: m
} -- ^ Generic user defined message with custom payload -- } -- ^ Generic user defined message with custom payload
| MsgEngineReady Word32 = MsgEngineReady Word32
| MsgWindowShown | MsgWindowShown
{ msgWSWhen :: Word32 { msgWSWhen :: Word32
, msgWSWindow :: SDL.Window , msgWSWindow :: SDL.Window
@ -76,8 +76,8 @@ data SystemMessage m
, msgWCWindow :: SDL.Window , msgWCWindow :: SDL.Window
} }
instance Message (SystemMessage m) where instance Message SystemMessage where
msgTime (MsgUserMessage t _) = t -- msgTime (MsgUserMessage t _) = t
msgTime (MsgEngineReady t) = t msgTime (MsgEngineReady t) = t
msgTime (MsgWindowShown t _) = t msgTime (MsgWindowShown t _) = t
msgTime (MsgWindowHidden t _) = t msgTime (MsgWindowHidden t _) = t

18
src/Affection/Subsystems/AffectionWindow.hs
View file

@ -7,21 +7,21 @@ import Affection.MessageBus
import Affection.Subsystems.Class import Affection.Subsystems.Class
import Affection.Types import Affection.Types
import Control.Monad.State.Class (get) import Control.Monad.State.Class (gets)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import qualified SDL import qualified SDL
data AffectionWindow msg = AffectionWindow data AffectionWindow m = AffectionWindow
{ windowChannel :: Channel msg { windowChannel :: Channel m
} }
instance Participant (AffectionWindow (SystemMessage m)) (SystemMessage m) where instance (Message m) => Participant (AffectionWindow m) m where
partChannel = windowChannel partChannel = windowChannel
partInit = do partInit = do
ad <- get chan <- gets messageChannel :: Affection sd m (Channel m)
nchan <- liftIO $ dupChannel $ messageChannel ad nchan <- liftIO $ dupChannel $ chan
return $ AffectionWindow return $ AffectionWindow
{ windowChannel = nchan { windowChannel = nchan
} }
@ -31,11 +31,11 @@ instance Participant (AffectionWindow (SystemMessage m)) (SystemMessage m) where
mmsg <- tryPeekChannel chan mmsg <- tryPeekChannel chan
return mmsg return mmsg
partEmit p m = do partEmit p message = do
let chan = partChannel p let chan = partChannel p
writeChannel chan m writeChannel chan message
instance Subsystem (AffectionWindow (SystemMessage m)) (SystemMessage m) where instance Subsystem (AffectionWindow SystemMessage) SystemMessage where
consumeEvents aw evs = doConsume evs consumeEvents aw evs = doConsume evs
where where
doConsume (e:es) = case SDL.eventPayload e of doConsume (e:es) = case SDL.eventPayload e of