affection/src/Affection/MessageBus/Class.hs

66 lines
1.8 KiB
Haskell

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
module Affection.MessageBus.Class
( Participant(..)
, genUUID
, UUID
) where
import Affection.MessageBus.Message
import Affection.Types
import Control.Monad.IO.Class (liftIO)
import Data.UUID
import Data.UUID.V4
import Affection.Logging
-- | This typeclass defines the behaviour of a participant in the message system
class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where
type Mesg prt us :: * -- ^ Message datatype
-- | Function to get the list of subscribers from the participant
partSubscribers
:: prt
-- ^ the 'Participant''s subscriber storage
-> Affection us [Mesg prt us -> Affection us ()]
-- ^ List of Subscriber functions
-- | Subscribe to the 'Participant''s events
partSubscribe
:: prt
-- ^ The 'Participant''s subscriber storage
-> (Mesg prt us -> Affection us ())
-- ^ What to do in case of a 'Message'
-- (Subscriber function)
-> 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
-> UUID
-- ^ The subscriber function's 'UUID'
-> Affection us ()
-- | Get the 'Participant' to emit a 'Message' on all of its subscribers
partEmit
:: prt
-- ^ The 'Participant''s subscriber storage
-> Mesg prt us
-- ^ The 'Message' to emit
-> Affection us ()
partEmit p m = do
liftIO $ logIO Verbose $ "Emitting message: " ++ show m
l <- partSubscribers p
mapM_ ($ m) l
-- | Helper function to generate new 'UUID's
genUUID :: Affection us UUID
genUUID = liftIO nextRandom