better messages with type families

This commit is contained in:
nek0 2017-12-27 17:33:31 +01:00
parent 1700734aa4
commit 616cea5f90
7 changed files with 26 additions and 14 deletions

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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