fixing things up

This commit is contained in:
nek0 2017-12-13 05:05:18 +01:00
parent 55d863e4cc
commit 1cbda31499
5 changed files with 31 additions and 23 deletions

View file

@ -1,5 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
module Affection.MessageBus.Class module Affection.MessageBus.Class
( Participant(..) ( Participant(..)
, genUUID , genUUID
@ -25,7 +26,7 @@ class (Show m, Message m) => Participant prt m where
-- | Subscribe to the 'Participant''s events -- | Subscribe to the 'Participant''s events
partSubscribe partSubscribe
:: prt -- ^ The 'Participant' to subscribe to :: prt -- ^ The 'Participant' to subscribe to
-> (m -> IO ()) -- ^ What to do in case of a 'Message' -> (forall sd. m -> Affection sd ()) -- ^ What to do in case of a 'Message'
-- (Subscriber function) -- (Subscriber function)
-> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function -> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function

View file

@ -33,6 +33,7 @@ data MouseMessage
, msgMWPos :: V2 Int32 , msgMWPos :: V2 Int32
, msgMWDIrection :: SDL.MouseScrollDirection , msgMWDIrection :: SDL.MouseScrollDirection
} }
deriving (Show)
instance Message MouseMessage where instance Message MouseMessage where
msgTime (MsgMouseMotion t _ _ _ _ _) = t msgTime (MsgMouseMotion t _ _ _ _ _) = t

View file

@ -1,4 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Affection.Subsystems.AffectionKeyboard where module Affection.Subsystems.AffectionKeyboard where
import Affection.MessageBus import Affection.MessageBus
@ -10,11 +11,11 @@ import Control.Concurrent.STM as STM
import qualified SDL import qualified SDL
data AffectionKeyboard = AffectionKeyboard data AffectionKeyboard sd = AffectionKeyboard
{ keyboardSubscribers :: TVar [(UUID, KeyboardMessage -> IO ())] { keyboardSubscribers :: forall sd. TVar [(UUID, KeyboardMessage -> Affection sd ())]
} }
instance Participant AffectionKeyboard KeyboardMessage where instance Participant (AffectionKeyboard sd) KeyboardMessage where
partSubscribe p funct = do partSubscribe p funct = do
uuid <- genUUID uuid <- genUUID
liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :) liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :)
@ -28,7 +29,7 @@ instance Participant AffectionKeyboard KeyboardMessage where
subTups <- liftIO $ readTVarIO $ keyboardSubscribers p subTups <- liftIO $ readTVarIO $ keyboardSubscribers p
return $ map snd subTups return $ map snd subTups
instance SDLSubsystem AffectionKeyboard KeyboardMessage where instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where
consumeSDLEvents ak evs = doConsume evs consumeSDLEvents ak evs = doConsume evs
where where
doConsume [] = return [] doConsume [] = return []

View file

@ -1,47 +1,51 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Affection.Subsystems.AffectionMouse where module Affection.Subsystems.AffectionMouse where
import Affection.MessageBus import Affection.MessageBus
import Affection.Subsystem.Class 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 import Control.Concurrent.STM
import Linear.Affine (unP)
import qualified SDL import qualified SDL
data AffectionMouse = AffectionMouse data AffectionMouse sd = AffectionMouse
{ mouseSubscribers :: TVar (UUID, MouseMessage -> IO ()) { mouseSubscribers :: forall sd. TVar [(UUID, MouseMessage -> Affection sd ())]
} }
instance Participant AffectionMouse MouseMessage where instance Participant (AffectionMouse sd) MouseMessage where
partSubscribe p funct = do partSubscribe p funct = do
uuid <- genUUID uuid <- genUUID
liftIO $ atmoically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :) liftIO $ atomically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :)
return uuid return uuid
partUnSubscribe p uuid = partUnSubscribe p uuid =
liftIO $ atomically $ modifyTVar' (mouseSubscribers p) liftIO $ atomically $ modifyTVar' (mouseSubscribers p)
(filter (\(u, _) -> u /= uuid)) (filter (\(u, _) -> u /= uuid))
partSubscribers p = partSubscribers p = do
subTups <- liftIO $ readTVarIO $ mouseSubscribers p subTups <- liftIO $ readTVarIO $ mouseSubscribers p
return $ map snd subTups return $ map snd subTups
instance SDLSubsystem AffectionMouse where instance SDLSubsystem (AffectionMouse sd) MouseMessage where
consumeSDLEvents am evs = doComsume evs consumeSDLEvents am evs = doConsume evs
where where
doConsume [] = return [] doConsume [] = return []
doConsume (e:es) = case SDL.EventPayload e of doConsume (e:es) = case SDL.eventPayload e of
SDL.MouseMotionEvent dat -> do SDL.MouseMotionEvent dat -> do
partEmit am (MsgMouseMotion partEmit am (MsgMouseMotion
(SDL.eventTimestamp dat) (SDL.eventTimestamp e)
(SDL.mouseMotionEventWindow dat) (SDL.mouseMotionEventWindow dat)
(SDL.mouseMotionEventWhich dat) (SDL.mouseMotionEventWhich dat)
(SDL.mouseMotionEventState dat) (SDL.mouseMotionEventState dat)
(SDL.mouseMotionEventPos dat) (unP $ SDL.mouseMotionEventPos dat)
(SDL.mouseMotionEventRelMotion dat) (SDL.mouseMotionEventRelMotion dat)
) )
doComsume es doConsume es
SDL.MouseButtonEvent dat -> do SDL.MouseButtonEvent dat -> do
partEmit am (MsgMouseButton partEmit am (MsgMouseButton
(SDL.eventTimestamp e) (SDL.eventTimestamp e)
@ -49,16 +53,16 @@ instance SDLSubsystem AffectionMouse where
(SDL.mouseButtonEventWhich dat) (SDL.mouseButtonEventWhich dat)
(SDL.mouseButtonEventButton dat) (SDL.mouseButtonEventButton dat)
(SDL.mouseButtonEventClicks dat) (SDL.mouseButtonEventClicks dat)
(SDL.mouseButtonEventPos dat) (unP $ SDL.mouseButtonEventPos dat)
) )
doConsume es doConsume es
SDL.MouseWheelEvent dat -> do SDL.MouseWheelEvent dat -> do
partEmit am (MsgMouseWheel partEmit am (MsgMouseWheel
(SDL.eventTimestamp e) (SDL.eventTimestamp e)
(SDL.mouseWheelEventWindow dat) (SDL.mouseWheelEventWindow dat)
(SDL.mouseWheelEvntWhich dat) (SDL.mouseWheelEventWhich dat)
(SDL.mouseWheelEventPos dat) (SDL.mouseWheelEventPos dat)
(SDL.mouseWheelEventDirection dat) (SDL.mouseWheelEventDirection dat)
) )
doConsume es doConsume es
_ -> fmap (e :) (doComsume es) _ -> fmap (e :) (doConsume es)

View file

@ -1,4 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
module Affection.Subsystems.AffectionWindow where module Affection.Subsystems.AffectionWindow where
import Affection.Types import Affection.Types
@ -11,10 +12,10 @@ import Control.Monad.IO.Class (liftIO)
import qualified SDL import qualified SDL
data AffectionWindow sd = AffectionWindow data AffectionWindow sd = AffectionWindow
{ windowSubscribers :: TVar [(UUID, WindowMessage -> Affection sd ())] { windowSubscribers :: forall sd. TVar [(UUID, WindowMessage -> Affection sd ())]
} }
instance Participant AffectionWindow WindowMessage where instance Participant (AffectionWindow sd) WindowMessage where
partSubscribe p funct = do partSubscribe p funct = do
uuid <- genUUID uuid <- genUUID
liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :) liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :)
@ -28,7 +29,7 @@ instance Participant AffectionWindow WindowMessage where
subTups <- liftIO $ readTVarIO $ windowSubscribers p subTups <- liftIO $ readTVarIO $ windowSubscribers p
return $ map snd subTups return $ map snd subTups
instance SDLSubsystem AffectionWindow WindowMessage where instance SDLSubsystem (AffectionWindow sd) WindowMessage where
consumeSDLEvents aw evs = doConsume evs consumeSDLEvents aw evs = doConsume evs
where where
doConsume [] = return [] doConsume [] = return []