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 AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
module Affection.MessageBus.Class
( Participant(..)
, genUUID
@ -25,7 +26,7 @@ class (Show m, Message m) => Participant prt m where
-- | Subscribe to the 'Participant''s events
partSubscribe
:: 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)
-> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function

View file

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

View file

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

View file

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

View file

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