diff --git a/examples/example00.hs b/examples/example00.hs index 9be083c..00d5c69 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -1,21 +1,74 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} import Affection import qualified SDL import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) data StateData = StateData { sdSubs :: Subsystems } data Subsystems = Subsystems - { subWindow :: AffectionWindow StateData - , subMouse :: AffectionMouse StateData - , subKeyboard :: AffectionKeyboard StateData + { subWindow :: Window + , subMouse :: Mouse + , subKeyboard :: Keyboard } +data Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) +data Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) +data Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) + +instance Participant Window WindowMessage StateData where + partSubscribers (Window t) = do + subTups <- liftIO $ readTVarIO $ t + return $ map snd subTups + + partSubscribe (Window t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + + partUnSubscribe (Window t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Window StateData where + consumeSDLEvents = consumeSDLWindowEvents + +instance Participant Mouse MouseMessage StateData where + partSubscribers (Mouse t) = do + subTups <- liftIO $ readTVarIO $ t + return $ map snd subTups + + partSubscribe (Mouse t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + + partUnSubscribe (Mouse t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Mouse StateData where + consumeSDLEvents = consumeSDLMouseEvents + +instance Participant Keyboard KeyboardMessage StateData where + partSubscribers (Keyboard t) = do + subTups <- liftIO $ readTVarIO $ t + return $ map snd subTups + + partSubscribe (Keyboard t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + + partUnSubscribe (Keyboard t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Keyboard StateData where + consumeSDLEvents = consumeSDLKeyboardEvents + main :: IO () main = do logIO Debug "Starting" @@ -23,6 +76,10 @@ main = do { initComponents = All , windowTitle = "affection: example00" , windowConfig = SDL.defaultWindow + { SDL.windowOpenGL = Just SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + } , initScreenMode = SDL.Windowed , canvasSize = Nothing , loadState = load @@ -40,9 +97,9 @@ load = do empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())]) empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())]) return $ StateData $ Subsystems - (AffectionWindow empty1) - (AffectionMouse empty2) - (AffectionKeyboard empty3) + (Window empty1) + (Mouse empty2) + (Keyboard empty3) pre :: Affection StateData () pre = do diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index aaac555..4530278 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RankNTypes #-} module Affection.MessageBus.Class ( Participant(..) , genUUID @@ -17,34 +17,45 @@ import Data.UUID.V4 import Affection.Logging -class (Show m, Message m) => Participant prt m where - -- | Function to get the lsit of subscribers from the participant +class (Show m, Message m) => Participant prt m us where + + -- | Function to get the list of subscribers from the participant partSubscribers - :: prt -- ^ the participant - -> forall us. Affection us [(m -> Affection us ())] -- ^ List of Subscriber functions + :: prt + -- ^ the 'Participant''s subscriber storage + -> Affection us [(m -> Affection us ())] + -- ^ List of Subscriber functions -- | Subscribe to the 'Participant''s events partSubscribe - :: prt -- ^ The 'Participant' to subscribe to - -> (forall us. m -> Affection us ()) -- ^ What to do in case of a 'Message' - -- (Subscriber function) - -> Affection us UUID -- ^ 'UUID' of the registered subscriber Function + :: prt + -- ^ The 'Participant''s subscriber storage + -> (m -> Affection us ()) + -- ^ What to do in case of a 'Message' + -- (Subscriber function) + -> Affection us 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' + :: prt + -- ^ The 'Participant''s subscriber storage to unsubscribe from + -> UUID + -- ^ The subscriber function's 'UUID' -> Affection us () -- | Get the 'Participant' to emit a 'Message' on all of its subscribers partEmit - :: prt -- ^ The 'Participant' - -> m -- ^ The 'Message' to emit + :: prt + -- ^ The 'Participant''s subscriber storage + -> m + -- ^ The 'Message' to emit -> Affection us () partEmit p m = do liftIO $ logIO Debug $ "Emitting message: " ++ show m l <- partSubscribers p mapM_ ($ m) l +-- | Helper function to generate new 'UUID's genUUID :: Affection us UUID genUUID = liftIO $ nextRandom diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index 6f822d2..4d19ea4 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} module Affection.Subsystems.AffectionKeyboard where import Affection.Types @@ -12,37 +12,24 @@ import Control.Monad.IO.Class (liftIO) import qualified SDL -data AffectionKeyboard us = AffectionKeyboard - { keyboardSubscribers :: forall us. TVar [(UUID, KeyboardMessage -> Affection us ())] - } - -instance Participant (AffectionKeyboard us) KeyboardMessage where - partSubscribe p funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :) - return uuid - - partUnSubscribe p uuid = - liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) - (filter (\(u, _) -> u /= uuid)) - - partSubscribers p = do - subTups <- liftIO $ readTVarIO $ keyboardSubscribers p - return $ map snd subTups - -instance SDLSubsystem (AffectionKeyboard us) KeyboardMessage where - consumeSDLEvents ak eps = doConsume eps - where - doConsume (e:es) = do - ts <- getElapsedTime - case e of - SDL.KeyboardEvent dat -> do - partEmit ak (MsgKeyboardEvent - ts - (SDL.keyboardEventWindow dat) - (SDL.keyboardEventKeyMotion dat) - (SDL.keyboardEventRepeat dat) - (SDL.keyboardEventKeysym dat) - ) - doConsume es - _ -> fmap (e :) (doConsume es) +consumeSDLKeyboardEvents + :: (Participant ak KeyboardMessage us) + => ak + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLKeyboardEvents ak eps = doConsume eps + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.KeyboardEvent dat -> do + partEmit ak (MsgKeyboardEvent + ts + (SDL.keyboardEventWindow dat) + (SDL.keyboardEventKeyMotion dat) + (SDL.keyboardEventRepeat dat) + (SDL.keyboardEventKeysym dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs index 35689c1..a4e83f9 100644 --- a/src/Affection/Subsystems/AffectionMouse.hs +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} module Affection.Subsystems.AffectionMouse where import Affection.MessageBus @@ -14,57 +14,44 @@ 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 eps = doConsume eps - where - doConsume (e:es) = do - ts <- getElapsedTime - case e of - SDL.MouseMotionEvent dat -> do - partEmit am (MsgMouseMotion - ts - (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 - ts - (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 - ts - (SDL.mouseWheelEventWindow dat) - (SDL.mouseWheelEventWhich dat) - (SDL.mouseWheelEventPos dat) - (SDL.mouseWheelEventDirection dat) - ) - doConsume es - _ -> fmap (e :) (doConsume es) +consumeSDLMouseEvents + :: (Participant am MouseMessage us) + => am + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLMouseEvents am eps = doConsume eps + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.MouseMotionEvent dat -> do + partEmit am (MsgMouseMotion + ts + (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 + ts + (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 + ts + (SDL.mouseWheelEventWindow dat) + (SDL.mouseWheelEventWhich dat) + (SDL.mouseWheelEventPos dat) + (SDL.mouseWheelEventDirection dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 1fe4775..0dea121 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} module Affection.Subsystems.AffectionWindow where import Affection.Types @@ -13,70 +13,57 @@ import Control.Monad.IO.Class (liftIO) import qualified SDL -data AffectionWindow us = AffectionWindow - { windowSubscribers :: forall us. TVar [(UUID, WindowMessage -> Affection us ())] - } - -instance Participant (AffectionWindow us) WindowMessage where - partSubscribe p funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :) - return uuid - - partUnSubscribe p uuid = - liftIO $ atomically $ modifyTVar' (windowSubscribers p) - (filter (\(u, _) -> u /= uuid)) - - partSubscribers p = do - subTups <- liftIO $ readTVarIO $ windowSubscribers p - return $ map snd subTups - -instance SDLSubsystem (AffectionWindow us) WindowMessage where - consumeSDLEvents aw eps = doConsume eps - where - doConsume (e:es) = do - ts <- getElapsedTime - case e of - SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do - partEmit aw (MsgWindowShow ts window) - doConsume es - SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do - partEmit aw (MsgWindowHide ts window) - doConsume es - SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do - partEmit aw (MsgWindowExpose ts window) - doConsume es - SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do - partEmit aw (MsgWindowMove ts window newPos) - doConsume es - SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do - partEmit aw (MsgWindowResize ts window newSize) - doConsume es - SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do - partEmit aw (MsgWindowSizeChange ts window) - doConsume es - SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do - partEmit aw (MsgWindowMinimize ts window) - doConsume es - SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do - partEmit aw (MsgWindowMaximize ts window) - doConsume es - SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do - partEmit aw (MsgWindowRestore ts window) - doConsume es - SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do - partEmit aw (MsgWindowGainMouseFocus ts window) - doConsume es - SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do - partEmit aw (MsgWindowLoseMouseFocus ts window) - doConsume es - SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do - partEmit aw (MsgWindowGainKeyboardFocus ts window) - doConsume es - SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do - partEmit aw (MsgWindowLoseKeyboardFocus ts window) - doConsume es - SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do - partEmit aw (MsgWindowClose ts window) - doConsume es - _ -> fmap (e :) (doConsume es) +consumeSDLWindowEvents + :: (Participant aw WindowMessage us) + => aw + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLWindowEvents aw eps = doConsume eps + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do + partEmit aw (MsgWindowShow ts window) + doConsume es + SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do + partEmit aw (MsgWindowHide ts window) + doConsume es + SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do + partEmit aw (MsgWindowExpose ts window) + doConsume es + SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do + partEmit aw (MsgWindowMove ts window newPos) + doConsume es + SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do + partEmit aw (MsgWindowResize ts window newSize) + doConsume es + SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do + partEmit aw (MsgWindowSizeChange ts window) + doConsume es + SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do + partEmit aw (MsgWindowMinimize ts window) + doConsume es + SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do + partEmit aw (MsgWindowMaximize ts window) + doConsume es + SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do + partEmit aw (MsgWindowRestore ts window) + doConsume es + SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do + partEmit aw (MsgWindowGainMouseFocus ts window) + doConsume es + SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do + partEmit aw (MsgWindowLoseMouseFocus ts window) + doConsume es + SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowGainKeyboardFocus ts window) + doConsume es + SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowLoseKeyboardFocus ts window) + doConsume es + SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do + partEmit aw (MsgWindowClose ts window) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/Class.hs b/src/Affection/Subsystems/Class.hs index f9f3d27..7c52f8e 100644 --- a/src/Affection/Subsystems/Class.hs +++ b/src/Affection/Subsystems/Class.hs @@ -7,5 +7,5 @@ import Affection.MessageBus import qualified SDL -class (Message m, Participant s m) => SDLSubsystem s m where - consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection sd [SDL.EventPayload] +class SDLSubsystem s us where + consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]