{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Types.UserData where import Affection import qualified SDL import Control.Concurrent.STM import NanoVG hiding (V2(..), V3(..)) import qualified Data.Map.Strict as M import Data.Text (Text(..)) import Data.Ecstasy import Linear data UserData = UserData { state :: State , subsystems :: Subsystems , assetImages :: M.Map ImgId Image , nano :: Context , uuid :: [UUID] , world :: Entity 'WorldOf } data State = Menu | Test data ImgId = ImgFloor data Direction = N | W | S | E | NW | SW | NE | SE data Entity f = Entity { pos :: Component f 'Field (V2 Float) , vel :: Component f 'Field (V2 Float) , rot :: Component f 'Field Direction } deriving (Generic) data Subsystems = Subsystems { subWindow :: Window , subMouse :: Mouse } newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData())]) newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) instance Participant Window UserData where type Mesg Window UserData = WindowMessage partSubscribers (Window t) = generalSubscribers t partSubscribe (Window t) = generalSubscribe t partUnSubscribe (Window t) = generalUnSubscribe t instance SDLSubsystem Window UserData where consumeSDLEvents = consumeSDLWindowEvents instance Participant Mouse UserData where type Mesg Mouse UserData = MouseMessage partSubscribers (Mouse t) = generalSubscribers t partSubscribe (Mouse t) = generalSubscribe t partUnSubscribe (Mouse t) = generalUnSubscribe t instance SDLSubsystem Mouse UserData where consumeSDLEvents = consumeSDLMouseEvents 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 uuid <- genUUID liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) return uuid generalUnSubscribe :: TVar [(UUID, msg -> Affection UserData ())] -> UUID -> Affection UserData () generalUnSubscribe t uuid = liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) where filterMsg (u, _) p = u /= p