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

View file

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

View file

@ -23,7 +23,7 @@ class (Show m, Message m) => Participant prt m us where
partSubscribers
:: prt
-- ^ the 'Participant''s subscriber storage
-> Affection us [(m -> Affection us ())]
-> Affection us [m -> Affection us ()]
-- ^ List of Subscriber functions
-- | 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
genUUID :: Affection us UUID
genUUID = liftIO $ nextRandom
genUUID = liftIO nextRandom