98 lines
2.2 KiB
Haskell
98 lines
2.2 KiB
Haskell
{-# 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
|