tracer/src/Types/UserData.hs

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

module Types.UserData where

import Affection

import Control.Concurrent.STM

import qualified SDL

import NanoVG hiding (V2(..), V3(..))

import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Ecstasy

import Control.Concurrent.MVar

import Types.StateData
import Types.ImgId
import Types.FontId
import Types.Animation
import Types.Entity

data UserData = UserData
  { state           :: State
  , subsystems      :: Subsystems
  , assetImages     :: M.Map ImgId Image
  , assetFonts      :: M.Map FontId T.Text
  , assetAnimations :: M.Map AnimId Animation
  , nano            :: Context
  , uuid            :: [UUID]
  , worldState      :: SystemState Entity (AffectionState (AffectionData UserData) IO)
  , stateData       :: StateData
  , stateMVar       :: MVar
    ( SystemState Entity (AffectionState (AffectionData UserData) IO)
    , StateData
    )
  , stateProgress   :: MVar (Float, T.Text)
  , threadContext   :: Maybe SDL.GLContext
  , window          :: Maybe SDL.Window
  }

data State
  = Load
  | Main SubMain
  deriving (Eq)

data SubMain
  = WorldMap
  | MindMap
  deriving (Eq)

data Subsystems = Subsystems
  { subWindow   :: SubWindow
  , subMouse    :: SubMouse
  , subkeyboard :: SubKeyboard
  , subJoypad   :: SubJoypad
  }

newtype SubWindow   = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData())])
newtype SubMouse    = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
newtype SubJoypad   = SubJoypad (TVar [(UUID, JoystickMessage -> Affection UserData ())])

instance Participant SubWindow UserData where
  type Mesg SubWindow UserData = WindowMessage

  partSubscribers (SubWindow t) = generalSubscribers t

  partSubscribe (SubWindow t) = generalSubscribe t

  partUnSubscribe (SubWindow t) = generalUnSubscribe t

instance SDLSubsystem SubWindow UserData where
  consumeSDLEvents = consumeSDLWindowEvents

instance Participant SubMouse UserData where
  type Mesg SubMouse UserData = MouseMessage

  partSubscribers (SubMouse t) = generalSubscribers t

  partSubscribe (SubMouse t) = generalSubscribe t

  partUnSubscribe (SubMouse t) = generalUnSubscribe t

instance SDLSubsystem SubMouse UserData where
  consumeSDLEvents = consumeSDLMouseEvents

instance Participant SubKeyboard UserData where
  type Mesg SubKeyboard UserData = KeyboardMessage

  partSubscribers (SubKeyboard t) = generalSubscribers t

  partSubscribe (SubKeyboard t) = generalSubscribe t

  partUnSubscribe (SubKeyboard t) = generalUnSubscribe t

instance SDLSubsystem SubKeyboard UserData where
  consumeSDLEvents = consumeSDLKeyboardEvents

instance Participant SubJoypad UserData where
  type Mesg SubJoypad UserData = JoystickMessage

  partSubscribers (SubJoypad t) = generalSubscribers t

  partSubscribe (SubJoypad t) = generalSubscribe t

  partUnSubscribe (SubJoypad t) = generalUnSubscribe t

instance SDLSubsystem SubJoypad UserData where
  consumeSDLEvents = consumeSDLJoystickEvents

generalSubscribers
  :: TVar [(UUID, msg -> Affection UserData ())]
  -> Affection UserData [(msg -> Affection UserData ())]
generalSubscribers t = do
  subTups <- liftIO $ readTVarIO t
  return $ map snd subTups

generalSubscribe
  :: TVar [(UUID, msg -> Affection UserData ())]
  -> (msg -> Affection UserData ())
  -> Affection UserData UUID
generalSubscribe t funct = do
  uu <- genUUID
  liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
  return uu

generalUnSubscribe
  :: TVar [(UUID, msg -> Affection UserData ())]
  -> UUID
  -> Affection UserData ()
generalUnSubscribe t uu =
  liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
  where
    filterMsg (u, _) p = u /= p