event system works!

This commit is contained in:
nek0 2017-12-15 17:48:12 +01:00
parent 3199d03401
commit f12e62d938
6 changed files with 209 additions and 180 deletions

View file

@ -1,21 +1,74 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
import Affection
import qualified SDL
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
data StateData = StateData
{ sdSubs :: Subsystems
}
data Subsystems = Subsystems
{ subWindow :: AffectionWindow StateData
, subMouse :: AffectionMouse StateData
, subKeyboard :: AffectionKeyboard StateData
{ subWindow :: Window
, subMouse :: Mouse
, subKeyboard :: Keyboard
}
data Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
data Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
data Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
instance Participant Window WindowMessage StateData where
partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO $ t
return $ map snd subTups
partSubscribe (Window t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Window t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance SDLSubsystem Window StateData where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Mouse MouseMessage StateData where
partSubscribers (Mouse t) = do
subTups <- liftIO $ readTVarIO $ t
return $ map snd subTups
partSubscribe (Mouse t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Mouse t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance SDLSubsystem Mouse StateData where
consumeSDLEvents = consumeSDLMouseEvents
instance Participant Keyboard KeyboardMessage StateData where
partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO $ t
return $ map snd subTups
partSubscribe (Keyboard t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Keyboard t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance SDLSubsystem Keyboard StateData where
consumeSDLEvents = consumeSDLKeyboardEvents
main :: IO ()
main = do
logIO Debug "Starting"
@ -23,6 +76,10 @@ main = do
{ initComponents = All
, windowTitle = "affection: example00"
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
, initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
@ -40,9 +97,9 @@ load = do
empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
return $ StateData $ Subsystems
(AffectionWindow empty1)
(AffectionMouse empty2)
(AffectionKeyboard empty3)
(Window empty1)
(Mouse empty2)
(Keyboard empty3)
pre :: Affection StateData ()
pre = do

View file

@ -1,6 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
module Affection.MessageBus.Class
( Participant(..)
, genUUID
@ -17,34 +17,45 @@ import Data.UUID.V4
import Affection.Logging
class (Show m, Message m) => Participant prt m where
-- | Function to get the lsit of subscribers from the participant
class (Show m, Message m) => Participant prt m us where
-- | Function to get the list of subscribers from the participant
partSubscribers
:: prt -- ^ the participant
-> forall us. Affection us [(m -> Affection us ())] -- ^ List of Subscriber functions
:: prt
-- ^ the 'Participant''s subscriber storage
-> Affection us [(m -> Affection us ())]
-- ^ List of Subscriber functions
-- | Subscribe to the 'Participant''s events
partSubscribe
:: prt -- ^ The 'Participant' to subscribe to
-> (forall us. m -> Affection us ()) -- ^ What to do in case of a 'Message'
:: prt
-- ^ The 'Participant''s subscriber storage
-> (m -> Affection us ())
-- ^ What to do in case of a 'Message'
-- (Subscriber function)
-> Affection us 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'
:: prt
-- ^ The 'Participant''s subscriber storage to unsubscribe from
-> UUID
-- ^ The subscriber function's 'UUID'
-> Affection us ()
-- | Get the 'Participant' to emit a 'Message' on all of its subscribers
partEmit
:: prt -- ^ The 'Participant'
-> m -- ^ The 'Message' to emit
:: prt
-- ^ The 'Participant''s subscriber storage
-> m
-- ^ The 'Message' to emit
-> Affection us ()
partEmit p m = do
liftIO $ logIO Debug $ "Emitting message: " ++ show m
l <- partSubscribers p
mapM_ ($ m) l
-- | Helper function to generate new 'UUID's
genUUID :: Affection us UUID
genUUID = liftIO $ nextRandom

View file

@ -1,5 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
module Affection.Subsystems.AffectionKeyboard where
import Affection.Types
@ -12,27 +12,14 @@ import Control.Monad.IO.Class (liftIO)
import qualified SDL
data AffectionKeyboard us = AffectionKeyboard
{ keyboardSubscribers :: forall us. TVar [(UUID, KeyboardMessage -> Affection us ())]
}
instance Participant (AffectionKeyboard us) KeyboardMessage where
partSubscribe p funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :)
return uuid
partUnSubscribe p uuid =
liftIO $ atomically $ modifyTVar' (keyboardSubscribers p)
(filter (\(u, _) -> u /= uuid))
partSubscribers p = do
subTups <- liftIO $ readTVarIO $ keyboardSubscribers p
return $ map snd subTups
instance SDLSubsystem (AffectionKeyboard us) KeyboardMessage where
consumeSDLEvents ak eps = doConsume eps
consumeSDLKeyboardEvents
:: (Participant ak KeyboardMessage us)
=> ak
-> [SDL.EventPayload]
-> Affection us [SDL.EventPayload]
consumeSDLKeyboardEvents ak eps = doConsume eps
where
doConsume [] = return []
doConsume (e:es) = do
ts <- getElapsedTime
case e of

View file

@ -1,5 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
module Affection.Subsystems.AffectionMouse where
import Affection.MessageBus
@ -14,27 +14,14 @@ import Linear.Affine (unP)
import qualified SDL
data AffectionMouse sd = AffectionMouse
{ mouseSubscribers :: forall sd. TVar [(UUID, MouseMessage -> Affection sd ())]
}
instance Participant (AffectionMouse sd) MouseMessage where
partSubscribe p funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :)
return uuid
partUnSubscribe p uuid =
liftIO $ atomically $ modifyTVar' (mouseSubscribers p)
(filter (\(u, _) -> u /= uuid))
partSubscribers p = do
subTups <- liftIO $ readTVarIO $ mouseSubscribers p
return $ map snd subTups
instance SDLSubsystem (AffectionMouse sd) MouseMessage where
consumeSDLEvents am eps = doConsume eps
consumeSDLMouseEvents
:: (Participant am MouseMessage us)
=> am
-> [SDL.EventPayload]
-> Affection us [SDL.EventPayload]
consumeSDLMouseEvents am eps = doConsume eps
where
doConsume [] = return []
doConsume (e:es) = do
ts <- getElapsedTime
case e of

View file

@ -1,6 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Affection.Subsystems.AffectionWindow where
import Affection.Types
@ -13,27 +13,14 @@ import Control.Monad.IO.Class (liftIO)
import qualified SDL
data AffectionWindow us = AffectionWindow
{ windowSubscribers :: forall us. TVar [(UUID, WindowMessage -> Affection us ())]
}
instance Participant (AffectionWindow us) WindowMessage where
partSubscribe p funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :)
return uuid
partUnSubscribe p uuid =
liftIO $ atomically $ modifyTVar' (windowSubscribers p)
(filter (\(u, _) -> u /= uuid))
partSubscribers p = do
subTups <- liftIO $ readTVarIO $ windowSubscribers p
return $ map snd subTups
instance SDLSubsystem (AffectionWindow us) WindowMessage where
consumeSDLEvents aw eps = doConsume eps
consumeSDLWindowEvents
:: (Participant aw WindowMessage us)
=> aw
-> [SDL.EventPayload]
-> Affection us [SDL.EventPayload]
consumeSDLWindowEvents aw eps = doConsume eps
where
doConsume [] = return []
doConsume (e:es) = do
ts <- getElapsedTime
case e of

View file

@ -7,5 +7,5 @@ import Affection.MessageBus
import qualified SDL
class (Message m, Participant s m) => SDLSubsystem s m where
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection sd [SDL.EventPayload]
class SDLSubsystem s us where
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]