blabla
This commit is contained in:
parent
78f058db6b
commit
3199d03401
3 changed files with 20 additions and 19 deletions
|
@ -1,6 +1,6 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
module Affection.MessageBus.Class
|
||||
( Participant(..)
|
||||
, genUUID
|
||||
|
@ -21,30 +21,30 @@ 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
|
||||
-> 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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue