affection/examples/example00/Main.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

import Affection
import qualified SDL

import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)

newtype StateData = StateData
  { sdSubs :: Subsystems
  }

data Subsystems = Subsystems
  { subWindow :: Window
  , subMouse :: Mouse
  , subKeyboard :: Keyboard
  }

newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> 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
  type Mesg Window StateData = WindowMessage

  partSubscribers (Window t) = do
    subTups <- liftIO $ readTVarIO t
    return $ map snd subTups

  partSubscribe (Window t) = generalSubscribe t

  partUnSubscribe (Window t) uuid =
    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))

instance SDLSubsystem Window StateData where
  consumeSDLEvents = consumeSDLWindowEvents

instance Participant Mouse StateData where
  type Mesg Mouse StateData = MouseMessage

  partSubscribers (Mouse t) = do
    subTups <- liftIO $ readTVarIO t
    return $ map snd subTups

  partSubscribe (Mouse t) = generalSubscribe t

  partUnSubscribe (Mouse t) uuid =
    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))

instance SDLSubsystem Mouse StateData where
  consumeSDLEvents = consumeSDLMouseEvents

instance Participant Keyboard StateData where
  type Mesg Keyboard StateData = KeyboardMessage

  partSubscribers (Keyboard t) = do
    subTups <- liftIO $ readTVarIO t
    return $ map snd subTups

  partSubscribe (Keyboard t) = generalSubscribe t

  partUnSubscribe (Keyboard t) uuid =
    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))

instance SDLSubsystem Keyboard StateData where
  consumeSDLEvents = consumeSDLKeyboardEvents

main :: IO ()
main = do
  logIO Debug "Starting"
  let conf = AffectionConfig
        { initComponents = All
        , windowTitle = "affection: example00"
        , windowConfig = SDL.defaultWindow
          { SDL.windowOpenGL = Just SDL.defaultOpenGL
            { SDL.glProfile = SDL.Core SDL.Normal 3 3
            }
          }
        , initScreenMode = SDL.Windowed
        , canvasSize = Nothing
        , loadState = load
        , preLoop = pre
        , eventLoop = handle
        , updateLoop = update
        , drawLoop = draw
        , cleanUp = clean
        }
  withAffection conf

load :: IO StateData
load = do
  empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())])
  empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
  return $ StateData $ Subsystems
    (Window empty1)
    (Mouse empty2)
    (Keyboard empty3)

pre :: Affection StateData ()
pre = do
  sd <- getAffection
  _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
  _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
  return ()

exitOnQ :: KeyboardMessage -> Affection StateData ()
exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
  case SDL.keysymKeycode sym of
    SDL.KeycodeQ -> do
      liftIO $ logIO Debug "Yo dog I heard..."
      quit
    _ -> return ()

exitOnWindowClose :: WindowMessage -> Affection StateData ()
exitOnWindowClose wm =
  case wm of
    MsgWindowClose _ _ -> do
      liftIO $ logIO Debug "I heard another one..."
      quit
    _ -> return ()

handle :: [SDL.EventPayload] -> Affection StateData ()
handle es = do
  (Subsystems a b c) <- sdSubs <$> getAffection
  _ <- consumeSDLEvents a es
  _ <- consumeSDLEvents b es
  _ <- consumeSDLEvents c es
  return ()

update _ = return ()

draw = return ()

clean _ = return ()