pituicat/src/Types/Subsystems.hs

90 lines
2.4 KiB
Haskell

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MutliParamTypeClasses #-}
module Types.Subsystems where
import Affection
import Control.Concurrent.STM.TVar
data Subsystems = Subsystems
{ subWindow :: SubWindow
, subMouse :: SubMouse
, subKeyboard :: SubKeyboard
, subTranslator :: SubTranslator
}
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
newtype SubTranslator = SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())])
instance Participant SubWindow where
type Mesg SubWindow = WindowMessage
partSubscribers (SubWindow t) = generalSubscribers t
partSubscribe (SubWindow t) = generalSubscribe t
partUnSubscribe (SubWindow t) = generalUnSubscribe t
instance SDLSubsystem SubWindow where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant SubMouse where
type Mesg SubMouse = MouseMessage
partSubscribers (SubMouse t) = generalSubscribers t
partSubscribe (SubMouse t) = generalSubscribe t
partUnSubscribe (SubMouse t) = generalUnSubscribe t
instance SDLSubsystem SubMouse where
consumeSDLEvents = consumeSDLMouseEvents
instance Participant SubKeyboard where
type Mesg SubKeyboard = KeyboardMessage
partSubscribers (SubKeyboard t) = generalSubscribers t
partSubscribe (SubKeyboard t) = generalSubscribe t
partUnSubscribe (SubKeyboard t) = generalUnSubscribe t
instance SDLSubsystem SubKeyboard where
consumeSDLEvents = consumeSDLKeyboardEvents
instance Participant SubTranslator where
type Mesg SubTranslator = TranslatorMessage
partSubscribers (SubTranslator t) = generalSubscribers t
partSubscribe (SubTranslator t) = generalSubscribe t
partUnSubscribe (SubTranslator t) = generalUnSubscribe t
generalSubscribers
:: TVar [(UUID, msg -> Affection ())]
-> Affection [(msg -> Affection ())]
generalSubscribers t = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
generalSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection ())
-> Affection UUID
generalSubscribe t funct = do
uu <- genUUID
liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
return uu
generalUnSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> UUID
-> Affection ()
generalUnSubscribe t uu =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
where
filterMsg (u, _) p = u /= p