This commit is contained in:
nek0 2017-12-15 18:12:16 +01:00
parent 004579eedd
commit ca81795585
3 changed files with 19 additions and 23 deletions

View file

@ -6,7 +6,7 @@ import qualified SDL
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
data StateData = StateData newtype StateData = StateData
{ sdSubs :: Subsystems { sdSubs :: Subsystems
} }
@ -16,19 +16,16 @@ data Subsystems = Subsystems
, subKeyboard :: Keyboard , subKeyboard :: Keyboard
} }
data Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
data Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
data Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
instance Participant Window WindowMessage StateData where instance Participant Window WindowMessage StateData where
partSubscribers (Window t) = do partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO $ t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
partSubscribe (Window t) funct = do partSubscribe (Window t) = generalSubscribe t
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Window t) uuid = partUnSubscribe (Window t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
@ -38,13 +35,10 @@ instance SDLSubsystem Window StateData where
instance Participant Mouse MouseMessage StateData where instance Participant Mouse MouseMessage StateData where
partSubscribers (Mouse t) = do partSubscribers (Mouse t) = do
subTups <- liftIO $ readTVarIO $ t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
partSubscribe (Mouse t) funct = do partSubscribe (Mouse t) = generalSubscribe t
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Mouse t) uuid = partUnSubscribe (Mouse t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
@ -54,13 +48,10 @@ instance SDLSubsystem Mouse StateData where
instance Participant Keyboard KeyboardMessage StateData where instance Participant Keyboard KeyboardMessage StateData where
partSubscribers (Keyboard t) = do partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO $ t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
partSubscribe (Keyboard t) funct = do partSubscribe (Keyboard t) = generalSubscribe t
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Keyboard t) uuid = partUnSubscribe (Keyboard t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
@ -68,6 +59,11 @@ instance Participant Keyboard KeyboardMessage StateData where
instance SDLSubsystem Keyboard StateData where instance SDLSubsystem Keyboard StateData where
consumeSDLEvents = consumeSDLKeyboardEvents consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
main :: IO () main :: IO ()
main = do main = do
logIO Debug "Starting" logIO Debug "Starting"

View file

@ -52,7 +52,7 @@ withAffection AffectionConfig{..} = do
-- construct window -- construct window
window <- SDL.createWindow windowTitle windowConfig window <- SDL.createWindow windowTitle windowConfig
SDL.showWindow window SDL.showWindow window
context <- SDL.glCreateContext windw context <- SDL.glCreateContext window
let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig
(w, h) = case canvasSize of (w, h) = case canvasSize of
Just (cw, ch) -> (cw, ch) Just (cw, ch) -> (cw, ch)
@ -104,7 +104,7 @@ withAffection AffectionConfig{..} = do
-- execute user defined draw loop -- execute user defined draw loop
liftIO $ GL.clear [ColorBuffer, DepthBuffer] liftIO $ GL.clear [ColorBuffer, DepthBuffer]
drawLoop drawLoop
liftIO $ flush liftIO flush
-- handle all new draw requests -- handle all new draw requests
ad2 <- get ad2 <- get
-- actual drawing -- actual drawing

View file

@ -23,7 +23,7 @@ class (Show m, Message m) => Participant prt m us where
partSubscribers partSubscribers
:: prt :: prt
-- ^ the 'Participant''s subscriber storage -- ^ the 'Participant''s subscriber storage
-> Affection us [(m -> Affection us ())] -> Affection us [m -> Affection us ()]
-- ^ List of Subscriber functions -- ^ List of Subscriber functions
-- | Subscribe to the 'Participant''s events -- | Subscribe to the 'Participant''s events
@ -58,4 +58,4 @@ 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