it builds!

affection.cabal

@@ -69,9 +69,11 @@ library
                      , Affection.MessageBus.Message.Class
                      , Affection.MessageBus.Message.WindowMessage
                      , Affection.MessageBus.Message.KeyboardMessage
+                     , Affection.MessageBus.Message.MouseMessage
                      , Affection.Subsystems.Class
                      , Affection.Subsystems.AffectionWindow
                      , Affection.Subsystems.AffectionKeyboard
+                     , Affection.Subsystems.AffectionMouse
   default-extensions:  OverloadedStrings
 
   -- Modules included in this library but not exported.
@@ -100,6 +102,7 @@ library
                      , bytestring
                      , OpenGL
                      , stm
+                     , uuid
 
 -- executable example00
 --   hs-source-dirs:    examples

src/Affection/MessageBus/Class.hs

@@ -1,33 +1,49 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
-module Affection.MessageBus.Class where
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Affection.MessageBus.Class 
+  ( Participant(..)
+  , genUUID
+  , UUID
+  ) where
 
 import Affection.MessageBus.Message
 import Affection.Types
 
-class (Message m) => Participant prt m where
-  -- | get the outbound 'Channel' of the 'Participant'
-  partChannel
-    :: prt       -- ^ The 'Participant'
-    -> Channel m -- ^ Outbound 'Channel'
+import Control.Monad.IO.Class (liftIO)
 
-  -- | Initialize the 'Participant' with an inbound 'Channel'
-  partInit
-    :: Channel m        -- ^ Inbound 'Channel' the 'Participant' will listen to
-    -> Affection sd prt -- ^ The constructed and initialized 'Participant'
+import Data.UUID
+import Data.UUID.V4
 
-  -- Get the 'Participant' to listen to its inbound 'Channel'
-  partListen
-    :: prt                    -- ^ The 'Participant'
-    -> Affection sd (Maybe m) -- ^ The optional 'Message' peeked from the 'Channel'
+import Affection.Logging
 
-  -- Get the 'Participant' to emit a Message on its outbound 'Channel'
+class (Show m, Message m) => Participant prt m where
+  -- | Function to get the lsit of subscribers from the participant
+  partSubscribers
+    :: prt                         -- ^ the participant
+    -> Affection sd [(m -> Affection sd ())] -- ^ List of Subscriber functions
+
+  -- | Subscribe to the 'Participant''s events
+  partSubscribe
+    :: prt               -- ^ The 'Participant' to subscribe to
+    -> (m -> IO ())      -- ^ What to do in case of a 'Message'
+                         -- (Subscriber function)
+    -> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function
+
+  -- | Unsubscribe a Subscriber function from Participant
+  partUnSubscribe
+    :: prt             -- ^ The 'Participant' to unsubscribe from
+    -> UUID            -- ^ The subscriber function's 'UUID'
+    -> Affection sd ()
+
+  -- | Get the 'Participant' to emit a 'Message' on all of its subscribers
   partEmit
     :: prt             -- ^ The 'Participant'
     -> m               -- ^ The 'Message' to emit
     -> Affection sd ()
+  partEmit p m = do
+    liftIO $ logIO Debug $ "Emitting message: " ++ show m
+    l <- partSubscribers p
+    mapM_ ($ m) l
 
--- data Envelope = Envelope
---   { envFrom    :: (Participant a _) => a
---   , envTo      :: (Participant b _) => b
---   , envMessage :: (Message msg) => msg
---   }
+genUUID :: Affection sd UUID
+genUUID = liftIO $ nextRandom

src/Affection/MessageBus/Message.hs

@@ -5,3 +5,4 @@ module Affection.MessageBus.Message
 import Affection.MessageBus.Message.Class as M
 import Affection.MessageBus.Message.WindowMessage as M
 import Affection.MessageBus.Message.KeyboardMessage as M
+import Affection.MessageBus.Message.MouseMessage as M

src/Affection/MessageBus/Message/KeyboardMessage.hs

@@ -12,7 +12,7 @@ data KeyboardMessage = MsgKeyboardEvent
   , msgKbdKeyMotion :: SDL.InputMotion
   , msgKbdLeyRepeat :: Bool
   , msgKbdKeysym :: SDL.Keysym
-  }
+  } deriving (Show)
 
 instance Message KeyboardMessage where
   msgTime (MsgKeyboardEvent t _ _ _ _) = t

src/Affection/MessageBus/Message/MouseMessage.hs

@@ -0,0 +1,40 @@
+module Affection.MessageBus.Message.MouseMessage where
+
+import Affection.MessageBus.Message.Class
+
+import Data.Word (Word32(..), Word8(..))
+import Data.Int (Int32(..))
+
+import qualified SDL
+
+import Linear (V2(..))
+
+data MouseMessage
+  = MsgMouseMotion
+    { msgMMWhen :: Word32
+    , msgMMWindow :: Maybe SDL.Window
+    , msgMMWhich :: SDL.MouseDevice
+    , msgMMState :: [SDL.MouseButton]
+    , msgMMPos :: V2 Int32
+    , msgMMRelMotion :: V2 Int32
+    }
+  | MsgMouseButton
+    { msgMBWhen :: Word32
+    , msgMBWindow :: Maybe SDL.Window
+    , msgMBWhich :: SDL.MouseDevice
+    , msgMBButton :: SDL.MouseButton
+    , msgMBClicks :: Word8
+    , msgMBPos :: V2 Int32
+    }
+  | MsgMouseWheel
+    { msgMWWhen :: Word32
+    , msgMWWhindow :: Maybe SDL.Window
+    , msgMWWhich :: SDL.MouseDevice
+    , msgMWPos :: V2 Int32
+    , msgMWDIrection :: SDL.MouseScrollDirection
+    }
+
+instance Message MouseMessage where
+  msgTime (MsgMouseMotion t _ _ _ _ _) = t
+  msgTime (MsgMouseButton t _ _ _ _ _) = t
+  msgTime (MsgMouseWheel t _ _ _ _) = t

src/Affection/MessageBus/Message/WindowMessage.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE RankNTypes #-}
 module Affection.MessageBus.Message.WindowMessage where
 
 import Affection.MessageBus.Message.Class
@@ -70,6 +69,7 @@ data WindowMessage
     { msgWCWhen :: Word32
     , msgWCWindow :: SDL.Window
     }
+  deriving (Show)
 
 instance Message WindowMessage where
   -- msgTime (MsgEngineReady t)   = t

src/Affection/MessageBus/Util.hs

@@ -1,31 +1,3 @@
 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
-newBroadcastChannel :: (Message msg) => IO (Channel msg)
-newBroadcastChannel = atomically $ Channel <$> newBroadcastTChan
-
--- | Duplicate a broadcast channel, so it can be accessed by subsystems
-dupChannel :: (Message msg)
-  => Channel msg      -- ^ Original 'Channel'
-  -> IO (Channel msg) -- ^ 'Channel' duplicate
-dupChannel (Channel c) = atomically $ Channel <$> dupTChan c
-
--- | Try to read a 'Channel' wihtout deleting the message. Returns 'Nothing' on
--- an empty 'Channel'
-tryPeekChannel :: (Message msg)
-  => Channel msg    -- ^ Channel to read from
-  -> IO (Maybe msg) -- ^ Resulting message (or not)
-tryPeekChannel (Channel c) = atomically $ tryPeekTChan c
-
--- | Write a message to a 'Channel' and thus broadcast it to all connected
--- subsystems
-writeChannel :: (Message msg)
-  => Channel msg -- ^ 'Channel' to write to
-  -> msg         -- ^ The Message to emit
-  -> IO ()
-writeChannel (Channel c) m = atomically $ writeTChan c m
+-- zuru zuru

src/Affection/Subsystems/AffectionKeyboard.hs

@@ -6,26 +6,27 @@ import Affection.Subsystems.Class
 import Affection.Types
 
 import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.STM as STM
 
 import qualified SDL
 
 data AffectionKeyboard = AffectionKeyboard
-  { keyboardInChannel :: Channel KeyboardMessage
-  , keyboardOutChannel :: Channel KeyboardMessage
+  { keyboardSubscribers :: TVar [(UUID, KeyboardMessage -> IO ())]
   }
 
 instance Participant AffectionKeyboard KeyboardMessage where
-  partChannel = keyboardOutChannel
+  partSubscribe p funct = do
+    uuid <- genUUID
+    liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :)
+    return uuid
 
-  partInit ichan = do
-    ochan <- liftIO $ newBroadcastChannel
-    return $ AffectionKeyboard ichan ochan
+  partUnSubscribe p uuid =
+    liftIO $ atomically $ modifyTVar' (keyboardSubscribers p)
+      (filter (\(u, _) -> u /= uuid))
 
-  partListen p =
-    liftIO $ tryPeekChannel (keyboardInChannel p)
-
-  partEmit p m =
-    liftIO $ writeChannel (keyboardOutChannel p) m
+  partSubscribers p = do
+    subTups <- liftIO $ readTVarIO $ keyboardSubscribers p
+    return $ map snd subTups
 
 instance SDLSubsystem AffectionKeyboard KeyboardMessage where
   consumeSDLEvents ak evs = doConsume evs

src/Affection/Subsystems/AffectionMouse.hs

@@ -0,0 +1,64 @@
+module Affection.Subsystems.AffectionMouse where
+
+import Affection.MessageBus
+import Affection.Subsystem.Class
+import Affection.Types
+
+import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.STM
+
+import qualified SDL
+
+data AffectionMouse = AffectionMouse
+  { mouseSubscribers :: TVar (UUID, MouseMessage -> IO ())
+  }
+
+instance Participant AffectionMouse MouseMessage where
+  partSubscribe p funct = do
+    uuid <- genUUID
+    liftIO $ atmoically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :)
+    return uuid
+
+  partUnSubscribe p uuid =
+    liftIO $ atomically $ modifyTVar' (mouseSubscribers p)
+      (filter (\(u, _) -> u /= uuid))
+
+  partSubscribers p =
+    subTups <- liftIO $ readTVarIO $ mouseSubscribers p
+    return $ map snd subTups
+
+instance SDLSubsystem AffectionMouse where
+  consumeSDLEvents am evs = doComsume evs
+    where
+      doConsume [] = return []
+      doConsume (e:es) = case SDL.EventPayload e of
+        SDL.MouseMotionEvent dat -> do
+          partEmit am (MsgMouseMotion
+            (SDL.eventTimestamp dat)
+            (SDL.mouseMotionEventWindow dat)
+            (SDL.mouseMotionEventWhich dat)
+            (SDL.mouseMotionEventState dat)
+            (SDL.mouseMotionEventPos dat)
+            (SDL.mouseMotionEventRelMotion dat)
+            )
+          doComsume es
+        SDL.MouseButtonEvent dat -> do
+          partEmit am (MsgMouseButton
+            (SDL.eventTimestamp e)
+            (SDL.mouseButtonEventWindow dat)
+            (SDL.mouseButtonEventWhich dat)
+            (SDL.mouseButtonEventButton dat)
+            (SDL.mouseButtonEventClicks dat)
+            (SDL.mouseButtonEventPos dat)
+            )
+          doConsume es
+        SDL.MouseWheelEvent dat -> do
+          partEmit am (MsgMouseWheel
+            (SDL.eventTimestamp e)
+            (SDL.mouseWheelEventWindow dat)
+            (SDL.mouseWheelEvntWhich dat)
+            (SDL.mouseWheelEventPos dat)
+            (SDL.mouseWheelEventDirection dat)
+            )
+          doConsume es
+        _ -> fmap (e :) (doComsume es)

src/Affection/Subsystems/AffectionWindow.hs

@@ -1,34 +1,32 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 module Affection.Subsystems.AffectionWindow where
 
+import Affection.Types
 import Affection.MessageBus
 import Affection.Subsystems.Class
-import Affection.Types
 
+import Control.Concurrent.STM as STM
 import Control.Monad.IO.Class (liftIO)
 
 import qualified SDL
 
-data AffectionWindow = AffectionWindow
-  { windowInChannel :: Channel WindowMessage
-  , windowOutChannel :: Channel WindowMessage
+data AffectionWindow sd = AffectionWindow
+  { windowSubscribers :: TVar [(UUID, WindowMessage -> Affection sd ())]
   }
 
 instance Participant AffectionWindow WindowMessage where
-  partChannel = windowOutChannel
+  partSubscribe p funct = do
+    uuid <- genUUID
+    liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :)
+    return uuid
 
-  partInit ichan = do
-    ochan <- liftIO $ newBroadcastChannel
-    return $ AffectionWindow
-      { windowOutChannel = ochan
-      , windowInChannel = ichan
-      }
+  partUnSubscribe p uuid =
+    liftIO $ atomically $ modifyTVar' (windowSubscribers p)
+      (filter (\(u, _) -> u /= uuid))
 
-  partListen p =
-    liftIO $ tryPeekChannel (windowInChannel p)
-
-  partEmit p message =
-    liftIO $ writeChannel (windowOutChannel p) message
+  partSubscribers p = do
+    subTups <- liftIO $ readTVarIO $ windowSubscribers p
+    return $ map snd subTups
 
 instance SDLSubsystem AffectionWindow WindowMessage where
   consumeSDLEvents aw evs = doConsume evs

src/Affection/Types.hs

@@ -42,7 +42,6 @@ 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
@@ -232,5 +231,3 @@ 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)