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