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 MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE Rank2Types #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
module Affection.MessageBus.Class
|
module Affection.MessageBus.Class
|
||||||
( Participant(..)
|
( Participant(..)
|
||||||
, genUUID
|
, genUUID
|
||||||
|
@ -20,31 +20,31 @@ import Affection.Logging
|
||||||
class (Show m, Message m) => Participant prt m where
|
class (Show m, Message m) => Participant prt m where
|
||||||
-- | Function to get the lsit of subscribers from the participant
|
-- | Function to get the lsit of subscribers from the participant
|
||||||
partSubscribers
|
partSubscribers
|
||||||
:: prt -- ^ the participant
|
:: 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
|
-- | Subscribe to the 'Participant''s events
|
||||||
partSubscribe
|
partSubscribe
|
||||||
:: prt -- ^ The 'Participant' to subscribe to
|
:: 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)
|
-- (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
|
-- | Unsubscribe a Subscriber function from Participant
|
||||||
partUnSubscribe
|
partUnSubscribe
|
||||||
:: prt -- ^ The 'Participant' to unsubscribe from
|
:: prt -- ^ The 'Participant' to unsubscribe from
|
||||||
-> UUID -- ^ The subscriber function's 'UUID'
|
-> UUID -- ^ The subscriber function's 'UUID'
|
||||||
-> Affection sd ()
|
-> Affection us ()
|
||||||
|
|
||||||
-- | Get the 'Participant' to emit a 'Message' on all of its subscribers
|
-- | Get the 'Participant' to emit a 'Message' on all of its subscribers
|
||||||
partEmit
|
partEmit
|
||||||
:: prt -- ^ The 'Participant'
|
:: prt -- ^ The 'Participant'
|
||||||
-> m -- ^ The 'Message' to emit
|
-> m -- ^ The 'Message' to emit
|
||||||
-> Affection sd ()
|
-> Affection us ()
|
||||||
partEmit p m = do
|
partEmit p m = do
|
||||||
liftIO $ logIO Debug $ "Emitting message: " ++ show m
|
liftIO $ logIO Debug $ "Emitting message: " ++ show m
|
||||||
l <- partSubscribers p
|
l <- partSubscribers p
|
||||||
mapM_ ($ m) l
|
mapM_ ($ m) l
|
||||||
|
|
||||||
genUUID :: Affection sd UUID
|
genUUID :: Affection us UUID
|
||||||
genUUID = liftIO $ nextRandom
|
genUUID = liftIO $ nextRandom
|
||||||
|
|
|
@ -2,21 +2,21 @@
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
module Affection.Subsystems.AffectionKeyboard where
|
module Affection.Subsystems.AffectionKeyboard where
|
||||||
|
|
||||||
import Affection.MessageBus
|
|
||||||
import Affection.Subsystems.Class
|
|
||||||
import Affection.Types
|
import Affection.Types
|
||||||
import Affection.Util
|
import Affection.Util
|
||||||
|
import Affection.MessageBus
|
||||||
|
import Affection.Subsystems.Class
|
||||||
|
|
||||||
import Control.Monad.IO.Class (liftIO)
|
|
||||||
import Control.Concurrent.STM as STM
|
import Control.Concurrent.STM as STM
|
||||||
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
|
|
||||||
data AffectionKeyboard sd = AffectionKeyboard
|
data AffectionKeyboard us = AffectionKeyboard
|
||||||
{ keyboardSubscribers :: forall sd. TVar [(UUID, KeyboardMessage -> Affection sd ())]
|
{ keyboardSubscribers :: forall us. TVar [(UUID, KeyboardMessage -> Affection us ())]
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Participant (AffectionKeyboard sd) KeyboardMessage where
|
instance Participant (AffectionKeyboard us) KeyboardMessage where
|
||||||
partSubscribe p funct = do
|
partSubscribe p funct = do
|
||||||
uuid <- genUUID
|
uuid <- genUUID
|
||||||
liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :)
|
liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :)
|
||||||
|
@ -30,7 +30,7 @@ instance Participant (AffectionKeyboard sd) KeyboardMessage where
|
||||||
subTups <- liftIO $ readTVarIO $ keyboardSubscribers p
|
subTups <- liftIO $ readTVarIO $ keyboardSubscribers p
|
||||||
return $ map snd subTups
|
return $ map snd subTups
|
||||||
|
|
||||||
instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where
|
instance SDLSubsystem (AffectionKeyboard us) KeyboardMessage where
|
||||||
consumeSDLEvents ak eps = doConsume eps
|
consumeSDLEvents ak eps = doConsume eps
|
||||||
where
|
where
|
||||||
doConsume (e:es) = do
|
doConsume (e:es) = do
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
module Affection.Subsystems.AffectionWindow where
|
module Affection.Subsystems.AffectionWindow where
|
||||||
|
|
||||||
import Affection.Types
|
import Affection.Types
|
||||||
|
@ -12,11 +13,11 @@ import Control.Monad.IO.Class (liftIO)
|
||||||
|
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
|
|
||||||
data AffectionWindow sd = AffectionWindow
|
data AffectionWindow us = AffectionWindow
|
||||||
{ windowSubscribers :: forall sd. TVar [(UUID, WindowMessage -> Affection sd ())]
|
{ windowSubscribers :: forall us. TVar [(UUID, WindowMessage -> Affection us ())]
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Participant (AffectionWindow sd) WindowMessage where
|
instance Participant (AffectionWindow us) WindowMessage where
|
||||||
partSubscribe p funct = do
|
partSubscribe p funct = do
|
||||||
uuid <- genUUID
|
uuid <- genUUID
|
||||||
liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :)
|
liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :)
|
||||||
|
@ -30,7 +31,7 @@ instance Participant (AffectionWindow sd) WindowMessage where
|
||||||
subTups <- liftIO $ readTVarIO $ windowSubscribers p
|
subTups <- liftIO $ readTVarIO $ windowSubscribers p
|
||||||
return $ map snd subTups
|
return $ map snd subTups
|
||||||
|
|
||||||
instance SDLSubsystem (AffectionWindow sd) WindowMessage where
|
instance SDLSubsystem (AffectionWindow us) WindowMessage where
|
||||||
consumeSDLEvents aw eps = doConsume eps
|
consumeSDLEvents aw eps = doConsume eps
|
||||||
where
|
where
|
||||||
doConsume (e:es) = do
|
doConsume (e:es) = do
|
||||||
|
|
Loading…
Reference in a new issue