drop repetitive code

This commit is contained in:
nek0 2017-12-27 20:27:38 +01:00
parent a1ab48009f
commit 11bb7b69e5

View file

@ -21,6 +21,15 @@ newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
generalSubscribe
:: TVar [(UUID, msg -> Affection StateData ())]
-> (msg -> Affection StateData())
-> Affection StateData UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
instance Participant Window StateData where instance Participant Window StateData where
type Mesg Window StateData = WindowMessage type Mesg Window StateData = WindowMessage
@ -28,10 +37,7 @@ instance Participant Window StateData where
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
partSubscribe (Window t) funct = do partSubscribe (Window t) = generalSubscribe t
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Window t) uuid = partUnSubscribe (Window t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
@ -46,10 +52,7 @@ instance Participant Mouse StateData where
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
partSubscribe (Mouse t) funct = do partSubscribe (Mouse t) = generalSubscribe t
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Mouse t) uuid = partUnSubscribe (Mouse t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
@ -64,10 +67,7 @@ instance Participant Keyboard StateData where
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
return $ map snd subTups return $ map snd subTups
partSubscribe (Keyboard t) funct = do partSubscribe (Keyboard t) = generalSubscribe t
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Keyboard t) uuid = partUnSubscribe (Keyboard t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))