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 RecordWildCards #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}
import Affection import Affection
import qualified SDL import qualified SDL
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
data StateData = StateData data StateData = StateData
{ sdSubs :: Subsystems { sdSubs :: Subsystems
} }
data Subsystems = Subsystems data Subsystems = Subsystems
{ subWindow :: AffectionWindow StateData { subWindow :: Window
, subMouse :: AffectionMouse StateData , subMouse :: Mouse
, subKeyboard :: AffectionKeyboard StateData , 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 :: IO ()
main = do main = do
logIO Debug "Starting" logIO Debug "Starting"
@ -23,6 +76,10 @@ main = do
{ initComponents = All { initComponents = All
, windowTitle = "affection: example00" , windowTitle = "affection: example00"
, windowConfig = SDL.defaultWindow , windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
, initScreenMode = SDL.Windowed , initScreenMode = SDL.Windowed
, canvasSize = Nothing , canvasSize = Nothing
, loadState = load , loadState = load
@ -40,9 +97,9 @@ load = do
empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())]) empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())]) empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
return $ StateData $ Subsystems return $ StateData $ Subsystems
(AffectionWindow empty1) (Window empty1)
(AffectionMouse empty2) (Mouse empty2)
(AffectionKeyboard empty3) (Keyboard empty3)
pre :: Affection StateData () pre :: Affection StateData ()
pre = do pre = do

View file

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

View file

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

View file

@ -1,5 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-}
module Affection.Subsystems.AffectionMouse where module Affection.Subsystems.AffectionMouse where
import Affection.MessageBus import Affection.MessageBus
@ -14,57 +14,44 @@ import Linear.Affine (unP)
import qualified SDL import qualified SDL
data AffectionMouse sd = AffectionMouse consumeSDLMouseEvents
{ mouseSubscribers :: forall sd. TVar [(UUID, MouseMessage -> Affection sd ())] :: (Participant am MouseMessage us)
} => am
-> [SDL.EventPayload]
instance Participant (AffectionMouse sd) MouseMessage where -> Affection us [SDL.EventPayload]
partSubscribe p funct = do consumeSDLMouseEvents am eps = doConsume eps
uuid <- genUUID where
liftIO $ atomically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :) doConsume [] = return []
return uuid doConsume (e:es) = do
ts <- getElapsedTime
partUnSubscribe p uuid = case e of
liftIO $ atomically $ modifyTVar' (mouseSubscribers p) SDL.MouseMotionEvent dat -> do
(filter (\(u, _) -> u /= uuid)) partEmit am (MsgMouseMotion
ts
partSubscribers p = do (SDL.mouseMotionEventWindow dat)
subTups <- liftIO $ readTVarIO $ mouseSubscribers p (SDL.mouseMotionEventWhich dat)
return $ map snd subTups (SDL.mouseMotionEventState dat)
(unP $ SDL.mouseMotionEventPos dat)
instance SDLSubsystem (AffectionMouse sd) MouseMessage where (SDL.mouseMotionEventRelMotion dat)
consumeSDLEvents am eps = doConsume eps )
where doConsume es
doConsume (e:es) = do SDL.MouseButtonEvent dat -> do
ts <- getElapsedTime partEmit am (MsgMouseButton
case e of ts
SDL.MouseMotionEvent dat -> do (SDL.mouseButtonEventWindow dat)
partEmit am (MsgMouseMotion (SDL.mouseButtonEventWhich dat)
ts (SDL.mouseButtonEventButton dat)
(SDL.mouseMotionEventWindow dat) (SDL.mouseButtonEventClicks dat)
(SDL.mouseMotionEventWhich dat) (unP $ SDL.mouseButtonEventPos dat)
(SDL.mouseMotionEventState dat) )
(unP $ SDL.mouseMotionEventPos dat) doConsume es
(SDL.mouseMotionEventRelMotion dat) SDL.MouseWheelEvent dat -> do
) partEmit am (MsgMouseWheel
doConsume es ts
SDL.MouseButtonEvent dat -> do (SDL.mouseWheelEventWindow dat)
partEmit am (MsgMouseButton (SDL.mouseWheelEventWhich dat)
ts (SDL.mouseWheelEventPos dat)
(SDL.mouseButtonEventWindow dat) (SDL.mouseWheelEventDirection dat)
(SDL.mouseButtonEventWhich dat) )
(SDL.mouseButtonEventButton dat) doConsume es
(SDL.mouseButtonEventClicks dat) _ -> fmap (e :) (doConsume es)
(unP $ SDL.mouseButtonEventPos dat)
)
doConsume es
SDL.MouseWheelEvent dat -> do
partEmit am (MsgMouseWheel
ts
(SDL.mouseWheelEventWindow dat)
(SDL.mouseWheelEventWhich dat)
(SDL.mouseWheelEventPos dat)
(SDL.mouseWheelEventDirection dat)
)
doConsume es
_ -> fmap (e :) (doConsume es)

View file

@ -1,6 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}
module Affection.Subsystems.AffectionWindow where module Affection.Subsystems.AffectionWindow where
import Affection.Types import Affection.Types
@ -13,70 +13,57 @@ import Control.Monad.IO.Class (liftIO)
import qualified SDL import qualified SDL
data AffectionWindow us = AffectionWindow consumeSDLWindowEvents
{ windowSubscribers :: forall us. TVar [(UUID, WindowMessage -> Affection us ())] :: (Participant aw WindowMessage us)
} => aw
-> [SDL.EventPayload]
instance Participant (AffectionWindow us) WindowMessage where -> Affection us [SDL.EventPayload]
partSubscribe p funct = do consumeSDLWindowEvents aw eps = doConsume eps
uuid <- genUUID where
liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :) doConsume [] = return []
return uuid doConsume (e:es) = do
ts <- getElapsedTime
partUnSubscribe p uuid = case e of
liftIO $ atomically $ modifyTVar' (windowSubscribers p) SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
(filter (\(u, _) -> u /= uuid)) partEmit aw (MsgWindowShow ts window)
doConsume es
partSubscribers p = do SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
subTups <- liftIO $ readTVarIO $ windowSubscribers p partEmit aw (MsgWindowHide ts window)
return $ map snd subTups doConsume es
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
instance SDLSubsystem (AffectionWindow us) WindowMessage where partEmit aw (MsgWindowExpose ts window)
consumeSDLEvents aw eps = doConsume eps doConsume es
where SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
doConsume (e:es) = do partEmit aw (MsgWindowMove ts window newPos)
ts <- getElapsedTime doConsume es
case e of SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do partEmit aw (MsgWindowResize ts window newSize)
partEmit aw (MsgWindowShow ts window) doConsume es
doConsume es SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do partEmit aw (MsgWindowSizeChange ts window)
partEmit aw (MsgWindowHide ts window) doConsume es
doConsume es SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do partEmit aw (MsgWindowMinimize ts window)
partEmit aw (MsgWindowExpose ts window) doConsume es
doConsume es SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do partEmit aw (MsgWindowMaximize ts window)
partEmit aw (MsgWindowMove ts window newPos) doConsume es
doConsume es SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do partEmit aw (MsgWindowRestore ts window)
partEmit aw (MsgWindowResize ts window newSize) doConsume es
doConsume es SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do partEmit aw (MsgWindowGainMouseFocus ts window)
partEmit aw (MsgWindowSizeChange ts window) doConsume es
doConsume es SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do partEmit aw (MsgWindowLoseMouseFocus ts window)
partEmit aw (MsgWindowMinimize ts window) doConsume es
doConsume es SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do partEmit aw (MsgWindowGainKeyboardFocus ts window)
partEmit aw (MsgWindowMaximize ts window) doConsume es
doConsume es SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do partEmit aw (MsgWindowLoseKeyboardFocus ts window)
partEmit aw (MsgWindowRestore ts window) doConsume es
doConsume es SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do partEmit aw (MsgWindowClose ts window)
partEmit aw (MsgWindowGainMouseFocus ts window) doConsume es
doConsume es _ -> fmap (e :) (doConsume es)
SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
partEmit aw (MsgWindowLoseMouseFocus ts window)
doConsume es
SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
partEmit aw (MsgWindowGainKeyboardFocus ts window)
doConsume es
SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
partEmit aw (MsgWindowLoseKeyboardFocus ts window)
doConsume es
SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
partEmit aw (MsgWindowClose ts window)
doConsume es
_ -> fmap (e :) (doConsume es)

View file

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