From 1bb1af935b7c5b7a2aebb0934a061a9cbc3ca7fc Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 27 Nov 2017 01:43:43 +0100 Subject: [PATCH] defining mesage bus further --- affection.cabal | 1 + src/Affection/MessageBus/Class.hs | 13 +++++++------ src/Affection/MessageBus/Message.hs | 16 +++++++++++++++- src/Affection/MessageBus/Util.hs | 2 +- 4 files changed, 24 insertions(+), 8 deletions(-) diff --git a/affection.cabal b/affection.cabal index 5077048..cf45d46 100644 --- a/affection.cabal +++ b/affection.cabal @@ -68,6 +68,7 @@ library , sdl2 , text , mtl + , time -- , gegl -- , babl , monad-loops diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index fb07942..c02687e 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses #-} module Affection.MessageBus.Class where import Control.Concurrent.STM as STM @@ -6,13 +7,13 @@ import Data.IORef import Affection.MessageBus.Message -type Channel msg = TChan msg +newtype (Message msg) => Channel msg = Channel (TChan msg) -class Participant prt where - partChannel :: (Message msg) => prt -> IORef (Channel msg) +class (Message msg) => Participant prt msg where + partChannel :: prt -> IORef (Channel msg) - partConnectChannel :: (Message msg) => prt -> Channel msg -> IO () + partConnectChannel :: prt -> Channel msg -> IO () - partListen :: (Message msg) => prt -> IO msg + partListen :: prt -> IO msg - partBroadcast :: (Message msg) => prt -> msg -> IO () + partBroadcast :: prt -> msg -> IO () diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index 5765aec..8fe92fe 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/src/Affection/MessageBus/Message.hs @@ -1,4 +1,18 @@ +{-# LANGUAGE RankNTypes #-} module Affection.MessageBus.Message where +import Data.Time.Clock (UTCTime(..)) + class Message msg where - msgPayload :: msg -> a + msgTime :: msg -> UTCTime + +data EngineMessage m + = MsgUserMessage + { msgPayload :: m + , msgWhen :: UTCTime + } -- ^ Generic user defined message with custom payload + | MsgEngineReady UTCTime + +instance Message (EngineMessage m) where + msgTime (MsgUserMessage _ t) = t + msgTime (MsgEngineReady t) = t diff --git a/src/Affection/MessageBus/Util.hs b/src/Affection/MessageBus/Util.hs index 759c582..ed7c551 100644 --- a/src/Affection/MessageBus/Util.hs +++ b/src/Affection/MessageBus/Util.hs @@ -5,4 +5,4 @@ import Affection.MessageBus.Message import Control.Concurrent.STM as STM newBroadcastChannel :: (Message msg) => IO (Channel msg) -newBroadcastChannel = atomically $ newBroadcastTChan +newBroadcastChannel = atomically $ Channel <$> newBroadcastTChan