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.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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue