canvas/app/Types/UserData.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types.UserData where

import Affection

import qualified Graphics.Rendering.OpenGL as GL

import Control.Concurrent.STM

import qualified SDL

import qualified Data.Map.Strict as M

import Linear

import Codec.Picture

-- internal imports

import Types.Sprite

import Classes.Renderable

data UserData = UserData
  { udSubsystems   :: Subsystems
  , udRenderAssets :: RenderAssets
  }

data RenderAssets = RenderAssets
  { assetSprites :: AssetDetails SpriteRenderObjects SpriteShaderObjects Sprite
  }

data Renderable dat => AssetDetails vo so dat = AssetDetails
  { adVertObj :: vo
  , adShadObj :: so
  , adTextObj :: M.Map AssetId GL.TextureObject
  , adDataObj :: M.Map AssetId [dat]
  }

type AssetId = String

data Subsystems = Subsystems
  { subWindow :: SubWindow
  , subMouse  :: SubMouse
  }

newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])

instance Participant SubWindow where
  type Mesg SubWindow = WindowMessage

  partSubscribers (SubWindow t) = genericSubscribers t

  partSubscribe (SubWindow t) = genericSubscribe t

  partUnSubscribe (SubWindow t) = genericUnSubscribe t

instance SDLSubsystem SubWindow where
  consumeSDLEvents = consumeSDLWindowEvents

instance Participant SubMouse where
  type Mesg SubMouse = MouseMessage

  partSubscribers (SubMouse t) = genericSubscribers t

  partSubscribe (SubMouse t) = genericSubscribe t

  partUnSubscribe (SubMouse t) = genericUnSubscribe t

instance SDLSubsystem SubMouse where
  consumeSDLEvents = consumeSDLMouseEvents

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

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

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