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'
-- (Subscriber function)
-> Affection us UUID -- ^ 'UUID' of the registered subscriber Function
:: 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
-- | 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,37 +12,24 @@ 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
where
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)
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
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 RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
module Affection.Subsystems.AffectionMouse where
import Affection.MessageBus
@ -14,57 +14,44 @@ 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
where
doConsume (e:es) = do
ts <- getElapsedTime
case e of
SDL.MouseMotionEvent dat -> do
partEmit am (MsgMouseMotion
ts
(SDL.mouseMotionEventWindow dat)
(SDL.mouseMotionEventWhich dat)
(SDL.mouseMotionEventState dat)
(unP $ SDL.mouseMotionEventPos dat)
(SDL.mouseMotionEventRelMotion dat)
)
doConsume es
SDL.MouseButtonEvent dat -> do
partEmit am (MsgMouseButton
ts
(SDL.mouseButtonEventWindow dat)
(SDL.mouseButtonEventWhich dat)
(SDL.mouseButtonEventButton dat)
(SDL.mouseButtonEventClicks dat)
(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)
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
SDL.MouseMotionEvent dat -> do
partEmit am (MsgMouseMotion
ts
(SDL.mouseMotionEventWindow dat)
(SDL.mouseMotionEventWhich dat)
(SDL.mouseMotionEventState dat)
(unP $ SDL.mouseMotionEventPos dat)
(SDL.mouseMotionEventRelMotion dat)
)
doConsume es
SDL.MouseButtonEvent dat -> do
partEmit am (MsgMouseButton
ts
(SDL.mouseButtonEventWindow dat)
(SDL.mouseButtonEventWhich dat)
(SDL.mouseButtonEventButton dat)
(SDL.mouseButtonEventClicks dat)
(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 RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Affection.Subsystems.AffectionWindow where
import Affection.Types
@ -13,70 +13,57 @@ 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
where
doConsume (e:es) = do
ts <- getElapsedTime
case e of
SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
partEmit aw (MsgWindowShow ts window)
doConsume es
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
partEmit aw (MsgWindowHide ts window)
doConsume es
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
partEmit aw (MsgWindowExpose ts window)
doConsume es
SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
partEmit aw (MsgWindowMove ts window newPos)
doConsume es
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
partEmit aw (MsgWindowResize ts window newSize)
doConsume es
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
partEmit aw (MsgWindowSizeChange ts window)
doConsume es
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
partEmit aw (MsgWindowMinimize ts window)
doConsume es
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
partEmit aw (MsgWindowMaximize ts window)
doConsume es
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
partEmit aw (MsgWindowRestore ts window)
doConsume es
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
partEmit aw (MsgWindowGainMouseFocus ts window)
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)
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
SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
partEmit aw (MsgWindowShow ts window)
doConsume es
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
partEmit aw (MsgWindowHide ts window)
doConsume es
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
partEmit aw (MsgWindowExpose ts window)
doConsume es
SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
partEmit aw (MsgWindowMove ts window newPos)
doConsume es
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
partEmit aw (MsgWindowResize ts window newSize)
doConsume es
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
partEmit aw (MsgWindowSizeChange ts window)
doConsume es
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
partEmit aw (MsgWindowMinimize ts window)
doConsume es
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
partEmit aw (MsgWindowMaximize ts window)
doConsume es
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
partEmit aw (MsgWindowRestore ts window)
doConsume es
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
partEmit aw (MsgWindowGainMouseFocus ts window)
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
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]