diff --git a/app/Types/UserData.hs b/app/Types/UserData.hs index 945ca67..8d9668c 100644 --- a/app/Types/UserData.hs +++ b/app/Types/UserData.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module Types.UserData where import Affection @@ -8,7 +10,68 @@ import qualified SDL import qualified Data.Map.Strict as M +import Codec.Picture + data UserData = UserData - { udSubsystems = Subsystems - , udAssetImages = M.Map ImgId Image + { 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 diff --git a/canvas.cabal b/canvas.cabal index 9b1e8a9..df96bef 100644 --- a/canvas.cabal +++ b/canvas.cabal @@ -17,7 +17,8 @@ extra-source-files: CHANGELOG.md executable canvas main-is: Main.hs - -- other-modules: + other-modules: Types + Types.UserData -- other-extensions: build-depends: base ^>=4.12.0.0 , affection @@ -26,5 +27,6 @@ executable canvas , JuicyPixels , JuicyPixels-extra , stm + , containers hs-source-dirs: app default-language: Haskell2010