{-# 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 UserData ())]) newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) instance Participant SubWindow UserData where type Mesg SubWindow UserData = WindowMessage partSubscribers (SubWindow t) = genericSubscribers t partSubscribe (SubWindow t) = genericSubscribe t partUnSubscribe (SubWindow t) = genericUnSubscribe t instance SDLSubsystem SubWindow UserData where consumeSDLEvents = consumeSDLWindowEvents instance Participant SubMouse UserData where type Mesg SubMouse UserData = MouseMessage partSubscribers (SubMouse t) = genericSubscribers t partSubscribe (SubMouse t) = genericSubscribe t partUnSubscribe (SubMouse t) = genericUnSubscribe t instance SDLSubsystem SubMouse UserData where consumeSDLEvents = consumeSDLMouseEvents genericSubscribers :: TVar [(UUID, msg -> Affection UserData ())] -> Affection UserData [(msg -> Affection UserData ())] genericSubscribers t = do subTups <- liftIO $ readTVarIO t return $ map snd subTups genericSubscribe :: TVar [(UUID, msg -> Affection UserData ())] -> (msg -> Affection UserData ()) -> Affection UserData UUID genericSubscribe t funct = do uu <- genUUID liftIO $ atomically $ modifyTVar' t ((uu, funct) :) return uu genericUnSubscribe :: TVar [(UUID, msg -> Affection UserData ())] -> UUID -> Affection UserData () genericUnSubscribe t uu = liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu)) where filterMsg (u, _) p = u /= p