affection/examples/example01/Types.hs

79 lines
1.9 KiB
Haskell
Raw Permalink Normal View History

2017-12-28 15:56:49 +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
2017-12-28 15:56:49 +00:00
data UserData = UserData
{ lifeMat :: MVar (Matrix Word)
, foodMat :: MVar (Matrix Word)
, timeMat :: MVar (Matrix Word)
2017-12-28 15:56:49 +00:00
, subsystems :: Subsystems
, nano :: Context
, doNextStep :: MVar Bool
2017-12-28 15:56:49 +00:00
}
data Subsystems = Subsystems
2018-09-25 14:10:36 +00:00
{ subWindow :: Types.Window
, subKeyboard :: Types.Keyboard
2017-12-28 15:56:49 +00:00
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
2017-12-28 15:56:49 +00:00
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
2017-12-28 15:56:49 +00:00
instance Participant Types.Window where
type Mesg Types.Window = WindowMessage
2017-12-28 15:56:49 +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
2017-12-28 15:56:49 +00:00
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Keyboard where
type Mesg Keyboard = KeyboardMessage
2017-12-28 15:56:49 +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
2017-12-28 15:56:49 +00:00
consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection ())
-> Affection UUID
2017-12-28 15:56:49 +00:00
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection ())]
2017-12-28 15:56:49 +00:00
-> UUID
-> Affection ()
2017-12-28 15:56:49 +00:00
generalUnSubscribe t uuid =
2017-12-29 19:31:52 +00:00
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
2017-12-29 19:31:52 +00:00
filterMsg (u, _) p = u /= p