76 lines
1.9 KiB
Haskell
76 lines
1.9 KiB
Haskell
|
{-# 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
|
||
|
|
, subsystems :: Subsystems
|
||
|
|
, nano :: Context
|
||
|
|
}
|
||
|
|
|
||
|
|
data Subsystems = Subsystems
|
||
|
|
{ subWindow :: Window
|
||
|
|
, subKeyboard :: Keyboard
|
||
|
|
}
|
||
|
|
|
||
|
|
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
|
||
|
|
|
||
|
|
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
|
||
|
|
|
||
|
|
instance Participant Window UserData where
|
||
|
|
type Mesg Window UserData = WindowMessage
|
||
|
|
|
||
|
|
partSubscribers (Window t) = do
|
||
|
|
subTups <- liftIO $ readTVarIO t
|
||
|
|
return $ map snd subTups
|
||
|
|
|
||
|
|
partSubscribe (Window t) = generalSubscribe t
|
||
|
|
|
||
|
|
partUnSubscribe (Window t) = generalUnSubscribe t
|
||
|
|
|
||
|
|
instance SDLSubsystem Window UserData where
|
||
|
|
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 =
|
||
|
|
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
|
||
|
|
where
|
||
|
|
filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
|
||
|
|
filterMsg (u, _) p = u /= p
|