From ab6b274b06536f9c681e3d79950f9915ec49f77f Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 27 Dec 2017 18:44:22 +0100 Subject: [PATCH] adjust to new affection --- haskelloids.cabal | 2 +- src/InGame.hs | 16 ++++++++-------- src/Types.hs | 21 +++++++++++++-------- 3 files changed, 22 insertions(+), 17 deletions(-) diff --git a/haskelloids.cabal b/haskelloids.cabal index 9792085..db074a7 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -67,7 +67,7 @@ executable haskelloids -- Other library packages from which modules are imported. build-depends: base >=4.9 && <4.11 - , affection <= 0.0.0.7 + , affection <= 0.0.0.8 , sdl2 >= 2.1.3.1 , OpenGL diff --git a/src/InGame.hs b/src/InGame.hs index d51d961..ac9dacd 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -129,16 +129,16 @@ updateGame sec = do || any (checkFriendlyFire (ship ud2)) (shots ud2) ) && isNothing (wonlost ud2) - ) - (putAffection ud2 - { wonlost = Just Lost - } - ) - when (isNothing (wonlost ud2) && null (haskelloids ud2)) - (putAffection ud2 + ) $ do + liftIO $ logIO A.Debug "You Lost!" + putAffection ud2 + { wonlost = Just Lost + } + when (isNothing (wonlost ud2) && null (haskelloids ud2)) $ do + liftIO $ logIO A.Debug "You Won!" + putAffection ud2 { wonlost = Just Won } - ) checkShotDown :: Affection UserData () checkShotDown = diff --git a/src/Types.hs b/src/Types.hs index 89aa877..16fab54 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module Types where @@ -66,13 +67,15 @@ data Subsystems = Subsystems } data UUIDClean = UUIDClean - { uuWindow :: [MsgId WindowMessage] - , uuKeyboard :: [MsgId KeyboardMessage] + { uuWindow :: [UUID] + , uuKeyboard :: [UUID] } newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) -instance Participant Window WindowMessage UserData where +instance Participant Window UserData where + type Mesg Window UserData = WindowMessage + partSubscribers (Window t) = do subTups <- liftIO $ readTVarIO t return $ map snd subTups @@ -80,9 +83,9 @@ instance Participant Window WindowMessage UserData where partSubscribe (Window t) funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) - return $ MsgId uuid MsgWindowEmptyEvent + return uuid - partUnSubscribe (Window t) (MsgId uuid _) = + partUnSubscribe (Window t) uuid = liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) where filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool @@ -93,7 +96,9 @@ instance SDLSubsystem Window UserData where newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) -instance Participant Keyboard KeyboardMessage UserData where +instance Participant Keyboard UserData where + type Mesg Keyboard UserData = KeyboardMessage + partSubscribers (Keyboard t) = do subTups <- liftIO $ readTVarIO t return $ map snd subTups @@ -101,9 +106,9 @@ instance Participant Keyboard KeyboardMessage UserData where partSubscribe (Keyboard t) funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) - return $ MsgId uuid MsgKeyboardEmptyEvent + return uuid - partUnSubscribe (Keyboard t) (MsgId uuid _) = + partUnSubscribe (Keyboard t) uuid = liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) where filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool