define UserData

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

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