vulkan-tutorial/examples/example00/Main.hs

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

import Affection as A

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

import qualified SDL hiding (Window(..))

import Data.Maybe (isJust, fromJust)

data StateData = StateData
  { sdSubs :: Subsystems
  , sdJoys :: [SDL.Joystick]
  }

data Subsystems = Subsystems
  { subWindow   :: Main.Window
  , subMouse    :: Main.Mouse
  , subKeyboard :: Main.Keyboard
  , 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 ())])

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

  partSubscribers (Window t) = generalSubscribers t

  partSubscribe (Window t) = generalSubscribe t

  partUnSubscribe (Window t) = generalUnSubscribe t

instance SDLSubsystem Main.Window StateData where
  consumeSDLEvents = consumeSDLWindowEvents

instance Participant Mouse StateData where
  type Mesg Mouse StateData = MouseMessage

  partSubscribers (Mouse t) = generalSubscribers t

  partSubscribe (Mouse t) = generalSubscribe t

  partUnSubscribe (Mouse t) = generalUnSubscribe t

instance SDLSubsystem Mouse StateData where
  consumeSDLEvents = consumeSDLMouseEvents

instance Participant Keyboard StateData where
  type Mesg Keyboard StateData = KeyboardMessage

  partSubscribers (Keyboard t) = generalSubscribers t

  partSubscribe (Keyboard t) = generalSubscribe t

  partUnSubscribe (Keyboard t) = generalUnSubscribe t

instance SDLSubsystem Keyboard StateData where
  consumeSDLEvents = consumeSDLKeyboardEvents

instance Participant Joystick StateData where
  type Mesg Joystick StateData = JoystickMessage

  partSubscribers (Joystick t) = generalSubscribers t

  partSubscribe (Joystick t) = generalSubscribe t

  partUnSubscribe (Joystick t) = generalUnSubscribe t

instance SDLSubsystem Joystick StateData where
  consumeSDLEvents = consumeSDLJoystickEvents

main :: IO ()
main = do
  logIO Debug "Starting"
  let conf = AffectionConfig
        { initComponents = All
        , windowTitle = "affection: example00"
        , windowConfigs =
          [
          ( 0
          , 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 =
  StateData <$> (Subsystems
    <$> (Window <$> newTVarIO [])
    <*> (Mouse <$> newTVarIO [])
    <*> (Keyboard <$> newTVarIO [])
    <*> (Joystick <$> newTVarIO [])
    )
    <*> return []

pre :: Affection StateData ()
pre = do
  sd <- getAffection
  _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
  _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
  _ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
  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 ()

joyConnectDisconnect :: JoystickMessage -> Affection StateData ()
joyConnectDisconnect 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
    }

handle :: [SDL.EventPayload] -> Affection StateData ()
handle es = do
  (Subsystems a b c d) <- sdSubs <$> getAffection
  leftovers <- consumeSDLEvents a
    =<< consumeSDLEvents b
    =<< consumeSDLEvents c
    =<< consumeSDLEvents d es
  mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers

update _ = return ()

draw = return ()

clean _ = return ()