From 78f058db6b46f2e9e9b8b1cef79fdceca1cfbc66 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 13 Dec 2017 15:19:53 +0100 Subject: [PATCH] still won't work --- affection.cabal | 84 +++++----- examples/example00.hs | 150 ++++++------------ src/Affection.hs | 8 +- src/Affection/MessageBus.hs | 3 + src/Affection/MessageBus/Class.hs | 6 +- src/Affection/MessageBus/Message/Class.hs | 2 +- .../MessageBus/Message/KeyboardMessage.hs | 4 +- .../MessageBus/Message/MouseMessage.hs | 8 +- .../MessageBus/Message/WindowMessage.hs | 31 ++-- src/Affection/Subsystems.hs | 8 + src/Affection/Subsystems/AffectionKeyboard.hs | 28 ++-- src/Affection/Subsystems/AffectionMouse.hs | 68 ++++---- src/Affection/Subsystems/AffectionWindow.hs | 94 +++++------ src/Affection/Subsystems/Class.hs | 2 +- src/Affection/Types.hs | 6 +- 15 files changed, 239 insertions(+), 263 deletions(-) create mode 100644 src/Affection/Subsystems.hs diff --git a/affection.cabal b/affection.cabal index 9055740..00b97da 100644 --- a/affection.cabal +++ b/affection.cabal @@ -70,6 +70,7 @@ library , Affection.MessageBus.Message.WindowMessage , Affection.MessageBus.Message.KeyboardMessage , Affection.MessageBus.Message.MouseMessage + , Affection.Subsystems , Affection.Subsystems.Class , Affection.Subsystems.AffectionWindow , Affection.Subsystems.AffectionKeyboard @@ -104,23 +105,26 @@ library , stm , uuid --- executable example00 --- hs-source-dirs: examples --- main-is: example00.hs --- ghc-options: -threaded -Wall --- default-language: Haskell2010 --- default-extensions: OverloadedStrings --- if flag(examples) --- build-depends: base --- , affection --- , sdl2 --- , gegl --- , babl --- , containers --- , mtl --- else --- buildable: False --- +executable example00 + if flag(debug) + cpp-options: -DDEBUG + if flag(warn) + cpp-options: -DWARN + if flag(error) + cpp-options: -DERROR + hs-source-dirs: examples + main-is: example00.hs + ghc-options: -threaded -Wall + default-language: Haskell2010 + default-extensions: OverloadedStrings + if flag(examples) + build-depends: base + , affection + , sdl2 + , stm + else + buildable: False + -- executable example01 -- hs-source-dirs: examples -- main-is: example01.hs @@ -209,26 +213,26 @@ library -- , monad-parallel -- else -- buildable: False - -executable example05 - hs-source-dirs: examples - main-is: example05.hs - ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts - default-language: Haskell2010 - default-extensions: OverloadedStrings - if flag(examples) - build-depends: base - , affection - , sdl2 - , gegl - , babl - , containers - , unordered-containers - , mtl - , random - , matrix - , random - , monad-parallel - , parallel - else - buildable: False +-- +-- executable example05 +-- hs-source-dirs: examples +-- main-is: example05.hs +-- ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts +-- default-language: Haskell2010 +-- default-extensions: OverloadedStrings +-- if flag(examples) +-- build-depends: base +-- , affection +-- , sdl2 +-- , gegl +-- , babl +-- , containers +-- , unordered-containers +-- , mtl +-- , random +-- , matrix +-- , random +-- , monad-parallel +-- , parallel +-- else +-- buildable: False diff --git a/examples/example00.hs b/examples/example00.hs index def9f9e..9be083c 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -1,117 +1,71 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} import Affection import qualified SDL -import qualified SDL.Raw as Raw -import qualified GEGL as G -import qualified BABL as B -import qualified Data.Map.Strict as M -import Control.Monad (when) +import Control.Concurrent.STM -import Foreign.Storable (peek) -import Foreign.C.Types (CInt(..)) +data StateData = StateData + { sdSubs :: Subsystems + } -import Debug.Trace - --- main :: IO () --- main = withAllAffection $ --- withDefaultWindow "test" $ do --- changeColor $ RGBA 255 255 255 255 --- clear --- present --- liftIO $ delaySec 2 +data Subsystems = Subsystems + { subWindow :: AffectionWindow StateData + , subMouse :: AffectionMouse StateData + , subKeyboard :: AffectionKeyboard StateData + } main :: IO () main = do - conf <- return $ AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - , preLoop = return () - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , loadState = load - , cleanUp = clean - } + logIO Debug "Starting" + let conf = AffectionConfig + { initComponents = All + , windowTitle = "affection: example00" + , windowConfig = SDL.defaultWindow + , initScreenMode = SDL.Windowed + , canvasSize = Nothing + , loadState = load + , preLoop = pre + , eventLoop = handle + , updateLoop = update + , drawLoop = draw + , cleanUp = clean + } withAffection conf -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - } - -load :: IO UserData +load :: IO StateData load = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ - props $ do - prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - prop "color2" $ G.RGBA 0.6 0.6 0.6 1 - traceM "checkerboard" - over <- G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - text <- G.gegl_node_new_child root $ G.textOperation $ - props $ do - prop "string" ("Hello world!"::String) - prop "color" $ G.RGBA 0 0 1 0.5 - prop "size" (40::Int) - traceM "text" - G.gegl_node_link checkerboard over - G.gegl_node_connect_to text "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("checkerboard", checkerboard) - , ("text" , text) - ] - traceM "loading complete" - return $ UserData - { nodeGraph = myMap - } + empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())]) + empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())]) + empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())]) + return $ StateData $ Subsystems + (AffectionWindow empty1) + (AffectionMouse empty2) + (AffectionKeyboard empty3) -draw :: Affection UserData () -draw = do - traceM "drawing" - AffectionData{..} <- get - let UserData{..} = userState - liftIO $ SDL.lockSurface drawSurface - pixels <- liftIO $ SDL.surfacePixels drawSurface - let SDL.Surface rawSurfacePtr _ = drawSurface - rawSurface <- liftIO $ peek rawSurfacePtr - pixelFormat <- liftIO $ peek $ Raw.surfaceFormat rawSurface - format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8) - SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface - let (w, h) = (fromIntegral rw, fromIntegral rh) - liftIO $ G.gegl_node_blit - (nodeGraph M.! "over" :: G.GeglNode) - 1 - (G.GeglRectangle 0 0 w h) - format - pixels - (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w) - [G.GeglBlitDefault] - liftIO $ SDL.unlockSurface drawSurface - liftIO $ SDL.updateWindowSurface drawWindow +pre :: Affection StateData () +pre = do + sd <- getAffection + _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ + return () -handle :: SDL.EventPayload -> Affection UserData () -handle = const $ return () +exitOnQ :: KeyboardMessage -> Affection StateData () +exitOnQ (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeQ -> quit + otherwise -> return () -update :: Double -> Affection UserData () -update sec = do - traceM "updating" - ad <- get - ud@UserData{..} <- getAffection +handle :: [SDL.EventPayload] -> Affection StateData () +handle es = do + (Subsystems a b c) <- sdSubs <$> getAffection + _ <- consumeSDLEvents a es + _ <- consumeSDLEvents b es + _ <- consumeSDLEvents c es + return () - -- sec <- getDelta - traceM $ (show $ 1 / sec) ++ " FPS" - when (elapsedTime ad > 5) $ - put $ ad - { quitEvent = True - } +update _ = return () + +draw = return () -clean :: UserData -> IO () clean _ = return () diff --git a/src/Affection.hs b/src/Affection.hs index 2917ec7..11dec7b 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -24,6 +24,9 @@ import Affection.StateMachine as A import Affection.MouseInteractable as A import Affection.Util as A import Affection.MessageBus as A +import Affection.Subsystems as A + +import Affection.Logging as A import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) @@ -45,7 +48,7 @@ withAffection AffectionConfig{..} = do do renderQuality <- SDL.get SDL.HintRenderScaleQuality when (renderQuality /= SDL.ScaleLinear) $ - putStrLn "Warning: Linear texture filtering not enabled!" + logIO Warn "Linear texture filtering not enabled!" -- construct window window <- SDL.createWindow windowTitle windowConfig SDL.showWindow window @@ -94,7 +97,8 @@ withAffection AffectionConfig{..} = do } -- poll events evs <- preHandleEvents =<< liftIO SDL.pollEvents - mapM_ eventLoop evs + -- mapM_ eventLoop evs + eventLoop evs -- execute user defined update loop unless (pausedTime ad) (updateLoop dt) -- execute user defined draw loop diff --git a/src/Affection/MessageBus.hs b/src/Affection/MessageBus.hs index 28d1bfa..d22edbb 100644 --- a/src/Affection/MessageBus.hs +++ b/src/Affection/MessageBus.hs @@ -1,7 +1,10 @@ module Affection.MessageBus ( module M + , module Msg ) where import Affection.MessageBus.Class as M import Affection.MessageBus.Message as M import Affection.MessageBus.Util as M + +import Affection.MessageBus.Message as Msg diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 4ec6b7d..a27bca3 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Rank2Types #-} module Affection.MessageBus.Class ( Participant(..) , genUUID @@ -20,13 +20,13 @@ import Affection.Logging class (Show m, Message m) => Participant prt m where -- | Function to get the lsit of subscribers from the participant partSubscribers - :: prt -- ^ the participant + :: 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 - -> (forall sd. m -> Affection sd ()) -- ^ What to do in case of a 'Message' + -> (m -> Affection sd ()) -- ^ What to do in case of a 'Message' -- (Subscriber function) -> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function diff --git a/src/Affection/MessageBus/Message/Class.hs b/src/Affection/MessageBus/Message/Class.hs index b97de31..bcb2651 100644 --- a/src/Affection/MessageBus/Message/Class.hs +++ b/src/Affection/MessageBus/Message/Class.hs @@ -3,4 +3,4 @@ module Affection.MessageBus.Message.Class where import Data.Word (Word32(..)) class Message msg where - msgTime :: msg -> Word32 + msgTime :: msg -> Double diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs index e51b712..5ef859a 100644 --- a/src/Affection/MessageBus/Message/KeyboardMessage.hs +++ b/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -2,12 +2,10 @@ module Affection.MessageBus.Message.KeyboardMessage where import Affection.MessageBus.Message.Class -import Data.Word (Word32(..)) - import qualified SDL data KeyboardMessage = MsgKeyboardEvent - { msgKbdWhen :: Word32 + { msgKbdWhen :: Double , msgKbdWindow :: Maybe SDL.Window , msgKbdKeyMotion :: SDL.InputMotion , msgKbdLeyRepeat :: Bool diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs index 4ff12b6..5833ae1 100644 --- a/src/Affection/MessageBus/Message/MouseMessage.hs +++ b/src/Affection/MessageBus/Message/MouseMessage.hs @@ -2,7 +2,7 @@ module Affection.MessageBus.Message.MouseMessage where import Affection.MessageBus.Message.Class -import Data.Word (Word32(..), Word8(..)) +import Data.Word (Word8(..)) import Data.Int (Int32(..)) import qualified SDL @@ -11,7 +11,7 @@ import Linear (V2(..)) data MouseMessage = MsgMouseMotion - { msgMMWhen :: Word32 + { msgMMWhen :: Double , msgMMWindow :: Maybe SDL.Window , msgMMWhich :: SDL.MouseDevice , msgMMState :: [SDL.MouseButton] @@ -19,7 +19,7 @@ data MouseMessage , msgMMRelMotion :: V2 Int32 } | MsgMouseButton - { msgMBWhen :: Word32 + { msgMBWhen :: Double , msgMBWindow :: Maybe SDL.Window , msgMBWhich :: SDL.MouseDevice , msgMBButton :: SDL.MouseButton @@ -27,7 +27,7 @@ data MouseMessage , msgMBPos :: V2 Int32 } | MsgMouseWheel - { msgMWWhen :: Word32 + { msgMWWhen :: Double , msgMWWhindow :: Maybe SDL.Window , msgMWWhich :: SDL.MouseDevice , msgMWPos :: V2 Int32 diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs index 43c4c46..d857ed2 100644 --- a/src/Affection/MessageBus/Message/WindowMessage.hs +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -2,7 +2,6 @@ module Affection.MessageBus.Message.WindowMessage where import Affection.MessageBus.Message.Class -import Data.Word (Word32(..)) import Data.Int (Int32(..)) import qualified SDL @@ -10,63 +9,63 @@ import qualified SDL import Linear (V2(..)) data WindowMessage - -- = MsgEngineReady Word32 + -- = MsgEngineReady Double = MsgWindowShow - { msgWSWhen :: Word32 + { msgWSWhen :: Double , msgWSWindow :: SDL.Window } | MsgWindowHide - { msgWHWhen :: Word32 + { msgWHWhen :: Double , msgWHWindow :: SDL.Window } | MsgWindowExpose - { msgWEWhen :: Word32 + { msgWEWhen :: Double , msgWEWindow :: SDL.Window } | MsgWindowMove - { msgWMWhen :: Word32 + { msgWMWhen :: Double , msgWMWindow :: SDL.Window , msgWMNewPos :: V2 Int32 } | MsgWindowResize - { msgWRWhen :: Word32 + { msgWRWhen :: Double , msgWRWindow :: SDL.Window , msgWRNewSize :: V2 Int32 } | MsgWindowSizeChange - { msgWSCWhen :: Word32 + { msgWSCWhen :: Double , msgWSCWindow :: SDL.Window } | MsgWindowMinimize - { msgWMinWhen :: Word32 + { msgWMinWhen :: Double , msgWMinWindow :: SDL.Window } | MsgWindowMaximize - { msgWMaxWhen :: Word32 + { msgWMaxWhen :: Double , msgWMaxWindow :: SDL.Window } | MsgWindowRestore - { msgWRestWhen :: Word32 + { msgWRestWhen :: Double , msgWRestWindow :: SDL.Window } | MsgWindowGainMouseFocus - { msgWGMFWhen :: Word32 + { msgWGMFWhen :: Double , msgWGMFWindow :: SDL.Window } | MsgWindowLoseMouseFocus - { msgWLMFWhen :: Word32 + { msgWLMFWhen :: Double , msgWLMFWindow :: SDL.Window } | MsgWindowGainKeyboardFocus - { msgWGKFWhen :: Word32 + { msgWGKFWhen :: Double , msgWGKFWindow :: SDL.Window } | MsgWindowLoseKeyboardFocus - { msgWLKFWhen :: Word32 + { msgWLKFWhen :: Double , msgWLKFWindow :: SDL.Window } | MsgWindowClose - { msgWCWhen :: Word32 + { msgWCWhen :: Double , msgWCWindow :: SDL.Window } deriving (Show) diff --git a/src/Affection/Subsystems.hs b/src/Affection/Subsystems.hs new file mode 100644 index 0000000..ce9929f --- /dev/null +++ b/src/Affection/Subsystems.hs @@ -0,0 +1,8 @@ +module Affection.Subsystems + ( module S + ) where + +import Affection.Subsystems.Class as S +import Affection.Subsystems.AffectionKeyboard as S +import Affection.Subsystems.AffectionWindow as S +import Affection.Subsystems.AffectionMouse as S diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index 188099a..dc62706 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionKeyboard where import Affection.MessageBus import Affection.Subsystems.Class import Affection.Types +import Affection.Util import Control.Monad.IO.Class (liftIO) import Control.Concurrent.STM as STM @@ -30,17 +31,18 @@ instance Participant (AffectionKeyboard sd) KeyboardMessage where return $ map snd subTups instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where - consumeSDLEvents ak evs = doConsume evs + consumeSDLEvents ak eps = doConsume eps where - doConsume [] = return [] - doConsume (e:es) = case SDL.eventPayload e of - SDL.KeyboardEvent dat -> do - partEmit ak (MsgKeyboardEvent - (SDL.eventTimestamp e) - (SDL.keyboardEventWindow dat) - (SDL.keyboardEventKeyMotion dat) - (SDL.keyboardEventRepeat dat) - (SDL.keyboardEventKeysym dat) - ) - doConsume es - _ -> fmap (e :) (doConsume es) + 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 ff47e06..35689c1 100644 --- a/src/Affection/Subsystems/AffectionMouse.hs +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionMouse where import Affection.MessageBus import Affection.Subsystems.Class import Affection.Types +import Affection.Util import Control.Monad.IO.Class (liftIO) import Control.Concurrent.STM @@ -32,37 +33,38 @@ instance Participant (AffectionMouse sd) MouseMessage where return $ map snd subTups instance SDLSubsystem (AffectionMouse sd) MouseMessage where - consumeSDLEvents am evs = doConsume evs + consumeSDLEvents am eps = doConsume eps 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) + 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 aebe2ee..9b432c8 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -3,6 +3,7 @@ module Affection.Subsystems.AffectionWindow where import Affection.Types +import Affection.Util import Affection.MessageBus import Affection.Subsystems.Class @@ -30,50 +31,51 @@ instance Participant (AffectionWindow sd) WindowMessage where return $ map snd subTups instance SDLSubsystem (AffectionWindow sd) WindowMessage where - consumeSDLEvents aw evs = doConsume evs + consumeSDLEvents aw eps = doConsume eps where - doConsume [] = return [] - doConsume (e:es) = case SDL.eventPayload e of - SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do - partEmit aw (MsgWindowShow (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do - partEmit aw (MsgWindowHide (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do - partEmit aw (MsgWindowExpose (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do - partEmit aw (MsgWindowMove (SDL.eventTimestamp e) window newPos) - doConsume es - SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do - partEmit aw (MsgWindowResize (SDL.eventTimestamp e) window newSize) - doConsume es - SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do - partEmit aw (MsgWindowSizeChange (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do - partEmit aw (MsgWindowMinimize (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do - partEmit aw (MsgWindowMaximize (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do - partEmit aw (MsgWindowRestore (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do - partEmit aw (MsgWindowGainMouseFocus (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do - partEmit aw (MsgWindowLoseMouseFocus (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do - partEmit aw (MsgWindowGainKeyboardFocus (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do - partEmit aw (MsgWindowLoseKeyboardFocus (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do - partEmit aw (MsgWindowClose (SDL.eventTimestamp e) window) - doConsume es - _ -> fmap (e :) (doConsume es) + 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 6dc42f4..f9f3d27 100644 --- a/src/Affection/Subsystems/Class.hs +++ b/src/Affection/Subsystems/Class.hs @@ -8,4 +8,4 @@ import Affection.MessageBus import qualified SDL class (Message m, Participant s m) => SDLSubsystem s m where - consumeSDLEvents :: s -> [SDL.Event] -> Affection sd [SDL.Event] + consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection sd [SDL.EventPayload] diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 6e89dd7..350c285 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -64,16 +64,16 @@ data AffectionConfig us = AffectionConfig -- ^ size of the texture canvas , initScreenMode :: SDL.WindowMode -- ^ Window mode to start in + , loadState :: IO us + -- ^ Provide your own load function to create this data. , preLoop :: Affection us () -- ^ Actions to be performed, before loop starts - , eventLoop :: SDL.EventPayload -> Affection us () + , eventLoop :: [SDL.EventPayload] -> Affection us () -- ^ Main update function. Takes fractions of a second as input. , updateLoop :: Double -> Affection us () -- ^ Main update function. Takes fractions of a second as input. , drawLoop :: Affection us () -- ^ Function for updating graphics. - , loadState :: IO us - -- ^ Provide your own load function to create this data. , cleanUp :: us -> IO () -- ^ Provide your own finisher function to clean your data. }