diff --git a/examples/example00/Main.hs b/examples/example00/Main.hs index 31b3a49..6986905 100644 --- a/examples/example00/Main.hs +++ b/examples/example00/Main.hs @@ -6,8 +6,9 @@ module Main where import Affection as A import Control.Concurrent.STM +import Control.Concurrent.MVar import Control.Monad.IO.Class (liftIO) -import Control.Monad (when) +import Control.Monad import qualified SDL hiding (Window(..)) @@ -16,9 +17,19 @@ import Data.String data StateData = StateData { sdSubs :: Subsystems - , sdJoys :: [SDL.Joystick] + , sdJoys :: MVar [SDL.Joystick] + , doNextStep :: MVar Bool } +instance Affectionate StateData where + loadState = load + preLoop = pre + handleEvents = handle + update = Main.update + draw = Main.draw + cleanUp = clean + hasNextStep = liftIO . readMVar . doNextStep + data Subsystems = Subsystems { subWindow :: Main.Window , subMouse :: Main.Mouse @@ -26,36 +37,13 @@ data Subsystems = Subsystems , subJoystick :: Main.Joystick } -newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) -newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) -newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) -newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection StateData ())]) +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())]) +newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())]) +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) +newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())]) -generalSubscribers - :: TVar [(UUID, msg -> Affection StateData ())] - -> Affection StateData [msg -> Affection StateData ()] -generalSubscribers t = do - subTups <- liftIO $ readTVarIO t - return $ map snd subTups - -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 - -generalUnSubscribe - :: TVar [(UUID, msg -> Affection StateData ())] - -> UUID - -> Affection StateData () -generalUnSubscribe t uuid = - liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) - -instance Participant Main.Window StateData where - type Mesg Main.Window StateData = WindowMessage +instance Participant Main.Window where + type Mesg Main.Window = WindowMessage partSubscribers (Window t) = generalSubscribers t @@ -63,11 +51,11 @@ instance Participant Main.Window StateData where partUnSubscribe (Window t) = generalUnSubscribe t -instance SDLSubsystem Main.Window StateData where +instance SDLSubsystem Main.Window where consumeSDLEvents = consumeSDLWindowEvents -instance Participant Mouse StateData where - type Mesg Mouse StateData = MouseMessage +instance Participant Mouse where + type Mesg Mouse = MouseMessage partSubscribers (Mouse t) = generalSubscribers t @@ -75,11 +63,11 @@ instance Participant Mouse StateData where partUnSubscribe (Mouse t) = generalUnSubscribe t -instance SDLSubsystem Mouse StateData where +instance SDLSubsystem Mouse where consumeSDLEvents = consumeSDLMouseEvents -instance Participant Keyboard StateData where - type Mesg Keyboard StateData = KeyboardMessage +instance Participant Keyboard where + type Mesg Keyboard = KeyboardMessage partSubscribers (Keyboard t) = generalSubscribers t @@ -87,11 +75,11 @@ instance Participant Keyboard StateData where partUnSubscribe (Keyboard t) = generalUnSubscribe t -instance SDLSubsystem Keyboard StateData where +instance SDLSubsystem Keyboard where consumeSDLEvents = consumeSDLKeyboardEvents -instance Participant Joystick StateData where - type Mesg Joystick StateData = JoystickMessage +instance Participant Joystick where + type Mesg Joystick = JoystickMessage partSubscribers (Joystick t) = generalSubscribers t @@ -99,7 +87,7 @@ instance Participant Joystick StateData where partUnSubscribe (Joystick t) = generalUnSubscribe t -instance SDLSubsystem Joystick StateData where +instance SDLSubsystem Joystick where consumeSDLEvents = consumeSDLJoystickEvents main :: IO () @@ -116,17 +104,10 @@ main = do { SDL.glProfile = SDL.Core SDL.Normal 3 3 } } + , SDL.Windowed ) ] - , initScreenMode = SDL.Windowed - , canvasSize = Nothing - , loadState = load - , preLoop = pre - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , cleanUp = clean - } + } :: AffectionConfig StateData withAffection conf load :: IO StateData @@ -137,49 +118,45 @@ load = <*> (Keyboard <$> newTVarIO []) <*> (Joystick <$> newTVarIO []) ) - <*> return [] + <*> newMVar [] + <*> newMVar True -pre :: Affection StateData () -pre = do - sd <- getAffection - _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ - _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose - _ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect +pre :: StateData -> Affection () +pre sd = do + _ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd)) + _ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd)) + _ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd)) return () -exitOnQ :: KeyboardMessage -> Affection StateData () -exitOnQ (MsgKeyboardEvent _ _ _ _ sym) = +exitOnQ :: MVar Bool -> KeyboardMessage -> Affection () +exitOnQ break (MsgKeyboardEvent _ _ _ _ sym) = case SDL.keysymKeycode sym of SDL.KeycodeQ -> do liftIO $ logIO Debug "Yo dog I heard..." - quit + void $ liftIO $ swapMVar break False _ -> return () -exitOnWindowClose :: WindowMessage -> Affection StateData () -exitOnWindowClose wm = +exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection () +exitOnWindowClose break wm = case wm of MsgWindowClose _ _ -> do liftIO $ logIO Debug "I heard another one..." - quit + void $ liftIO $ swapMVar break False _ -> return () -joyConnectDisconnect :: JoystickMessage -> Affection StateData () -joyConnectDisconnect msg = do +joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection () +joyConnectDisconnect mvjs msg = do mj <- joystickAutoConnect msg when (isJust mj) $ do - sd <- getAffection - putAffection sd - { sdJoys = fromJust mj : sdJoys sd - } - sd <- getAffection - njs <- joystickAutoDisconnect (sdJoys sd) msg - putAffection sd - { sdJoys = njs - } + js <- liftIO $ readMVar mvjs + void $ liftIO $ swapMVar mvjs (fromJust mj : js) + js <- liftIO $ readMVar mvjs + njs <- joystickAutoDisconnect js msg + liftIO $ putMVar mvjs njs -handle :: [SDL.EventPayload] -> Affection StateData () -handle es = do - (Subsystems a b c d) <- sdSubs <$> getAffection +handle :: StateData -> [SDL.EventPayload] -> Affection () +handle sd es = do + let (Subsystems a b c d) = sdSubs sd leftovers <- consumeSDLEvents a =<< consumeSDLEvents b =<< consumeSDLEvents c @@ -187,8 +164,31 @@ handle es = do mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e)) leftovers -update _ = return () +update _ _ = return () -draw = return () +draw _ = return () clean _ = return () + +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 + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + +generalUnSubscribe + :: TVar [(UUID, msg -> Affection ())] + -> UUID + -> Affection () +generalUnSubscribe t uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) diff --git a/src/Affection/Subsystems/Class.hs b/src/Affection/Subsystems/Class.hs index f004eee..ec55ae3 100644 --- a/src/Affection/Subsystems/Class.hs +++ b/src/Affection/Subsystems/Class.hs @@ -7,7 +7,7 @@ import Affection.Types import qualified SDL -- | This class denotes a Subsystem to be part of SDL -class SDLSubsystem s us where +class SDLSubsystem s where -- | Consume the given 'SDL.EventPayload's and return only those not -- recognised consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload]