diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index a27bca3..aaac555 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -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 diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index dc62706..6f822d2 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -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 diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 9b432c8..1fe4775 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -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