make example00 affectionate and working!

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 Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
-newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
+newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())])
-newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
-newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection StateData ())])
+newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())])
 
-generalSubscribers
+instance Participant Main.Window where
-  :: TVar [(UUID, msg -> Affection StateData ())]
+  type Mesg Main.Window = WindowMessage
-  -> 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
 
   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
+instance Participant Mouse where
-  type Mesg Mouse StateData = MouseMessage
+  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
+instance Participant Keyboard where
-  type Mesg Keyboard StateData = KeyboardMessage
+  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
+instance Participant Joystick where
-  type Mesg Joystick StateData = JoystickMessage
+  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
+        } :: AffectionConfig StateData
-        , canvasSize = Nothing
-        , loadState = load
-        , preLoop = pre
-        , eventLoop = handle
-        , updateLoop = update
-        , drawLoop = draw
-        , cleanUp = clean
-        }
   withAffection conf
 
 load :: IO StateData
@@ -137,49 +118,45 @@ load =
     <*> (Keyboard <$> newTVarIO [])
     <*> (Joystick <$> newTVarIO [])
     )
-    <*> return []
+    <*> newMVar []
+    <*> newMVar True
 
-pre :: Affection StateData ()
+pre :: StateData -> Affection ()
-pre = do
+pre sd = do
-  sd <- getAffection
+  _ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd))
-  _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
+  _ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd))
-  _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
+  _ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd))
-  _ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
   return ()
 
-exitOnQ :: KeyboardMessage -> Affection StateData ()
+exitOnQ :: MVar Bool -> KeyboardMessage -> Affection ()
-exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
+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 :: MVar Bool -> WindowMessage -> Affection ()
-exitOnWindowClose wm =
+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 :: MVar [SDL.Joystick] -> JoystickMessage -> Affection ()
-joyConnectDisconnect msg = do
+joyConnectDisconnect mvjs msg = do
   mj <- joystickAutoConnect msg
   when (isJust mj) $ do
-    sd <- getAffection
+    js <- liftIO $ readMVar mvjs
-    putAffection sd
+    void $ liftIO $ swapMVar mvjs (fromJust mj : js)
-      { sdJoys = fromJust mj : sdJoys sd
+  js <- liftIO $ readMVar mvjs
-      }
+  njs <- joystickAutoDisconnect js msg
-  sd <- getAffection
+  liftIO $ putMVar mvjs njs
-  njs <- joystickAutoDisconnect (sdJoys sd) msg
-  putAffection sd
-    { sdJoys = njs
-    }
 
-handle :: [SDL.EventPayload] -> Affection StateData ()
+handle :: StateData -> [SDL.EventPayload] -> Affection ()
-handle es = do
+handle sd es = do
-  (Subsystems a b c d) <- sdSubs <$> getAffection
+  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))

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]