classy messup

affection.cabal

@@ -44,6 +44,8 @@ library
                      , Affection.MessageBus.Util
                      , Affection.MessageBus.Class
                      , Affection.MessageBus.Message
+                     , Affection.Subsystems.Class
+                     , Affection.Subsystems.AffectionWindow
   default-extensions:  OverloadedStrings
 
   -- Modules included in this library but not exported.

src/Affection.hs

@@ -40,7 +40,7 @@ import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
 
 -- | Main function which bootstraps everything else.
 withAffection
-  :: AffectionConfig us -- ^ Configuration of the Game and its engine.
+  :: AffectionConfig us msg -- ^ Configuration of the Game and its engine.
   -> IO ()
 withAffection AffectionConfig{..} = do
   -- intialiaze SDL

src/Affection/MessageBus/Class.hs

@@ -1,16 +1,14 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 module Affection.MessageBus.Class where
 
-import Control.Concurrent.STM as STM
-
 import Affection.MessageBus.Message
-
-newtype (Message msg) => Channel msg = Channel (TChan msg)
+import Affection.Types
 
 class (Message msg) => Participant prt msg where
   partChannel        :: prt -> Channel msg
 
-  -- partConnectChannel :: prt -> Channel msg -> IO ()
+  partInit           :: Affection sd msg prt
 
   partListen         :: prt -> IO (Maybe msg)
 

src/Affection/MessageBus/Util.hs

@@ -2,6 +2,7 @@ module Affection.MessageBus.Util where
 
 import Affection.MessageBus.Class
 import Affection.MessageBus.Message
+import Affection.Types
 import Control.Concurrent.STM as STM
 
 -- | Build a new broadcast channel

src/Affection/MouseInteractable.hs

@@ -17,7 +17,7 @@ class MouseClickable a us where
     -> (Int, Int)      -- The coordinates of the click
     -> SDL.InputMotion -- The 'SDL.InputMotion' of the click
     -> Int             -- The number of clicks
-    -> Affection us ()
+    -> Affection us msg ()
 
 -- | A helper function that checks wether provided clickables have been clicked.
 -- This function does not consume provided events, but passes them on.
@@ -25,7 +25,7 @@ handleMouseClicks
   :: (Foldable t, MouseClickable clickable us)
   => SDL.EventPayload              -- ^ Piped event in
   -> t clickable                   -- ^ 'MouseClickable' elemt to be checked
-  -> Affection us SDL.EventPayload -- ^ Unaltered event
+  -> Affection us msg SDL.EventPayload -- ^ Unaltered event
 handleMouseClicks e clickables =
   case e of
     SDL.MouseButtonEvent dat -> do

src/Affection/StateMachine.hs

@@ -7,8 +7,8 @@ import Affection.Types
 import qualified SDL
 
 class StateMachine a us where
-  smLoad   :: a -> Affection us ()
-  smUpdate :: a -> Double -> Affection us ()
-  smEvent  :: a -> SDL.EventPayload -> Affection us ()
-  smDraw   :: a -> Affection us ()
-  smClean  :: a -> Affection us ()
+  smLoad   :: a -> Affection us msg ()
+  smUpdate :: a -> Double -> Affection us msg ()
+  smEvent  :: a -> SDL.EventPayload -> Affection us msg ()
+  smDraw   :: a -> Affection us msg ()
+  smClean  :: a -> Affection us msg ()

src/Affection/Subsystems/AffectionWindow.hs

@@ -1,17 +1,31 @@
-module Affection.Subsystem.AffectionWindow where
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Affection.Subsystems.AffectionWindow where
 
 import Affection.MessageBus
 import Affection.Subsystems.Class
+import Affection.Types
+
+import Control.Monad.State.Class (get)
+import Control.Monad.IO.Class (liftIO)
 
 import qualified SDL
 
-data AffectionWindow = AffectionWindow
+data AffectionWindow msg = AffectionWindow
   { windowChannel :: Channel msg
   }
 
-instance Participant AffectionWindow where
+instance Participant (AffectionWindow (SystemMessage m)) (SystemMessage m) where
   partChannel = windowChannel
 
+  partInit = do
+    ad <- get
+    nchan <- liftIO $ dupChannel $ messageChannel ad
+    return $ AffectionWindow
+      { windowChannel = nchan
+      }
+
   partListen p = do
     let chan = partChannel p
     mmsg <- tryPeekChannel chan
@@ -21,50 +35,50 @@ instance Participant AffectionWindow where
     let chan = partChannel p
     writeChannel chan m
 
-instance Subsystem AffectionWindow where
+instance Subsystem (AffectionWindow (SystemMessage m)) (SystemMessage m) where
   consumeEvents aw evs = doConsume evs
     where
       doConsume (e:es) = case SDL.eventPayload e of
-        SDL.WindowShownEvent (SDL.WindowShownEventData window) = do
-          partEmit aw (MsgWindowShown (SDL.eventTiemstamp e) window)
+        SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
+          partEmit aw (MsgWindowShown (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) = do
-          partEmit aw (MsgWindowHidden (SDL.eventTimestemp e) window)
+        SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
+          partEmit aw (MsgWindowHidden (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowExposedEvent (SDL.WindowExposedEventData window) = do
+        SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
           partEmit aw (MsgWindowExposed (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) = do
-          partEmit aw (MsgWindowMoved (SDL.EventTimestamp e) window newPos)
+        SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
+          partEmit aw (MsgWindowMoved (SDL.eventTimestamp e) window newPos)
           doConsume es
-        SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) = do
-          partEmit aw (MsgWindowResized (SDL.EventTimestamp e) window newSize)
+        SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
+          partEmit aw (MsgWindowResized (SDL.eventTimestamp e) window newSize)
           doConsume es
-        SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) = do
-          partEmit aw (MsgWindowSizeChanged (SDL.EventTimestamp e) window)
+        SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
+          partEmit aw (MsgWindowSizeChanged (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) = do
-          partEmit aw (MsgWindowMinimized (SDL.eventTimestemp e) window)
+        SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
+          partEmit aw (MsgWindowMinimized (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) = do
-          partEmit aw (MsgWindowMaximized (SDL.eventTimestemp e) window)
+        SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
+          partEmit aw (MsgWindowMaximized (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) = do
-          partEmit aw (MsgWindowRestored (SDL.eventTimestemp e) window)
+        SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
+          partEmit aw (MsgWindowRestored (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) = do
-          partEmit aw (MsgWindowGainedMouseFocus (SDL.eventTimestemp e) window)
+        SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
+          partEmit aw (MsgWindowGainedMouseFocus (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) = do
-          partEmit aw (MsgWindowLostMouseFocus (SDL.eventTimestemp e) window)
+        SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
+          partEmit aw (MsgWindowLostMouseFocus (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) = do
-          partEmit aw (MsgWindowGainedKeyboardFocus (SDL.eventTimestemp e) window)
+        SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
+          partEmit aw (MsgWindowGainedKeyboardFocus (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) = do
-          partEmit aw (MsgWindowLostKeyboardFocus (SDL.eventTimestemp e) window)
+        SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
+          partEmit aw (MsgWindowLostKeyboardFocus (SDL.eventTimestamp e) window)
           doConsume es
-        SDL.WindowClosed (SDL.WindowClosedEventData window) = do
-          partEmit aw (MsgWindowClosed (SDL.eventTimestemp e) window)
+        SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
+          partEmit aw (MsgWindowClosed (SDL.eventTimestamp e) window)
           doConsume es
-        _ = fmap (e :) (doConsume es)
+        _ -> fmap (e :) (doConsume es)

src/Affection/Subsystems/Class.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 module Affection.Subsystems.Class where
 
-import Affection.MessageBus.Class
+import Affection.MessageBus
 
 import qualified SDL
 
-class (Participant s) => Subsystem s where
+class (Message m, Participant s m) => Subsystem s m where
   consumeEvents :: s -> [SDL.Event] -> IO [SDL.Event]

src/Affection/Types.hs

@@ -42,6 +42,7 @@ import Data.Map.Strict as M
 import Control.Monad.IO.Class
 import Control.Monad.State
 import qualified Control.Monad.Parallel as MP
+import Control.Concurrent.STM as STM
 
 import System.Clock (TimeSpec)
 -- import Control.Monad.Reader
@@ -50,8 +51,10 @@ import System.Clock (TimeSpec)
 
 import Foreign.Ptr (Ptr)
 
+import Affection.MessageBus.Message
+
 -- | Configuration for the aplication. needed at startup.
-data AffectionConfig us = AffectionConfig
+data AffectionConfig us msg = AffectionConfig
   { initComponents :: InitComponents
       -- ^ SDL components to initialize at startup
   , windowTitle    :: T.Text
@@ -62,13 +65,13 @@ data AffectionConfig us = AffectionConfig
       -- ^ size of the texture canvas
   , initScreenMode :: SDL.WindowMode
       -- ^ Window mode to start in
-  , preLoop        :: Affection us ()
+  , preLoop        :: Affection us msg ()
       -- ^ Actions to be performed, before loop starts
-  , eventLoop      :: SDL.EventPayload -> Affection us ()
+  , eventLoop      :: SDL.EventPayload -> Affection us msg ()
       -- ^ Main update function. Takes fractions of a second as input.
-  , updateLoop     :: Double -> Affection us ()
+  , updateLoop     :: Double -> Affection us msg ()
       -- ^ Main update function. Takes fractions of a second as input.
-  , drawLoop       :: Affection us ()
+  , drawLoop       :: Affection us msg ()
       -- ^ Function for updating graphics.
   , loadState      :: IO us
       -- ^ Provide your own load function to create this data.
@@ -82,7 +85,7 @@ data InitComponents
   | Only [SDL.InitFlag]
 
 -- | Main type for defining the look, feel and action of the whole application.
-data AffectionData us = AffectionData
+data AffectionData us msg = AffectionData
   -- { affectionConfig :: AffectionConfig us -- ^ Application configuration.
   { quitEvent       :: Bool               -- ^ Loop breaker.
   , userState       :: us                 -- ^ State data provided by user
@@ -100,6 +103,7 @@ data AffectionData us = AffectionData
   , deltaTime       :: Double             -- ^ Elapsed time in seconds since last tick
   , sysTime         :: TimeSpec           -- ^ System time (NOT the time on the clock)
   , pausedTime      :: Bool               -- ^ Should the update loop be executed?
+  , messageChannel  :: Channel msg        -- ^ The main broadcast channel to duplicate all others from
   }
 
 -- -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated
@@ -127,7 +131,7 @@ newtype AffectionState us m a = AffectionState
 
 instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m)
 
-type Affection us a = AffectionState (AffectionData us) IO a
+type Affection us msg a = AffectionState (AffectionData us msg) IO a
 
 -- -- | Inner 'StateT' monad of Affection
 -- type AffectionInner us od a = StateT (AffectionState us od) IO a
@@ -228,3 +232,5 @@ type Angle = Double
 --   { partStorLatest :: Maybe Particle -- ^ The particle stored last
 --   , partStorList   :: [Particle]     -- ^ List of particles in ascending order of remaining lifetime
 --   }
+
+newtype (Message msg) => Channel msg = Channel (TChan msg)

src/Affection/Util.hs

@@ -10,12 +10,12 @@ import System.Clock
 import Control.Monad.State
 
 -- Prehandle SDL events in case any window events occur
-preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload]
+preHandleEvents :: [SDL.Event] -> Affection us msg [SDL.EventPayload]
 preHandleEvents evs =
   return $ map SDL.eventPayload evs
 
 -- | Return the userstate to the user
-getAffection :: Affection us us
+getAffection :: Affection us msg us
 getAffection = do
   ad <- get
   return $ userState ad
@@ -23,7 +23,7 @@ getAffection = do
 -- | Put altered user state back
 putAffection
   :: us              -- User state
-  -> Affection us ()
+  -> Affection us msg ()
 putAffection us = do
   ad <- get
   put $ ad
@@ -36,20 +36,20 @@ delaySec
 delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
 
 -- | Get time since start but always the same in the current tick.
-getElapsedTime :: Affection us Double
+getElapsedTime :: Affection us msg Double
 getElapsedTime =
   elapsedTime <$> get
 
-getDelta :: Affection us Double
+getDelta :: Affection us msg Double
 getDelta =
   deltaTime <$> get
 
-quit :: Affection us ()
+quit :: Affection us msg ()
 quit = do
   ad <- get
   put $ ad { quitEvent = True }
 
-toggleScreen :: Affection us ()
+toggleScreen :: Affection us msg ()
 toggleScreen = do
   ad <- get
   newMode <- case screenMode ad of