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

View File

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

View File

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

View File

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

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

View File

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

View File

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

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 #-}
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

View File

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