rebuilding participant system

This commit is contained in:
nek0 2017-12-20 02:00:48 +01:00
parent 13991556dc
commit ea90f8f9cd
4 changed files with 23 additions and 13 deletions

View file

@ -1,10 +1,13 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
module Affection.MessageBus.Class module Affection.MessageBus.Class
( Participant(..) ( Participant(..)
, genUUID , genUUID
, UUID , UUID
, MsgId(..)
) where ) where
import Affection.MessageBus.Message import Affection.MessageBus.Message
@ -17,30 +20,30 @@ import Data.UUID.V4
import Affection.Logging import Affection.Logging
class (Show m, Message m) => Participant prt m us where class (Message msg, Show msg) => Participant prt msg us where
-- | Function to get the list of subscribers from the participant -- | Function to get the list of subscribers from the participant
partSubscribers partSubscribers
:: prt :: prt
-- ^ the 'Participant''s subscriber storage -- ^ the 'Participant''s subscriber storage
-> Affection us [m -> Affection us ()] -> Affection us [msg -> Affection us ()]
-- ^ List of Subscriber functions -- ^ List of Subscriber functions
-- | Subscribe to the 'Participant''s events -- | Subscribe to the 'Participant''s events
partSubscribe partSubscribe
:: prt :: prt
-- ^ The 'Participant''s subscriber storage -- ^ The 'Participant''s subscriber storage
-> (m -> Affection us ()) -> (msg -> Affection us ())
-- ^ What to do in case of a 'Message' -- ^ What to do in case of a 'Message'
-- (Subscriber function) -- (Subscriber function)
-> Affection us UUID -> Affection us (MsgId msg)
-- ^ 'UUID' of the registered subscriber Function -- ^ 'UUID' of the registered subscriber Function
-- | Unsubscribe a Subscriber function from Participant -- | Unsubscribe a Subscriber function from Participant
partUnSubscribe partUnSubscribe
:: prt :: prt
-- ^ The 'Participant''s subscriber storage to unsubscribe from -- ^ The 'Participant''s subscriber storage to unsubscribe from
-> UUID -> (MsgId msg)
-- ^ The subscriber function's 'UUID' -- ^ The subscriber function's 'UUID'
-> Affection us () -> Affection us ()
@ -48,7 +51,7 @@ class (Show m, Message m) => Participant prt m us where
partEmit partEmit
:: prt :: prt
-- ^ The 'Participant''s subscriber storage -- ^ The 'Participant''s subscriber storage
-> m -> msg
-- ^ The 'Message' to emit -- ^ The 'Message' to emit
-> Affection us () -> Affection us ()
partEmit p m = do partEmit p m = do
@ -59,3 +62,5 @@ class (Show m, Message m) => Participant prt m us where
-- | Helper function to generate new 'UUID's -- | Helper function to generate new 'UUID's
genUUID :: Affection us UUID genUUID :: Affection us UUID
genUUID = liftIO nextRandom genUUID = liftIO nextRandom
data MsgId msg = (Message msg, Show msg) => MsgId UUID msg

View file

@ -4,13 +4,16 @@ import Affection.MessageBus.Message.Class
import qualified SDL import qualified SDL
data KeyboardMessage = MsgKeyboardEvent data KeyboardMessage
{ msgKbdWhen :: Double = MsgKeyboardEvent
, msgKbdWindow :: Maybe SDL.Window { msgKbdWhen :: Double
, msgKbdKeyMotion :: SDL.InputMotion , msgKbdWindow :: Maybe SDL.Window
, msgKbdKeyRepeat :: Bool , msgKbdKeyMotion :: SDL.InputMotion
, msgKbdKeysym :: SDL.Keysym , msgKbdKeyRepeat :: Bool
} deriving (Show) , msgKbdKeysym :: SDL.Keysym
}
| MsgKeyboardEmptyEvent
deriving (Show)
instance Message KeyboardMessage where instance Message KeyboardMessage where
msgTime (MsgKeyboardEvent t _ _ _ _) = t msgTime (MsgKeyboardEvent t _ _ _ _) = t

View file

@ -33,6 +33,7 @@ data MouseMessage
, msgMWPos :: V2 Int32 , msgMWPos :: V2 Int32
, msgMWDIrection :: SDL.MouseScrollDirection , msgMWDIrection :: SDL.MouseScrollDirection
} }
| MsgMouseEmptyMessage
deriving (Show) deriving (Show)
instance Message MouseMessage where instance Message MouseMessage where

View file

@ -68,6 +68,7 @@ data WindowMessage
{ msgWCWhen :: Double { msgWCWhen :: Double
, msgWCWindow :: SDL.Window , msgWCWindow :: SDL.Window
} }
| MsgWindowEmptyEvent
deriving (Show) deriving (Show)
instance Message WindowMessage where instance Message WindowMessage where