This commit is contained in:
nek0 2017-12-13 15:53:51 +01:00
parent 78f058db6b
commit 3199d03401
3 changed files with 20 additions and 19 deletions

View file

@ -1,6 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RankNTypes #-}
module Affection.MessageBus.Class
( Participant(..)
, genUUID
@ -20,31 +20,31 @@ import Affection.Logging
class (Show m, Message m) => Participant prt m where
-- | Function to get the lsit of subscribers from the participant
partSubscribers
:: prt -- ^ the participant
-> Affection sd [(m -> Affection sd ())] -- ^ List of Subscriber functions
:: prt -- ^ the participant
-> forall us. Affection us [(m -> Affection us ())] -- ^ List of Subscriber functions
-- | Subscribe to the 'Participant''s events
partSubscribe
:: prt -- ^ The 'Participant' to subscribe to
-> (m -> Affection sd ()) -- ^ What to do in case of a 'Message'
-> (forall us. m -> Affection us ()) -- ^ What to do in case of a 'Message'
-- (Subscriber function)
-> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function
-> Affection us UUID -- ^ 'UUID' of the registered subscriber Function
-- | Unsubscribe a Subscriber function from Participant
partUnSubscribe
:: prt -- ^ The 'Participant' to unsubscribe from
-> UUID -- ^ The subscriber function's 'UUID'
-> Affection sd ()
-> Affection us ()
-- | Get the 'Participant' to emit a 'Message' on all of its subscribers
partEmit
:: prt -- ^ The 'Participant'
-> m -- ^ The 'Message' to emit
-> Affection sd ()
-> Affection us ()
partEmit p m = do
liftIO $ logIO Debug $ "Emitting message: " ++ show m
l <- partSubscribers p
mapM_ ($ m) l
genUUID :: Affection sd UUID
genUUID :: Affection us UUID
genUUID = liftIO $ nextRandom

View file

@ -2,21 +2,21 @@
{-# LANGUAGE RankNTypes #-}
module Affection.Subsystems.AffectionKeyboard where
import Affection.MessageBus
import Affection.Subsystems.Class
import Affection.Types
import Affection.Util
import Affection.MessageBus
import Affection.Subsystems.Class
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM as STM
import Control.Monad.IO.Class (liftIO)
import qualified SDL
data AffectionKeyboard sd = AffectionKeyboard
{ keyboardSubscribers :: forall sd. TVar [(UUID, KeyboardMessage -> Affection sd ())]
data AffectionKeyboard us = AffectionKeyboard
{ keyboardSubscribers :: forall us. TVar [(UUID, KeyboardMessage -> Affection us ())]
}
instance Participant (AffectionKeyboard sd) KeyboardMessage where
instance Participant (AffectionKeyboard us) KeyboardMessage where
partSubscribe p funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :)
@ -30,7 +30,7 @@ instance Participant (AffectionKeyboard sd) KeyboardMessage where
subTups <- liftIO $ readTVarIO $ keyboardSubscribers p
return $ map snd subTups
instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where
instance SDLSubsystem (AffectionKeyboard us) KeyboardMessage where
consumeSDLEvents ak eps = doConsume eps
where
doConsume (e:es) = do

View file

@ -1,5 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
module Affection.Subsystems.AffectionWindow where
import Affection.Types
@ -12,11 +13,11 @@ import Control.Monad.IO.Class (liftIO)
import qualified SDL
data AffectionWindow sd = AffectionWindow
{ windowSubscribers :: forall sd. TVar [(UUID, WindowMessage -> Affection sd ())]
data AffectionWindow us = AffectionWindow
{ windowSubscribers :: forall us. TVar [(UUID, WindowMessage -> Affection us ())]
}
instance Participant (AffectionWindow sd) WindowMessage where
instance Participant (AffectionWindow us) WindowMessage where
partSubscribe p funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :)
@ -30,7 +31,7 @@ instance Participant (AffectionWindow sd) WindowMessage where
subTups <- liftIO $ readTVarIO $ windowSubscribers p
return $ map snd subTups
instance SDLSubsystem (AffectionWindow sd) WindowMessage where
instance SDLSubsystem (AffectionWindow us) WindowMessage where
consumeSDLEvents aw eps = doConsume eps
where
doConsume (e:es) = do