90 lines
2.4 KiB
Haskell
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
|