event system works!
This commit is contained in:
nek0
parent
3199d03401
commit
f12e62d938
6 changed files with 209 additions and 180 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
Loading…
Reference in a new issue