canvas/app/Types/UserData.hs

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

import Affection

import Control.Concurrent.STM

import qualified SDL

import qualified Data.Map.Strict as M

import Codec.Picture

data UserData = UserData
  { udSubsystems  :: Subsystems
  , udAssetImages :: M.Map ImgId (Image PixelRGBA8)
  }

type ImgId = 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