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

blabla

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -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
@ -21,30 +21,30 @@ 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

14
src/Affection/Subsystems/AffectionKeyboard.hs
View file

@ -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

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

@ -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