it builds!

This commit is contained in:
nek0 2017-12-13 04:37:16 +01:00
parent 64537fe1c7
commit 55d863e4cc
11 changed files with 173 additions and 81 deletions

View file

@ -69,9 +69,11 @@ library
, Affection.MessageBus.Message.Class , Affection.MessageBus.Message.Class
, Affection.MessageBus.Message.WindowMessage , Affection.MessageBus.Message.WindowMessage
, Affection.MessageBus.Message.KeyboardMessage , Affection.MessageBus.Message.KeyboardMessage
, Affection.MessageBus.Message.MouseMessage
, Affection.Subsystems.Class , Affection.Subsystems.Class
, Affection.Subsystems.AffectionWindow , Affection.Subsystems.AffectionWindow
, Affection.Subsystems.AffectionKeyboard , Affection.Subsystems.AffectionKeyboard
, Affection.Subsystems.AffectionMouse
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
-- Modules included in this library but not exported. -- Modules included in this library but not exported.
@ -100,6 +102,7 @@ library
, bytestring , bytestring
, OpenGL , OpenGL
, stm , stm
, uuid
-- executable example00 -- executable example00
-- hs-source-dirs: examples -- hs-source-dirs: examples

View file

@ -1,33 +1,49 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
module Affection.MessageBus.Class where {-# LANGUAGE AllowAmbiguousTypes #-}
module Affection.MessageBus.Class
( Participant(..)
, genUUID
, UUID
) where
import Affection.MessageBus.Message import Affection.MessageBus.Message
import Affection.Types import Affection.Types
class (Message m) => Participant prt m where import Control.Monad.IO.Class (liftIO)
-- | get the outbound 'Channel' of the 'Participant'
partChannel
:: prt -- ^ The 'Participant'
-> Channel m -- ^ Outbound 'Channel'
-- | Initialize the 'Participant' with an inbound 'Channel' import Data.UUID
partInit import Data.UUID.V4
:: Channel m -- ^ Inbound 'Channel' the 'Participant' will listen to
-> Affection sd prt -- ^ The constructed and initialized 'Participant'
-- Get the 'Participant' to listen to its inbound 'Channel' import Affection.Logging
partListen
:: prt -- ^ The 'Participant'
-> Affection sd (Maybe m) -- ^ The optional 'Message' peeked from the 'Channel'
-- 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 partEmit
:: prt -- ^ The 'Participant' :: prt -- ^ The 'Participant'
-> m -- ^ The 'Message' to emit -> m -- ^ The 'Message' to emit
-> Affection sd () -> Affection sd ()
partEmit p m = do
liftIO $ logIO Debug $ "Emitting message: " ++ show m
l <- partSubscribers p
mapM_ ($ m) l
-- data Envelope = Envelope genUUID :: Affection sd UUID
-- { envFrom :: (Participant a _) => a genUUID = liftIO $ nextRandom
-- , envTo :: (Participant b _) => b
-- , envMessage :: (Message msg) => msg
-- }

View file

@ -5,3 +5,4 @@ module Affection.MessageBus.Message
import Affection.MessageBus.Message.Class as M import Affection.MessageBus.Message.Class as M
import Affection.MessageBus.Message.WindowMessage as M import Affection.MessageBus.Message.WindowMessage as M
import Affection.MessageBus.Message.KeyboardMessage as M import Affection.MessageBus.Message.KeyboardMessage as M
import Affection.MessageBus.Message.MouseMessage as M

View file

@ -12,7 +12,7 @@ data KeyboardMessage = MsgKeyboardEvent
, msgKbdKeyMotion :: SDL.InputMotion , msgKbdKeyMotion :: SDL.InputMotion
, msgKbdLeyRepeat :: Bool , msgKbdLeyRepeat :: Bool
, msgKbdKeysym :: SDL.Keysym , msgKbdKeysym :: SDL.Keysym
} } deriving (Show)
instance Message KeyboardMessage where instance Message KeyboardMessage where
msgTime (MsgKeyboardEvent t _ _ _ _) = t msgTime (MsgKeyboardEvent t _ _ _ _) = t

View file

@ -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

View file

@ -1,4 +1,3 @@
{-# LANGUAGE RankNTypes #-}
module Affection.MessageBus.Message.WindowMessage where module Affection.MessageBus.Message.WindowMessage where
import Affection.MessageBus.Message.Class import Affection.MessageBus.Message.Class
@ -70,6 +69,7 @@ data WindowMessage
{ msgWCWhen :: Word32 { msgWCWhen :: Word32
, msgWCWindow :: SDL.Window , msgWCWindow :: SDL.Window
} }
deriving (Show)
instance Message WindowMessage where instance Message WindowMessage where
-- msgTime (MsgEngineReady t) = t -- msgTime (MsgEngineReady t) = t

View file

@ -1,31 +1,3 @@
module Affection.MessageBus.Util where module Affection.MessageBus.Util where
import Affection.MessageBus.Class -- zuru zuru
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

View file

@ -6,26 +6,27 @@ import Affection.Subsystems.Class
import Affection.Types import Affection.Types
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM as STM
import qualified SDL import qualified SDL
data AffectionKeyboard = AffectionKeyboard data AffectionKeyboard = AffectionKeyboard
{ keyboardInChannel :: Channel KeyboardMessage { keyboardSubscribers :: TVar [(UUID, KeyboardMessage -> IO ())]
, keyboardOutChannel :: Channel KeyboardMessage
} }
instance Participant AffectionKeyboard KeyboardMessage where 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 partUnSubscribe p uuid =
ochan <- liftIO $ newBroadcastChannel liftIO $ atomically $ modifyTVar' (keyboardSubscribers p)
return $ AffectionKeyboard ichan ochan (filter (\(u, _) -> u /= uuid))
partListen p = partSubscribers p = do
liftIO $ tryPeekChannel (keyboardInChannel p) subTups <- liftIO $ readTVarIO $ keyboardSubscribers p
return $ map snd subTups
partEmit p m =
liftIO $ writeChannel (keyboardOutChannel p) m
instance SDLSubsystem AffectionKeyboard KeyboardMessage where instance SDLSubsystem AffectionKeyboard KeyboardMessage where
consumeSDLEvents ak evs = doConsume evs consumeSDLEvents ak evs = doConsume evs

View file

@ -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)

View file

@ -1,34 +1,32 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
module Affection.Subsystems.AffectionWindow where module Affection.Subsystems.AffectionWindow where
import Affection.Types
import Affection.MessageBus import Affection.MessageBus
import Affection.Subsystems.Class import Affection.Subsystems.Class
import Affection.Types
import Control.Concurrent.STM as STM
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import qualified SDL import qualified SDL
data AffectionWindow = AffectionWindow data AffectionWindow sd = AffectionWindow
{ windowInChannel :: Channel WindowMessage { windowSubscribers :: TVar [(UUID, WindowMessage -> Affection sd ())]
, windowOutChannel :: Channel WindowMessage
} }
instance Participant AffectionWindow WindowMessage where 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 partUnSubscribe p uuid =
ochan <- liftIO $ newBroadcastChannel liftIO $ atomically $ modifyTVar' (windowSubscribers p)
return $ AffectionWindow (filter (\(u, _) -> u /= uuid))
{ windowOutChannel = ochan
, windowInChannel = ichan
}
partListen p = partSubscribers p = do
liftIO $ tryPeekChannel (windowInChannel p) subTups <- liftIO $ readTVarIO $ windowSubscribers p
return $ map snd subTups
partEmit p message =
liftIO $ writeChannel (windowOutChannel p) message
instance SDLSubsystem AffectionWindow WindowMessage where instance SDLSubsystem AffectionWindow WindowMessage where
consumeSDLEvents aw evs = doConsume evs consumeSDLEvents aw evs = doConsume evs

View file

@ -42,7 +42,6 @@ import Data.Map.Strict as M
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State import Control.Monad.State
import qualified Control.Monad.Parallel as MP import qualified Control.Monad.Parallel as MP
import Control.Concurrent.STM as STM
import System.Clock (TimeSpec) import System.Clock (TimeSpec)
-- import Control.Monad.Reader -- import Control.Monad.Reader
@ -232,5 +231,3 @@ type Angle = Double
-- { partStorLatest :: Maybe Particle -- ^ The particle stored last -- { partStorLatest :: Maybe Particle -- ^ The particle stored last
-- , partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime -- , partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime
-- } -- }
newtype (Message msg) => Channel msg = Channel (TChan msg)