linted
This commit is contained in:
parent
004579eedd
commit
ca81795585
3 changed files with 19 additions and 23 deletions
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue