affection/examples/example01/Types.hs

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