Merge pull request #7 from nek0/mesg

better messages with type families

src/Affection/MessageBus/Class.hs

@@ -7,7 +7,7 @@ module Affection.MessageBus.Class
   ( Participant(..)
   , genUUID
   , UUID
-  , MsgId(..)
+  -- , MsgId(..)
   ) where
 
 import Affection.MessageBus.Message
@@ -20,30 +20,31 @@ import Data.UUID.V4
 
 import Affection.Logging
 
-class (Message msg, Show msg) => Participant prt msg us where
+class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where
+  type Mesg prt us :: *
 
   -- | Function to get the list of subscribers from the participant
   partSubscribers
     :: prt
     -- ^ the 'Participant''s subscriber storage
-    -> Affection us [msg -> Affection us ()]
+    -> Affection us [Mesg prt us -> Affection us ()]
     -- ^ List of Subscriber functions
 
   -- | Subscribe to the 'Participant''s events
   partSubscribe
     :: prt
     -- ^ The 'Participant''s subscriber storage
-    -> (msg -> Affection us ())
+    -> (Mesg prt us -> Affection us ())
     -- ^ What to do in case of a 'Message'
     -- (Subscriber function)
-    -> Affection us (MsgId msg)
+    -> Affection us UUID
     -- ^ 'UUID' of the registered subscriber Function
 
   -- | Unsubscribe a Subscriber function from Participant
   partUnSubscribe
     :: prt
     -- ^ The 'Participant''s subscriber storage to unsubscribe from
-    -> (MsgId msg)
+    -> UUID
     -- ^ The subscriber function's 'UUID'
     -> Affection us ()
 
@@ -51,7 +52,7 @@ class (Message msg, Show msg) => Participant prt msg us where
   partEmit
     :: prt
     -- ^ The 'Participant''s subscriber storage
-    -> msg
+    -> Mesg prt us
     -- ^ The 'Message' to emit
     -> Affection us ()
   partEmit p m = do
@@ -63,4 +64,4 @@ class (Message msg, Show msg) => Participant prt msg us where
 genUUID :: Affection us UUID
 genUUID = liftIO nextRandom
 
-data MsgId msg = (Message msg, Show msg) => MsgId UUID msg
+-- data MsgId msg = (Message msg, Show msg) => MsgId UUID msg

src/Affection/MessageBus/Message/KeyboardMessage.hs

@@ -12,7 +12,6 @@ data KeyboardMessage
     , msgKbdKeyRepeat :: Bool
     , msgKbdKeysym :: SDL.Keysym
     }
-  | MsgKeyboardEmptyEvent
   deriving (Show)
 
 instance Message KeyboardMessage where

src/Affection/MessageBus/Message/MouseMessage.hs

@@ -33,7 +33,6 @@ data MouseMessage
     , msgMWPos :: V2 Int32
     , msgMWDIrection :: SDL.MouseScrollDirection
     }
-  | MsgMouseEmptyEvent
   deriving (Show)
 
 instance Message MouseMessage where

src/Affection/MessageBus/Message/WindowMessage.hs

@@ -68,7 +68,6 @@ data WindowMessage
     { msgWCWhen :: Double
     , msgWCWindow :: SDL.Window
     }
-  | MsgWindowEmptyEvent
   deriving (Show)
 
 instance Message WindowMessage where

src/Affection/Subsystems/AffectionKeyboard.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 module Affection.Subsystems.AffectionKeyboard where
 
 import Affection.Types
@@ -13,7 +15,7 @@ import Control.Monad.IO.Class (liftIO)
 import qualified SDL
 
 consumeSDLKeyboardEvents
-  :: (Participant ak KeyboardMessage us)
+  :: forall ak us. (Participant ak us, Mesg ak us ~ KeyboardMessage)
   => ak
   -> [SDL.EventPayload]
   -> Affection us [SDL.EventPayload]

src/Affection/Subsystems/AffectionMouse.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 module Affection.Subsystems.AffectionMouse where
 
 import Affection.MessageBus
@@ -15,12 +17,15 @@ import Linear.Affine (unP)
 import qualified SDL
 
 consumeSDLMouseEvents
-  :: (Participant am MouseMessage us)
+  :: forall am us. (Participant am us, Mesg am us ~ MouseMessage)
   => am
   -> [SDL.EventPayload]
   -> Affection us [SDL.EventPayload]
 consumeSDLMouseEvents am = doConsume
   where
+    doConsume
+      :: [SDL.EventPayload]
+      -> Affection us [SDL.EventPayload]
     doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime

src/Affection/Subsystems/AffectionWindow.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 module Affection.Subsystems.AffectionWindow where
 
 import Affection.Types
@@ -14,12 +17,16 @@ import Control.Monad.IO.Class (liftIO)
 import qualified SDL
 
 consumeSDLWindowEvents
-  :: (Participant aw WindowMessage us)
+  :: forall aw us. (Participant aw us, Mesg aw us ~ WindowMessage)
   => aw
   -> [SDL.EventPayload]
   -> Affection us [SDL.EventPayload]
 consumeSDLWindowEvents aw = doConsume
   where
+    doConsume
+      :: (Mesg aw us ~ WindowMessage)
+      => [SDL.EventPayload]
+      -> Affection us [SDL.EventPayload]
     doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime