{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Main where import Affection as A import Control.Concurrent.STM import Control.Concurrent.MVar import Control.Monad.IO.Class (liftIO) import Control.Monad import qualified SDL hiding (Window(..)) import Data.Maybe (isJust, fromJust) import Data.String data StateData = StateData { sdSubs :: Subsystems , 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 , subKeyboard :: Main.Keyboard , subJoystick :: Main.Joystick } 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 ())]) instance Participant Main.Window where type Mesg Main.Window = WindowMessage partSubscribers (Window t) = generalSubscribers t partSubscribe (Window t) = generalSubscribe t partUnSubscribe (Window t) = generalUnSubscribe t instance SDLSubsystem Main.Window where consumeSDLEvents = consumeSDLWindowEvents instance Participant Mouse where type Mesg Mouse = MouseMessage partSubscribers (Mouse t) = generalSubscribers t partSubscribe (Mouse t) = generalSubscribe t partUnSubscribe (Mouse t) = generalUnSubscribe t instance SDLSubsystem Mouse where consumeSDLEvents = consumeSDLMouseEvents instance Participant Keyboard where type Mesg Keyboard = KeyboardMessage partSubscribers (Keyboard t) = generalSubscribers t partSubscribe (Keyboard t) = generalSubscribe t partUnSubscribe (Keyboard t) = generalUnSubscribe t instance SDLSubsystem Keyboard where consumeSDLEvents = consumeSDLKeyboardEvents instance Participant Joystick where type Mesg Joystick = JoystickMessage partSubscribers (Joystick t) = generalSubscribers t partSubscribe (Joystick t) = generalSubscribe t partUnSubscribe (Joystick t) = generalUnSubscribe t instance SDLSubsystem Joystick where consumeSDLEvents = consumeSDLJoystickEvents main :: IO () main = do logIO Debug "Starting" let conf = AffectionConfig { initComponents = All , windowTitle = "affection: example00" , windowConfigs = [ ( 0 , SDL.defaultWindow { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL { SDL.glProfile = SDL.Core SDL.Normal 3 3 } } , SDL.Windowed ) ] } :: AffectionConfig StateData withAffection conf load :: IO StateData load = StateData <$> (Subsystems <$> (Window <$> newTVarIO []) <*> (Mouse <$> newTVarIO []) <*> (Keyboard <$> newTVarIO []) <*> (Joystick <$> newTVarIO []) ) <*> newMVar [] <*> newMVar True 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 :: MVar Bool -> KeyboardMessage -> Affection () exitOnQ break (MsgKeyboardEvent _ _ _ _ sym) = case SDL.keysymKeycode sym of SDL.KeycodeQ -> do liftIO $ logIO Debug "Yo dog I heard..." void $ liftIO $ swapMVar break False _ -> return () exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection () exitOnWindowClose break wm = case wm of MsgWindowClose _ _ -> do liftIO $ logIO Debug "I heard another one..." void $ liftIO $ swapMVar break False _ -> return () joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection () joyConnectDisconnect mvjs msg = do mj <- joystickAutoConnect msg when (isJust mj) $ do js <- liftIO $ readMVar mvjs void $ liftIO $ swapMVar mvjs (fromJust mj : js) js <- liftIO $ readMVar mvjs njs <- joystickAutoDisconnect js msg liftIO $ putMVar mvjs njs handle :: StateData -> [SDL.EventPayload] -> Affection () handle sd es = do let (Subsystems a b c d) = sdSubs sd leftovers <- consumeSDLEvents a =<< consumeSDLEvents b =<< consumeSDLEvents c =<< consumeSDLEvents d es mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e)) leftovers update _ _ = 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))