diff --git a/affection.cabal b/affection.cabal index 0f144f5..9055740 100644 --- a/affection.cabal +++ b/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 diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index b83e99b..3aa1fea 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/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 diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index 6712571..0af45ec 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/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 diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs index e783592..e51b712 100644 --- a/src/Affection/MessageBus/Message/KeyboardMessage.hs +++ b/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 diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs new file mode 100644 index 0000000..a3c60d8 --- /dev/null +++ b/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 diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs index d410b2e..43c4c46 100644 --- a/src/Affection/MessageBus/Message/WindowMessage.hs +++ b/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 diff --git a/src/Affection/MessageBus/Util.hs b/src/Affection/MessageBus/Util.hs index 341f21b..b2cae3e 100644 --- a/src/Affection/MessageBus/Util.hs +++ b/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 diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index de5ad62..094b559 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/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 diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs new file mode 100644 index 0000000..8c9f144 --- /dev/null +++ b/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) diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 26eb841..90b560a 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/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 diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 8810fe1..6e89dd7 100644 --- a/src/Affection/Types.hs +++ b/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)