affection/examples/example02/Types.hs

79 lines
1.9 KiB
Haskell
Raw Permalink Normal View History

2018-12-26 22:19:20 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types where
import Affection
import Data.Matrix as M
import NanoVG
import Control.Concurrent.STM
import Control.Concurrent.MVar
2018-12-26 22:19:20 +00:00
data UserData = UserData
{ lifeMat :: MVar (Matrix Word)
, foodMat :: MVar (Matrix Word)
, timeMat :: MVar (Matrix Word)
2018-12-26 22:19:20 +00:00
, subsystems :: Subsystems
, nano :: Context
, doNextStep :: MVar Bool
2018-12-26 22:19:20 +00:00
}
data Subsystems = Subsystems
{ subWindow :: Types.Window
, subKeyboard :: Types.Keyboard
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
2018-12-26 22:19:20 +00:00
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
2018-12-26 22:19:20 +00:00
instance Participant Types.Window where
type Mesg Types.Window = WindowMessage
2018-12-26 22:19:20 +00:00
partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Window t) = generalSubscribe t
partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Types.Window where
2018-12-26 22:19:20 +00:00
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Keyboard where
type Mesg Keyboard = KeyboardMessage
2018-12-26 22:19:20 +00:00
partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Keyboard t) = generalSubscribe t
partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard where
2018-12-26 22:19:20 +00:00
consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection ())
-> Affection UUID
2018-12-26 22:19:20 +00:00
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection ())]
2018-12-26 22:19:20 +00:00
-> UUID
-> Affection ()
2018-12-26 22:19:20 +00:00
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
2018-12-26 22:19:20 +00:00
filterMsg (u, _) p = u /= p