diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,23 +1,16 @@ # reflex-sdl2 +![status](https://gitlab.com/schell/reflex-sdl2/badges/master/build.svg) + This is a [reflex][2] host for [sdl2][0]. Writing and running [sdl2][0] apps requires version 2 of the awesome [SDL][1] -library. If you have [nix][4] then the build process will install SDL2 for you. +library. ## building -### with stack & nix - -Using [stack][3] and [nix][4] together is the path of enlightenment. [nix][4] -handles installing SDL2 while [stack][3] builds the haskell deps. - - stack --nix build - -### without nix - -Without [nix][4] you'll have to install SDL2 yourself. +The first step is to install SDL. ### macOS @@ -34,7 +27,14 @@ otherwise please visit the org page above and install via their README. +### building with stack +After installing SDL, we can build with stack. + +Using [stack][3] is the path of least resistance. + + stack build + ## examples After building you can view an example using the built-in 2d renderer in @@ -42,12 +42,10 @@ To run the example do: - stack --nix exec reflex-sdl2-exe + stack exec reflex-sdl2-exe [0]: http://hackage.haskell.org/package/sdl2 "sdl2 haskell bindings" [1]: http://libsdl.org "Simple Direct Media Layer" [2]: https://github.com/reflex-frp/reflex "reflex frp" [3]: https://docs.haskellstack.org/en/stable/README/ "the haskell tool stack" -[4]: https://nixos.org "Nix" -[5]: https://github.com/reflex-frp/reflex-platform "the reflex platform" diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -7,10 +7,11 @@ {-# LANGUAGE UndecidableInstances #-} module Main where -import Control.Concurrent (threadDelay) -import Control.Monad (forM_, guard, void) +import Control.Concurrent (threadDelay) +import Control.Monad (forM_, guard, void) +import Control.Monad.Reader (MonadReader (..), runReaderT) +import Reflex import Reflex.SDL2 -import System.Exit (exitSuccess) -------------------------------------------------------------------------------- @@ -48,14 +49,14 @@ ---------------------------------------------------------------------- -- | Commit a layer stack that changes over time. -commitLayers :: (ReflexSDL2 r t m, MonadDynamicWriter t [Layer m] m) +commitLayers :: (ReflexSDL2 t m, MonadDynamicWriter t [Layer m] m) => Dynamic t [Layer m] -> m () commitLayers = tellDyn ---------------------------------------------------------------------- -- | Commit one layer that changes over time. -commitLayer :: (ReflexSDL2 r t m, MonadDynamicWriter t [Layer m] m) +commitLayer :: (ReflexSDL2 t m, MonadDynamicWriter t [Layer m] m) => Dynamic t (Layer m) -> m () commitLayer = tellDyn . fmap pure @@ -81,10 +82,10 @@ | otherwise = ButtonStateOver -button :: (ReflexSDL2 r t m, MonadDynamicWriter t [Layer m] m) - => Renderer - -> m (Event t ButtonState) -button r = do +button + :: (ReflexSDL2 t m, MonadDynamicWriter t [Layer m] m, MonadReader Renderer m) + => m (Event t ButtonState) +button = do evMotionData <- getMouseMotionEvent let position = V2 100 100 size = V2 100 100 @@ -104,6 +105,7 @@ dButtonState <- holdDyn ButtonStateUp $ leftmost [ updated dButtonStatePre , ButtonStateUp <$ evPB ] + r <- ask commitLayer $ ffor dButtonState $ \st -> do let color = case st of ButtonStateUp -> V4 192 192 192 255 @@ -116,19 +118,23 @@ guest - :: (ReflexSDL2 r t m, MonadDynamicWriter t [Layer m] m) - => Renderer - -> m () -guest r = do + :: (ReflexSDL2 t m, MonadDynamicWriter t [Layer m] m, MonadReader Renderer m) + => m () +guest = do -- Print some stuff after the network is built. evPB <- getPostBuild performEvent_ $ ffor evPB $ \() -> liftIO $ putStrLn "starting up..." + ------------------------------------------------------------------------------ + -- Get a handle on our renderer + ------------------------------------------------------------------------------ + r <- ask + ------------------------------------------------------------------------------ -- Test async events. -- This will wait three seconds before coloring the background black. ------------------------------------------------------------------------------ - evDelay <- getAsyncEventWithEventCode 0xBEEF $ threadDelay 3000000 + evDelay <- getAsyncEvent $ threadDelay 3000000 dDelay <- holdDyn False $ True <$ evDelay commitLayers $ ffor dDelay $ \case False -> pure $ do @@ -141,7 +147,7 @@ ------------------------------------------------------------------------------ -- A button! ------------------------------------------------------------------------------ - evBtnState <- button r + evBtnState <- button let evBtnPressed = fmapMaybe (guard . (== ButtonStateDown)) evBtnState performEvent_ $ ffor evBtnPressed $ const $ liftIO $ putStrLn "Button pressed!" @@ -181,7 +187,7 @@ ------------------------------------------------------------------------------ evKey <- getKeyboardEvent let evKeyNoRepeat = fmapMaybe (\k -> k <$ guard (not $ keyboardEventRepeat k)) evKey - dPressed <- holdDyn False $ ((== Pressed) . keyboardEventKeyMotion) <$> evKeyNoRepeat + dPressed <- holdDyn False $ (== Pressed) . keyboardEventKeyMotion <$> evKeyNoRepeat void $ holdView (return ()) $ ffor (updated dPressed) $ \case False -> return () True -> do @@ -201,23 +207,44 @@ -- Test our recurring timer events ------------------------------------------------------------------------------ let performDeltaSecondTimer n = do - evEverySecond <- getRecurringTimerEventWithEventCode n $ fromIntegral n * 1000 - dSeconds <- foldDyn (+) (0 :: Int) $ 1 <$ evEverySecond - evSecondsDelta <- performEventDelta $ updated dSeconds - dSecondsDelta <- holdDyn 0 evSecondsDelta - putDebugLnE (updated $ zipDynWith (,) dSeconds dSecondsDelta) $ (show n ++) . (": " ++) . show + evDelta <- performEventDelta =<< tickLossyFromPostBuildTime n + dTicks <- foldDyn (+) 0 $ (1 :: Int) <$ evDelta + dDelta <- holdDyn 0 evDelta + dElapsed <- foldDyn (+) 0 evDelta + flip putDebugLnE id $ updated $ do + tickz <- dTicks + lapse <- dElapsed + delta <- dDelta + return $ unwords [ show n + , "timer -" + , show tickz + , "ticks -" + , show lapse + , "lapsed -" + , show delta + , "delta since last tick" + ] performDeltaSecondTimer 1 - performDeltaSecondTimer 2 ------------------------------------------------------------------------------ -- Quit on a quit event ------------------------------------------------------------------------------ evQuit <- getQuitEvent - performEvent_ $ ffor evQuit $ \() -> liftIO $ do - putStrLn "bye!" - exitSuccess + performEvent_ $ liftIO (putStrLn "bye!") <$ evQuit + shutdownOn =<< delay 0 evQuit +app :: (ReflexSDL2 t m, MonadReader Renderer m) => m () +app = do + (_, dynLayers) <- runDynamicWriterT guest + r <- ask + performEvent_ $ ffor (updated dynLayers) $ \layers -> do + rendererDrawColor r $= V4 0 0 0 255 + clear r + sequence_ layers + present r + + main :: IO () main = do initializeAll @@ -233,10 +260,9 @@ putStrLn "creating renderer..." r <- createRenderer window (-1) defaultRenderer rendererDrawBlendMode r $= BlendAlphaBlend - host () $ do - (_, dynLayers) <- runDynamicWriterT $ guest r - performEvent_ $ ffor (updated dynLayers) $ \layers -> do - rendererDrawColor r $= V4 0 0 0 255 - clear r - sequence_ layers - present r + -- Host the network with an example of how to embed your own effects. + -- In this case it's a simple reader. + host $ runReaderT app r + destroyRenderer r + destroyWindow window + quit diff --git a/reflex-sdl2.cabal b/reflex-sdl2.cabal --- a/reflex-sdl2.cabal +++ b/reflex-sdl2.cabal @@ -1,5 +1,5 @@ name: reflex-sdl2 -version: 0.2.0.0 +version: 0.3.0.0 synopsis: SDL2 and reflex FRP description: A minimal host for sdl2 based reflex apps. homepage: https://github.com/schell/reflex-sdl2#readme @@ -7,7 +7,7 @@ license-file: LICENSE author: Schell Scivally maintainer: schell@takt.com -copyright: Copyright: (c) 2017 Schell Scivally +copyright: Copyright: (c) 2017 - 2019 Schell Scivally category: Game build-type: Simple extra-source-files: README.md @@ -18,17 +18,20 @@ ghc-options: -Wall exposed-modules: Reflex.SDL2 , Reflex.SDL2.Internal - build-depends: async >= 2.1 && < 2.2 + , Reflex.SDL2.Class + , Reflex.SDL2.Base + build-depends: async >= 2.1 && < 2.3 , base >= 4.7 && < 5 - , containers >= 0.5 && < 0.6 + , containers >= 0.5 && < 0.7 , dependent-sum >= 0.4 && < 0.5 , exception-transformers >= 0.4 && < 0.5 + , ref-tf >= 0.4 && < 0.5 , mtl >= 2.2 && < 2.3 , primitive >= 0.6 && < 0.7 , reflex >= 0.5 && < 0.6 - , ref-tf >= 0.4 && < 0.5 - , sdl2 >= 2.3 && < 2.4 - , stm >= 2.4 && < 2.5 + , sdl2 >= 2.3 && < 2.5 + , stm >= 2.4 && < 2.6 + default-language: Haskell2010 executable reflex-sdl2-exe @@ -36,6 +39,8 @@ main-is: Main.hs ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base + , mtl + , reflex >= 0.5 && < 0.6 , reflex-sdl2 default-language: Haskell2010 diff --git a/src/Reflex/SDL2.hs b/src/Reflex/SDL2.hs --- a/src/Reflex/SDL2.hs +++ b/src/Reflex/SDL2.hs @@ -1,14 +1,13 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | This module contains a minimum yet convenient API needed to get started @@ -17,85 +16,46 @@ -- For an example see -- [app/Main.hs](https://github.com/schell/reflex-sdl2/blob/master/app/Main.hs) module Reflex.SDL2 - (-- * Running an app + ( -- * Running an app host - -- * The reflex-sdl2 base type and constraints - , ReflexSDL2 + + -- * Gracefully shutting down an app + , shutdownOn + + -- * The reflex-sdl2 class + , HasSDL2Events (..) + -- * Base transformer , ReflexSDL2T + -- * Common constraints (most powerful but convenient) + , ReflexSDL2 + -- * Concrete stack , ConcreteReflexSDL2 + -- * Higher order switching , holdView , dynView - , -- * Time delta events - getDeltaTickEvent + + -- * Time and recurring timer events + , TickInfo(..) + , getDeltaTickEvent , performEventDelta - -- * *WithEventCode events - -- $witheventcode - , getRecurringTimerEventWithEventCode - , getAsyncEventWithEventCode - , delayEventWithEventCode - -- * User data - , userLocal + -- * Async events + , getAsyncEvent -- * Debugging , putDebugLnE - -- * SDL2 events - , getTicksEvent - , getAnySDLEvent - , getWindowShownEvent - , getWindowHiddenEvent - , getWindowExposedEvent - , getWindowMovedEvent - , getWindowResizedEvent - , getWindowSizeChangedEvent - , getWindowMinimizedEvent - , getWindowMaximizedEvent - , getWindowRestoredEvent - , getWindowGainedMouseFocusEvent - , getWindowLostMouseFocusEvent - , getWindowGainedKeyboardFocusEvent - , getWindowLostKeyboardFocusEvent - , getWindowClosedEvent - , getKeyboardEvent - , getTextEditingEvent - , getTextInputEvent - , getKeymapChangedEvent - , getMouseMotionEvent - , getMouseButtonEvent - , getMouseWheelEvent - , getJoyAxisEvent - , getJoyBallEvent - , getJoyHatEvent - , getJoyButtonEvent - , getJoyDeviceEvent - , getControllerAxisEvent - , getControllerButtonEvent - , getControllerDeviceEvent - , getAudioDeviceEvent - , getQuitEvent - , getUserEvent - , getSysWMEvent - , getTouchFingerEvent - , getMultiGestureEvent - , getDollarGestureEvent - , getDropEvent - , getClipboardUpdateEvent - , getUnknownEvent - , getUserData - -- * Re-exports - , module Reflex , module SDL , MonadIO , liftIO ) where -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (async) -import Control.Monad (forM_, void) -import Control.Monad.Exception (MonadException) +import Control.Concurrent (newChan, newEmptyMVar, putMVar, + readChan, takeMVar) +import Control.Concurrent.Async (async, cancel) +import Control.Monad (forM_, unless, void) import Control.Monad.Fix (MonadFix) import Control.Monad.Identity (Identity (..)) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -103,156 +63,32 @@ import Control.Monad.Ref (readRef) import Data.Dependent.Sum (DSum ((:=>))) import Data.Function (fix) -import Data.Int (Int32) import Data.Word (Word32) -import Foreign.Marshal.Alloc (malloc, free) -import Foreign.Ptr (castPtr, Ptr) -import Foreign.Storable (Storable (..)) +import GHC.Conc (atomically, newTVar, readTVar, + readTVarIO, writeTVar) import Reflex hiding (Additive) import Reflex.Host.Class -import SDL hiding (Event) +import SDL hiding (Event, delay) +import Reflex.SDL2.Base +import Reflex.SDL2.Class import Reflex.SDL2.Internal ------------------------------------------------------------------------------ -- | A collection of constraints that represent the default reflex-sdl2 network. -type ReflexSDL2 r t m = - ( Reflex t - , MonadHold t m - , MonadSample t m - , MonadAdjust t m - , PostBuild t m - , PerformEvent t m - , MonadFix m - , MonadIO m - , MonadIO (Performable m) - , MonadReader (SystemEvents r t) m - ) - - ------------------------------------------------------------------------------- --- | Run a @('Reader' 'SystemEvents' r t)@ computation with a modified --- 'sysUserData' @r@. -userLocal :: MonadReader (SystemEvents r t) m => (r -> r) -> m a -> m a -userLocal f = local (\se -> se{sysUserData = f $ sysUserData se}) - - ------------------------------------------------------------------------------- --- | Provides a basic implementation of 'ReflexSDL2' constraints. -newtype ReflexSDL2T r t (m :: * -> *) a = - ReflexSDL2T { runReflexSDL2T :: ReaderT (SystemEvents r t) m a } - -deriving instance (ReflexHost t, Functor m) => Functor (ReflexSDL2T r t m) -deriving instance (ReflexHost t, Applicative m) => Applicative (ReflexSDL2T r t m) -deriving instance (ReflexHost t, Monad m) => Monad (ReflexSDL2T r t m) -deriving instance (ReflexHost t, MonadFix m) => MonadFix (ReflexSDL2T r t m) -deriving instance (ReflexHost t, Monad m) => MonadReader (SystemEvents r t) (ReflexSDL2T r t m) -deriving instance (ReflexHost t, MonadIO m) => MonadIO (ReflexSDL2T r t m) -deriving instance ReflexHost t => MonadTrans (ReflexSDL2T r t) -deriving instance (ReflexHost t, MonadException m) => MonadException (ReflexSDL2T r t m) - - ------------------------------------------------------------------------------- --- | 'ReflexSDL2T' is an instance of 'PostBuild'. -instance (Reflex t, PostBuild t m, ReflexHost t, Monad m) => PostBuild t (ReflexSDL2T r t m) where - getPostBuild = lift getPostBuild - - ------------------------------------------------------------------------------- --- | 'ReflexSDL2T' is an instance of 'PerformEvent'. -instance (ReflexHost t, PerformEvent t m) => PerformEvent t (ReflexSDL2T r t m) where - type Performable (ReflexSDL2T r t m) = ReflexSDL2T r t (Performable m) - performEvent_ = ReflexSDL2T . performEvent_ . fmap runReflexSDL2T - performEvent = ReflexSDL2T . performEvent . fmap runReflexSDL2T - - ------------------------------------------------------------------------------- --- | 'ReflexSDL2T' is an instance of 'MonadAdjust'. -instance ( Reflex t - , ReflexHost t - , MonadAdjust t m - , Monad m - --, PrimMonad (HostFrame t) - ) => MonadAdjust t (ReflexSDL2T r t m) where - runWithReplace ma evmb = - ReflexSDL2T $ runWithReplace (runReflexSDL2T ma) (runReflexSDL2T <$> evmb) - traverseDMapWithKeyWithAdjust kvma dMapKV = ReflexSDL2T . - traverseDMapWithKeyWithAdjust (\ka -> runReflexSDL2T . kvma ka) dMapKV - traverseDMapWithKeyWithAdjustWithMove kvma dMapKV = ReflexSDL2T . - traverseDMapWithKeyWithAdjustWithMove (\ka -> runReflexSDL2T . kvma ka) dMapKV - - ------------------------------------------------------------------------------- --- | 'ReflexSDL2T' is an instance of 'MonadHold'. -instance ( ReflexHost t - , Applicative m - , Monad m - , MonadSample t m - ) => MonadSample t (ReflexSDL2T r t m) where - sample = lift . sample - - ------------------------------------------------------------------------------- --- | 'ReflexSDL2T' is an instance of 'MonadHold'. -instance (ReflexHost t, MonadHold t m) => MonadHold t (ReflexSDL2T r t m) where - hold a = lift . hold a - holdDyn a = lift . holdDyn a - holdIncremental p = lift . holdIncremental p - buildDynamic ma = lift . buildDynamic ma - - --------------------------------------------------------------------------------- -data TimerData = TimerData Int32 Timestamp - - -toTimerData :: Int32 -> RegisteredEventData -> Timestamp -> IO (Maybe TimerData) -toTimerData eventCode rdat ts - | eventCode == registeredEventCode rdat = - return $ Just $ TimerData eventCode ts - | otherwise = return Nothing - - -fromTimerData :: TimerData -> IO RegisteredEventData -fromTimerData (TimerData code _) = - return $ emptyRegisteredEvent{ registeredEventCode = code } - - --------------------------------------------------------------------------------- --- $witheventcode --- The *WithEventCode flavor of events use sdl2's user events system. Each --- function evaluates on the current thread, returning an 'Event' that will fire --- on the main thread and can be used to drive GL updates. It uses sdl2's --- user event machinery, requiring a special single use event code to identify --- the event on the other side of sdl2's FFI. This is a great use case for a --- @Fresh@ effect in your app. --------------------------------------------------------------------------------- - --- | Retrieves an event that fires every 'n' milliseconds. -getRecurringTimerEventWithEventCode - :: ReflexSDL2 r t m - => Int32 - -- ^ Single use event code. - -> Int - -- ^ Number of milliseconds. - -> m (Event t ()) -getRecurringTimerEventWithEventCode eventCode n = do - -- Register the timer event as a user event so it will wake `waitEvent` when - -- pushed into the queue. - let toData = toTimerData eventCode - registerEvent toData fromTimerData >>= \case - Nothing -> return () - Just (RegisteredEventType pushIt _) -> liftIO $ void $ async $ fix $ \loop -> do - threadDelay $ n * 1000 - ts <- ticks - pushIt (TimerData eventCode ts) >>= \case - EventPushSuccess -> return () - EventPushFiltered -> putStrLn "timer push filtered" - EventPushFailure t -> print t - loop - -- Filter the user event to only fire when the incoming code matches. - evUser <- getUserEvent - return $ fmapMaybe (guard . (eventCode ==) . userEventCode) evUser +type ReflexSDL2 t m = ( Reflex t + , MonadHold t m + , MonadSample t m + , Adjustable t m + , PostBuild t m + , PerformEvent t m + , TriggerEvent t m + , MonadFix m + , MonadIO m + , MonadIO (Performable m) + , HasSDL2Events t m + ) -------------------------------------------------------------------------------- @@ -260,233 +96,56 @@ -- since the last frame. -- Be aware that subscribing to this 'Event' (by using it in a monadic action) -- will result in your app running sdl2's event loop every frame. -getDeltaTickEvent :: ReflexSDL2 r t m => m (Event t Word32) +getDeltaTickEvent + :: (MonadHold t m, MonadFix m, HasSDL2Events t m) => m (Event t Word32) getDeltaTickEvent = do let f (lastTick, _) thisTick = (thisTick, thisTick - lastTick) - evTickAndDel <- accum f (0, 0) =<< asks sysTicksEvent + evTickAndDel <- accum f (0, 0) =<< getTicksEvent return $ snd <$> evTickAndDel -- | Populate the event value with the time in milliseconds since the last time -- the event fired. -performEventDelta :: ReflexSDL2 r t m => Event t a -> m (Event t Word32) +performEventDelta :: ReflexSDL2 t m => Event t a -> m (Event t Word32) performEventDelta ev = do tnow <- ticks evTicks <- performEvent $ ticks <$ ev fmap fst <$> accum (\(_, prev) now -> (now - prev, now)) (0, tnow) evTicks -readAndFreePtr :: Storable a => Ptr () -> IO a -readAndFreePtr ptr = do - a <- peek $ castPtr ptr - free ptr - return a - - -registerAndPushAsync :: (MonadIO m, Storable a) => Int32 -> IO a -> m () -registerAndPushAsync eventCode action = do - let toData rdat _ - | eventCode == registeredEventCode rdat = - Just <$> readAndFreePtr (registeredEventData1 rdat) - | otherwise = return Nothing - fromData a = do - ptr <- malloc - poke ptr a - return $ emptyRegisteredEvent{ registeredEventCode = eventCode - , registeredEventData1 = castPtr ptr - } - registerEvent toData fromData >>= \case - Nothing -> return () - Just (RegisteredEventType pushIt _) -> liftIO $ void $ async $ do - a <- action - pushIt a >>= \case - EventPushSuccess -> return () - EventPushFiltered -> putStrLn "async push filtered" - EventPushFailure t -> print t - - -getStorableUserEventWithEventCode - :: (ReflexSDL2 r t m, Storable a) => Int32 -> m (Event t a) -getStorableUserEventWithEventCode code = do - evUser <- getUserEvent - let evUserFilt = fmapMaybe (\udat -> udat <$ guard (code == userEventCode udat)) - evUser - performEvent $ liftIO . readAndFreePtr . userEventData1 <$> evUserFilt - - -------------------------------------------------------------------------------- --- | Executes the given IO action in a separate thread asynchronously and --- returns an 'Event' that fires on the main thread with the result value --- of that action. This uses sdl2's user events system, which requires that --- the action result have an instance of 'Storable'. --- --- Your 'a' type gets marshalled to C FFI and back, hence the --- 'Storable' requirement. -getAsyncEventWithEventCode - :: (ReflexSDL2 r t m, Storable a) => Int32 -> IO a -> m (Event t a) -getAsyncEventWithEventCode eventCode action = do - registerAndPushAsync eventCode action - getStorableUserEventWithEventCode eventCode +getAsyncEvent :: ReflexSDL2 t m => IO a -> m (Event t a) +getAsyncEvent f = do + (ev, g) <- newTriggerEvent + void $ liftIO $ async $ f >>= g + return ev -------------------------------------------------------------------------------- --- | Delays the given event by the given number of milliseconds. -delayEventWithEventCode - :: (ReflexSDL2 r t m, Storable a) => Int32 -> Int -> Event t a -> m (Event t a) -delayEventWithEventCode code millis ev = do - performEvent_ $ ffor ev $ \a -> - registerAndPushAsync code $ threadDelay (millis * 1000) >> return a - getStorableUserEventWithEventCode code - --------------------------------------------------------------------------------- --- SDL2 Events --------------------------------------------------------------------------------- -getTicksEvent :: ReflexSDL2 r t m => m (Event t Word32) -getTicksEvent = asks sysTicksEvent - -getAnySDLEvent :: ReflexSDL2 r t m => m (Event t EventPayload) -getAnySDLEvent = asks sysAnySDLEvent - -getWindowShownEvent :: ReflexSDL2 r t m => m (Event t WindowShownEventData) -getWindowShownEvent = asks sysWindowShownEvent - -getWindowHiddenEvent :: ReflexSDL2 r t m => m (Event t WindowHiddenEventData) -getWindowHiddenEvent = asks sysWindowHiddenEvent - -getWindowExposedEvent :: ReflexSDL2 r t m => m (Event t WindowExposedEventData) -getWindowExposedEvent = asks sysWindowExposedEvent - -getWindowMovedEvent :: ReflexSDL2 r t m => m (Event t WindowMovedEventData) -getWindowMovedEvent = asks sysWindowMovedEvent - -getWindowResizedEvent :: ReflexSDL2 r t m => m (Event t WindowResizedEventData) -getWindowResizedEvent = asks sysWindowResizedEvent - -getWindowSizeChangedEvent :: ReflexSDL2 r t m => m (Event t WindowSizeChangedEventData) -getWindowSizeChangedEvent = asks sysWindowSizeChangedEvent - -getWindowMinimizedEvent :: ReflexSDL2 r t m => m (Event t WindowMinimizedEventData) -getWindowMinimizedEvent = asks sysWindowMinimizedEvent - -getWindowMaximizedEvent :: ReflexSDL2 r t m => m (Event t WindowMaximizedEventData) -getWindowMaximizedEvent = asks sysWindowMaximizedEvent - -getWindowRestoredEvent :: ReflexSDL2 r t m => m (Event t WindowRestoredEventData) -getWindowRestoredEvent = asks sysWindowRestoredEvent - -getWindowGainedMouseFocusEvent :: ReflexSDL2 r t m => m (Event t WindowGainedMouseFocusEventData) -getWindowGainedMouseFocusEvent = asks sysWindowGainedMouseFocusEvent - -getWindowLostMouseFocusEvent :: ReflexSDL2 r t m => m (Event t WindowLostMouseFocusEventData) -getWindowLostMouseFocusEvent = asks sysWindowLostMouseFocusEvent - -getWindowGainedKeyboardFocusEvent :: ReflexSDL2 r t m => m (Event t WindowGainedKeyboardFocusEventData) -getWindowGainedKeyboardFocusEvent = asks sysWindowGainedKeyboardFocusEvent - -getWindowLostKeyboardFocusEvent :: ReflexSDL2 r t m => m (Event t WindowLostKeyboardFocusEventData) -getWindowLostKeyboardFocusEvent = asks sysWindowLostKeyboardFocusEvent - -getWindowClosedEvent :: ReflexSDL2 r t m => m (Event t WindowClosedEventData) -getWindowClosedEvent = asks sysWindowClosedEvent - -getKeyboardEvent :: ReflexSDL2 r t m => m (Event t KeyboardEventData) -getKeyboardEvent = asks sysKeyboardEvent - -getTextEditingEvent :: ReflexSDL2 r t m => m (Event t TextEditingEventData) -getTextEditingEvent = asks sysTextEditingEvent - -getTextInputEvent :: ReflexSDL2 r t m => m (Event t TextInputEventData) -getTextInputEvent = asks sysTextInputEvent - -getKeymapChangedEvent :: ReflexSDL2 r t m => m (Event t ()) -getKeymapChangedEvent = asks sysKeymapChangedEvent - -getMouseMotionEvent :: ReflexSDL2 r t m => m (Event t MouseMotionEventData) -getMouseMotionEvent = asks sysMouseMotionEvent - -getMouseButtonEvent :: ReflexSDL2 r t m => m (Event t MouseButtonEventData) -getMouseButtonEvent = asks sysMouseButtonEvent - -getMouseWheelEvent :: ReflexSDL2 r t m => m (Event t MouseWheelEventData) -getMouseWheelEvent = asks sysMouseWheelEvent - -getJoyAxisEvent :: ReflexSDL2 r t m => m (Event t JoyAxisEventData) -getJoyAxisEvent = asks sysJoyAxisEvent - -getJoyBallEvent :: ReflexSDL2 r t m => m (Event t JoyBallEventData) -getJoyBallEvent = asks sysJoyBallEvent - -getJoyHatEvent :: ReflexSDL2 r t m => m (Event t JoyHatEventData) -getJoyHatEvent = asks sysJoyHatEvent - -getJoyButtonEvent :: ReflexSDL2 r t m => m (Event t JoyButtonEventData) -getJoyButtonEvent = asks sysJoyButtonEvent - -getJoyDeviceEvent :: ReflexSDL2 r t m => m (Event t JoyDeviceEventData) -getJoyDeviceEvent = asks sysJoyDeviceEvent - -getControllerAxisEvent :: ReflexSDL2 r t m => m (Event t ControllerAxisEventData) -getControllerAxisEvent = asks sysControllerAxisEvent - -getControllerButtonEvent :: ReflexSDL2 r t m => m (Event t ControllerButtonEventData) -getControllerButtonEvent = asks sysControllerButtonEvent - -getControllerDeviceEvent :: ReflexSDL2 r t m => m (Event t ControllerDeviceEventData) -getControllerDeviceEvent = asks sysControllerDeviceEvent - -getAudioDeviceEvent :: ReflexSDL2 r t m => m (Event t AudioDeviceEventData) -getAudioDeviceEvent = asks sysAudioDeviceEvent - -getQuitEvent :: ReflexSDL2 r t m => m (Event t ()) -getQuitEvent = asks sysQuitEvent - -getUserEvent :: ReflexSDL2 r t m => m (Event t UserEventData) -getUserEvent = asks sysUserEvent - -getSysWMEvent :: ReflexSDL2 r t m => m (Event t SysWMEventData) -getSysWMEvent = asks sysSysWMEvent - -getTouchFingerEvent :: ReflexSDL2 r t m => m (Event t TouchFingerEventData) -getTouchFingerEvent = asks sysTouchFingerEvent - -getMultiGestureEvent :: ReflexSDL2 r t m => m (Event t MultiGestureEventData) -getMultiGestureEvent = asks sysMultiGestureEvent - -getDollarGestureEvent :: ReflexSDL2 r t m => m (Event t DollarGestureEventData) -getDollarGestureEvent = asks sysDollarGestureEvent - -getDropEvent :: ReflexSDL2 r t m => m (Event t DropEventData) -getDropEvent = asks sysDropEvent - -getClipboardUpdateEvent :: ReflexSDL2 r t m => m (Event t ()) -getClipboardUpdateEvent = asks sysClipboardUpdateEvent - -getUnknownEvent :: ReflexSDL2 r t m => m (Event t UnknownEventData) -getUnknownEvent = asks sysUnknownEvent - -getUserData :: ReflexSDL2 r t m => m r -getUserData = asks sysUserData +-- $grace +-- | Will exit the main reflex-sdl2 loop when the given Event fires. This allows +-- the programmer to shut down the network before shutting down SDL. +shutdownOn + :: (PerformEvent t m, MonadIO (Performable m), HasSDL2Events t m) + => Event t () + -> m () +shutdownOn ev = do + var <- getQuitVar + performEvent_ $ liftIO (putMVar var ()) <$ ev -------------------------------------------------------------------------------- --- | The concrete/specialized type used to run reflex-sdl2 apps. -type ConcreteReflexSDL2 r = - ReflexSDL2T r Spider (PostBuildT Spider (PerformEventT Spider (SpiderHost Global))) - ---deriving instance MonadReader (SystemEvents r Spider) (ConcreteReflexSDL2 r) +-- | The monomorphic type used to run reflex-sdl2 apps. +type ConcreteReflexSDL2 = ReflexSDL2T Spider (TriggerEventT Spider (PostBuildT Spider (PerformEventT Spider (SpiderHost Global)))) ------------------------------------------------------------------------------ --- | Host a reflex-sdl2 app. This function is your application's main loop and --- will not terminate. +-- | Host a reflex-sdl2 app. host - :: r - -- ^ A user data value of type 'r'. - -- Use 'getUserData' to access this value within your app network. - -> ConcreteReflexSDL2 r () + :: ConcreteReflexSDL2 () -- ^ A concrete reflex-sdl2 network to run. - -> IO void -host sysUserData app = runSpiderHost $ do + -> IO () +host app = runSpiderHost $ do -- Get events and trigger refs for all things that can happen. (sysPostBuildEvent, trPostBuildRef) <- newEventWithTriggerRef (sysAnySDLEvent, trAnySDLRef) <- newEventWithTriggerRef @@ -532,11 +191,43 @@ (sysClipboardUpdateEvent, trClipboardUpdateRef) <- newEventWithTriggerRef (sysUnknownEvent, trUnknownRef) <- newEventWithTriggerRef - -- Build the network and get our firing command to trigger the post build event. + -- Build the network and get our firing command to trigger the post build event, + -- then loop forever in another thread, dequeueing triggers from our chan and + -- placing them into a TVar. Push a new user event into the SDL event queue that + -- will set off a read of the TVar and the firing of the triggers within the + -- main loop. + -- Also - create som quit vars to communicate when our loops should absolutely end. + chan <- liftIO newChan + triggersVar <- liftIO $ atomically $ newTVar [] + sysQuitVar <- liftIO newEmptyMVar + mainQuitVar <- liftIO $ atomically $ newTVar False + let reservedTriggerCode = 31337 + isJustTriggerData dat _ = + return $ guard $ registeredEventCode dat == reservedTriggerCode + fromData () = return emptyRegisteredEvent{ registeredEventCode = reservedTriggerCode } + pushTrig <- registerEvent isJustTriggerData fromData >>= \case + Nothing -> error "Could not register an sdl event for TriggerEvent." + Just (RegisteredEventType pushTrig _) -> return pushTrig + asyncTrigger <- liftIO $ async $ fix $ \loop -> do + trigs <- readChan chan + atomically $ do + prevTrigs <- readTVar triggersVar + writeTVar triggersVar $ prevTrigs ++ trigs + pushTrig () >>= \case + EventPushSuccess -> return () + EventPushFiltered -> putStrLn "trigger push filtered" + EventPushFailure t -> print t + loop + void $ liftIO $ async $ do + takeMVar sysQuitVar + atomically $ writeTVar mainQuitVar True + void $ pushTrig () + cancel asyncTrigger + ((), FireCommand fire) <- - hostPerformEventT $ - runPostBuildT (runReaderT (runReflexSDL2T app) SystemEvents{..}) - sysPostBuildEvent + hostPerformEventT $ flip runPostBuildT sysPostBuildEvent + $ flip runTriggerEventT chan + $ runReflexSDL2T app SystemEvents{..} -- Trigger the post build event. (readRef trPostBuildRef >>=) . mapM_ $ \tr -> @@ -544,14 +235,14 @@ -- Loop forever doing all of our main loop stuff. fix $ \loop -> do - -- Fire any tick events, if anyone is listening. + -- Fire any tick events if anyone is listening. -- If someone _is_ listening, we need to fire an -- event every frame - otherwise we can wait around -- for an sdl event to update the network. - t <- ticks shouldWait <- readRef trTicksRef >>= \case Nothing -> return True Just tr -> do + t <- ticks void $ fire [tr :=> Identity t] $ return () return False @@ -623,8 +314,19 @@ fire [tr :=> Identity dat] $ return () QuitEvent -> (readRef trQuitRef >>=) . mapM_ $ \tr -> fire [tr :=> Identity ()] $ return () - UserEvent dat -> (readRef trUserRef >>=) . mapM_ $ \tr -> - fire [tr :=> Identity dat] $ return () + UserEvent dat -> + -- We've found some triggered reflex events, read them and fire them. + if userEventCode dat == reservedTriggerCode + then do + triggers <- liftIO $ atomically $ do + trigs <- readTVar triggersVar + writeTVar triggersVar [] + return trigs + forM_ triggers $ \(EventTriggerRef ref :=> TriggerInvocation a _cb) -> + (readRef ref >>=) . mapM_ $ \tr -> fire [tr :=> Identity a] $ return () + -- Run the callbacks of those triggered events. + forM_ triggers $ \(_ :=> TriggerInvocation _a cb) -> liftIO cb + else (readRef trUserRef >>=) . mapM_ $ \tr -> fire [tr :=> Identity dat] $ return () SysWMEvent dat -> (readRef trSysWMRef >>=) . mapM_ $ \tr -> fire [tr :=> Identity dat] $ return () TouchFingerEvent dat -> (readRef trTouchFingerRef >>=) . mapM_ $ \tr -> @@ -647,7 +349,8 @@ forM_ payloads $ \payload -> fire [tr :=> Identity payload] $ return () - loop + shouldQuit <- liftIO $ readTVarIO mainQuitVar + unless shouldQuit loop ------------------------------------------------------------------------------ @@ -667,7 +370,7 @@ -- with the network of the 'Event's value. This process is repeated each time -- the 'Event' fires a new network. Returns a 'Dynamic' of the inner network's -- result that updates any time the 'Event' fires. -holdView :: ReflexSDL2 r t m => m a -> Event t (m a) -> m (Dynamic t a) +holdView :: ReflexSDL2 t m => m a -> Event t (m a) -> m (Dynamic t a) holdView child0 newChild = do (result0, newResult) <- runWithReplace child0 newChild holdDyn result0 newResult @@ -677,7 +380,7 @@ -- | Run a 'Dynamic'ally changing network, replacing the current one with the -- new one every time the 'Dynamic' updates. Returns an 'Event' of the inner -- network's result value that fires every time the 'Dynamic' changes. -dynView :: ReflexSDL2 r t m => Dynamic t (m a) -> m (Event t a) +dynView :: ReflexSDL2 t m => Dynamic t (m a) -> m (Event t a) dynView child = do evPB <- getPostBuild let newChild = leftmost [updated child, tagCheap (current child) evPB] diff --git a/src/Reflex/SDL2/Base.hs b/src/Reflex/SDL2/Base.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/SDL2/Base.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Reflex.SDL2.Base + ( ReflexSDL2T (..) + , runReflexSDL2T + ) where + + +import Control.Monad.Exception (MonadException) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader +import Reflex hiding (Additive) +import Reflex.Host.Class + +import Reflex.SDL2.Class +import Reflex.SDL2.Internal + + +------------------------------------------------------------------------------ +-- | Provides an implementation of the 'HasSDL2Events' type class. +newtype ReflexSDL2T t (m :: * -> *) a = + ReflexSDL2T { unReflexSDL2T :: ReaderT (SystemEvents t) m a } + + +runReflexSDL2T :: ReflexSDL2T t m a -> SystemEvents t -> m a +runReflexSDL2T = runReaderT . unReflexSDL2T + + +deriving instance (ReflexHost t, Functor m) => Functor (ReflexSDL2T t m) +deriving instance (ReflexHost t, Applicative m) => Applicative (ReflexSDL2T t m) +deriving instance (ReflexHost t, Monad m) => Monad (ReflexSDL2T t m) +deriving instance (ReflexHost t, MonadFix m) => MonadFix (ReflexSDL2T t m) +deriving instance (ReflexHost t, MonadIO m) => MonadIO (ReflexSDL2T t m) +deriving instance ReflexHost t => MonadTrans (ReflexSDL2T t) +deriving instance (ReflexHost t, MonadException m) => MonadException (ReflexSDL2T t m) +deriving instance (ReflexHost t, TriggerEvent t m) => TriggerEvent t (ReflexSDL2T t m) + + +askSys :: Monad m => (SystemEvents t -> a) -> ReflexSDL2T t m a +askSys = ReflexSDL2T . asks + + +instance (ReflexHost t, Monad m) => HasSDL2Events t (ReflexSDL2T t m) where + getTicksEvent = askSys sysTicksEvent + getAnySDLEvent = askSys sysAnySDLEvent + getWindowShownEvent = askSys sysWindowShownEvent + getWindowHiddenEvent = askSys sysWindowHiddenEvent + getWindowExposedEvent = askSys sysWindowExposedEvent + getWindowMovedEvent = askSys sysWindowMovedEvent + getWindowResizedEvent = askSys sysWindowResizedEvent + getWindowSizeChangedEvent = askSys sysWindowSizeChangedEvent + getWindowMinimizedEvent = askSys sysWindowMinimizedEvent + getWindowMaximizedEvent = askSys sysWindowMaximizedEvent + getWindowRestoredEvent = askSys sysWindowRestoredEvent + getWindowGainedMouseFocusEvent = askSys sysWindowGainedMouseFocusEvent + getWindowLostMouseFocusEvent = askSys sysWindowLostMouseFocusEvent + getWindowGainedKeyboardFocusEvent = askSys sysWindowGainedKeyboardFocusEvent + getWindowLostKeyboardFocusEvent = askSys sysWindowLostKeyboardFocusEvent + getWindowClosedEvent = askSys sysWindowClosedEvent + getKeyboardEvent = askSys sysKeyboardEvent + getTextEditingEvent = askSys sysTextEditingEvent + getTextInputEvent = askSys sysTextInputEvent + getKeymapChangedEvent = askSys sysKeymapChangedEvent + getMouseMotionEvent = askSys sysMouseMotionEvent + getMouseButtonEvent = askSys sysMouseButtonEvent + getMouseWheelEvent = askSys sysMouseWheelEvent + getJoyAxisEvent = askSys sysJoyAxisEvent + getJoyBallEvent = askSys sysJoyBallEvent + getJoyHatEvent = askSys sysJoyHatEvent + getJoyButtonEvent = askSys sysJoyButtonEvent + getJoyDeviceEvent = askSys sysJoyDeviceEvent + getControllerAxisEvent = askSys sysControllerAxisEvent + getControllerButtonEvent = askSys sysControllerButtonEvent + getControllerDeviceEvent = askSys sysControllerDeviceEvent + getAudioDeviceEvent = askSys sysAudioDeviceEvent + getQuitEvent = askSys sysQuitEvent + getUserEvent = askSys sysUserEvent + getSysWMEvent = askSys sysSysWMEvent + getTouchFingerEvent = askSys sysTouchFingerEvent + getMultiGestureEvent = askSys sysMultiGestureEvent + getDollarGestureEvent = askSys sysDollarGestureEvent + getDropEvent = askSys sysDropEvent + getClipboardUpdateEvent = askSys sysClipboardUpdateEvent + getUnknownEvent = askSys sysUnknownEvent + getQuitVar = askSys sysQuitVar + + +------------------------------------------------------------------------------ +-- | 'ReflexSDL2T' is an instance of 'PostBuild'. +instance (Reflex t, PostBuild t m, ReflexHost t, Monad m) => PostBuild t (ReflexSDL2T t m) where + getPostBuild = lift getPostBuild + + +------------------------------------------------------------------------------ +-- | 'ReflexSDL2T' is an instance of 'PerformEvent'. +instance (ReflexHost t, PerformEvent t m) => PerformEvent t (ReflexSDL2T t m) where + type Performable (ReflexSDL2T t m) = ReflexSDL2T t (Performable m) + performEvent_ = ReflexSDL2T . performEvent_ . fmap unReflexSDL2T + performEvent = ReflexSDL2T . performEvent . fmap unReflexSDL2T + + +------------------------------------------------------------------------------ +-- | 'ReflexSDL2T' is an instance of 'Adjustable'. +instance ( Reflex t + , ReflexHost t + , Adjustable t m + , Monad m + ) => Adjustable t (ReflexSDL2T t m) where + runWithReplace ma evmb = + ReflexSDL2T $ runWithReplace (unReflexSDL2T ma) (unReflexSDL2T <$> evmb) + traverseDMapWithKeyWithAdjust kvma dMapKV = ReflexSDL2T . + traverseDMapWithKeyWithAdjust (\ka -> unReflexSDL2T . kvma ka) dMapKV + traverseDMapWithKeyWithAdjustWithMove kvma dMapKV = ReflexSDL2T . + traverseDMapWithKeyWithAdjustWithMove (\ka -> unReflexSDL2T . kvma ka) dMapKV + traverseIntMapWithKeyWithAdjust f im = ReflexSDL2T . + traverseIntMapWithKeyWithAdjust (\ka -> unReflexSDL2T . f ka) im + + +------------------------------------------------------------------------------ +-- | 'ReflexSDL2T' is an instance of 'MonadHold'. +instance ( ReflexHost t + , Applicative m + , Monad m + , MonadSample t m + ) => MonadSample t (ReflexSDL2T t m) where + sample = lift . sample + + +------------------------------------------------------------------------------ +-- | 'ReflexSDL2T' is an instance of 'MonadHold'. +instance (ReflexHost t, MonadHold t m) => MonadHold t (ReflexSDL2T t m) where + hold a = lift . hold a + holdDyn a = lift . holdDyn a + holdIncremental p = lift . holdIncremental p + buildDynamic ma = lift . buildDynamic ma + headE = lift . headE diff --git a/src/Reflex/SDL2/Class.hs b/src/Reflex/SDL2/Class.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/SDL2/Class.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +module Reflex.SDL2.Class where + + +import Control.Concurrent (MVar) +import Control.Monad.Reader (ReaderT) +import Control.Monad.Trans (lift) +import Data.Word (Word32) +import Reflex (Event, Reflex) +import Reflex.DynamicWriter.Base (DynamicWriterT) +import SDL hiding (Event) + + +class (Reflex t, Monad m) => HasSDL2Events t m | m -> t where + getTicksEvent :: m (Event t Word32) + getAnySDLEvent :: m (Event t EventPayload) + getWindowShownEvent :: m (Event t WindowShownEventData) + getWindowHiddenEvent :: m (Event t WindowHiddenEventData) + getWindowExposedEvent :: m (Event t WindowExposedEventData) + getWindowMovedEvent :: m (Event t WindowMovedEventData) + getWindowResizedEvent :: m (Event t WindowResizedEventData) + getWindowSizeChangedEvent :: m (Event t WindowSizeChangedEventData) + getWindowMinimizedEvent :: m (Event t WindowMinimizedEventData) + getWindowMaximizedEvent :: m (Event t WindowMaximizedEventData) + getWindowRestoredEvent :: m (Event t WindowRestoredEventData) + getWindowGainedMouseFocusEvent :: m (Event t WindowGainedMouseFocusEventData) + getWindowLostMouseFocusEvent :: m (Event t WindowLostMouseFocusEventData) + getWindowGainedKeyboardFocusEvent :: m (Event t WindowGainedKeyboardFocusEventData) + getWindowLostKeyboardFocusEvent :: m (Event t WindowLostKeyboardFocusEventData) + getWindowClosedEvent :: m (Event t WindowClosedEventData) + getKeyboardEvent :: m (Event t KeyboardEventData) + getTextEditingEvent :: m (Event t TextEditingEventData) + getTextInputEvent :: m (Event t TextInputEventData) + getKeymapChangedEvent :: m (Event t ()) + getMouseMotionEvent :: m (Event t MouseMotionEventData) + getMouseButtonEvent :: m (Event t MouseButtonEventData) + getMouseWheelEvent :: m (Event t MouseWheelEventData) + getJoyAxisEvent :: m (Event t JoyAxisEventData) + getJoyBallEvent :: m (Event t JoyBallEventData) + getJoyHatEvent :: m (Event t JoyHatEventData) + getJoyButtonEvent :: m (Event t JoyButtonEventData) + getJoyDeviceEvent :: m (Event t JoyDeviceEventData) + getControllerAxisEvent :: m (Event t ControllerAxisEventData) + getControllerButtonEvent :: m (Event t ControllerButtonEventData) + getControllerDeviceEvent :: m (Event t ControllerDeviceEventData) + getAudioDeviceEvent :: m (Event t AudioDeviceEventData) + getQuitEvent :: m (Event t ()) + getUserEvent :: m (Event t UserEventData) + getSysWMEvent :: m (Event t SysWMEventData) + getTouchFingerEvent :: m (Event t TouchFingerEventData) + getMultiGestureEvent :: m (Event t MultiGestureEventData) + getDollarGestureEvent :: m (Event t DollarGestureEventData) + getDropEvent :: m (Event t DropEventData) + getClipboardUpdateEvent :: m (Event t ()) + getUnknownEvent :: m (Event t UnknownEventData) + getQuitVar :: m (MVar ()) + + +instance HasSDL2Events t m => HasSDL2Events t (ReaderT r m) where + getTicksEvent = lift getTicksEvent + getAnySDLEvent = lift getAnySDLEvent + getWindowShownEvent = lift getWindowShownEvent + getWindowHiddenEvent = lift getWindowHiddenEvent + getWindowExposedEvent = lift getWindowExposedEvent + getWindowMovedEvent = lift getWindowMovedEvent + getWindowResizedEvent = lift getWindowResizedEvent + getWindowSizeChangedEvent = lift getWindowSizeChangedEvent + getWindowMinimizedEvent = lift getWindowMinimizedEvent + getWindowMaximizedEvent = lift getWindowMaximizedEvent + getWindowRestoredEvent = lift getWindowRestoredEvent + getWindowGainedMouseFocusEvent = lift getWindowGainedMouseFocusEvent + getWindowLostMouseFocusEvent = lift getWindowLostMouseFocusEvent + getWindowGainedKeyboardFocusEvent = lift getWindowGainedKeyboardFocusEvent + getWindowLostKeyboardFocusEvent = lift getWindowLostKeyboardFocusEvent + getWindowClosedEvent = lift getWindowClosedEvent + getKeyboardEvent = lift getKeyboardEvent + getTextEditingEvent = lift getTextEditingEvent + getTextInputEvent = lift getTextInputEvent + getKeymapChangedEvent = lift getKeymapChangedEvent + getMouseMotionEvent = lift getMouseMotionEvent + getMouseButtonEvent = lift getMouseButtonEvent + getMouseWheelEvent = lift getMouseWheelEvent + getJoyAxisEvent = lift getJoyAxisEvent + getJoyBallEvent = lift getJoyBallEvent + getJoyHatEvent = lift getJoyHatEvent + getJoyButtonEvent = lift getJoyButtonEvent + getJoyDeviceEvent = lift getJoyDeviceEvent + getControllerAxisEvent = lift getControllerAxisEvent + getControllerButtonEvent = lift getControllerButtonEvent + getControllerDeviceEvent = lift getControllerDeviceEvent + getAudioDeviceEvent = lift getAudioDeviceEvent + getQuitEvent = lift getQuitEvent + getUserEvent = lift getUserEvent + getSysWMEvent = lift getSysWMEvent + getTouchFingerEvent = lift getTouchFingerEvent + getMultiGestureEvent = lift getMultiGestureEvent + getDollarGestureEvent = lift getDollarGestureEvent + getDropEvent = lift getDropEvent + getClipboardUpdateEvent = lift getClipboardUpdateEvent + getUnknownEvent = lift getUnknownEvent + getQuitVar = lift getQuitVar + + +instance HasSDL2Events t m => HasSDL2Events t (DynamicWriterT t w m) where + getTicksEvent = lift getTicksEvent + getAnySDLEvent = lift getAnySDLEvent + getWindowShownEvent = lift getWindowShownEvent + getWindowHiddenEvent = lift getWindowHiddenEvent + getWindowExposedEvent = lift getWindowExposedEvent + getWindowMovedEvent = lift getWindowMovedEvent + getWindowResizedEvent = lift getWindowResizedEvent + getWindowSizeChangedEvent = lift getWindowSizeChangedEvent + getWindowMinimizedEvent = lift getWindowMinimizedEvent + getWindowMaximizedEvent = lift getWindowMaximizedEvent + getWindowRestoredEvent = lift getWindowRestoredEvent + getWindowGainedMouseFocusEvent = lift getWindowGainedMouseFocusEvent + getWindowLostMouseFocusEvent = lift getWindowLostMouseFocusEvent + getWindowGainedKeyboardFocusEvent = lift getWindowGainedKeyboardFocusEvent + getWindowLostKeyboardFocusEvent = lift getWindowLostKeyboardFocusEvent + getWindowClosedEvent = lift getWindowClosedEvent + getKeyboardEvent = lift getKeyboardEvent + getTextEditingEvent = lift getTextEditingEvent + getTextInputEvent = lift getTextInputEvent + getKeymapChangedEvent = lift getKeymapChangedEvent + getMouseMotionEvent = lift getMouseMotionEvent + getMouseButtonEvent = lift getMouseButtonEvent + getMouseWheelEvent = lift getMouseWheelEvent + getJoyAxisEvent = lift getJoyAxisEvent + getJoyBallEvent = lift getJoyBallEvent + getJoyHatEvent = lift getJoyHatEvent + getJoyButtonEvent = lift getJoyButtonEvent + getJoyDeviceEvent = lift getJoyDeviceEvent + getControllerAxisEvent = lift getControllerAxisEvent + getControllerButtonEvent = lift getControllerButtonEvent + getControllerDeviceEvent = lift getControllerDeviceEvent + getAudioDeviceEvent = lift getAudioDeviceEvent + getQuitEvent = lift getQuitEvent + getUserEvent = lift getUserEvent + getSysWMEvent = lift getSysWMEvent + getTouchFingerEvent = lift getTouchFingerEvent + getMultiGestureEvent = lift getMultiGestureEvent + getDollarGestureEvent = lift getDollarGestureEvent + getDropEvent = lift getDropEvent + getClipboardUpdateEvent = lift getClipboardUpdateEvent + getUnknownEvent = lift getUnknownEvent + getQuitVar = lift getQuitVar diff --git a/src/Reflex/SDL2/Internal.hs b/src/Reflex/SDL2/Internal.hs --- a/src/Reflex/SDL2/Internal.hs +++ b/src/Reflex/SDL2/Internal.hs @@ -4,9 +4,10 @@ -- need them :) module Reflex.SDL2.Internal where -import Data.Word (Word32) -import Reflex (Event) -import SDL hiding (Event) +import Control.Concurrent (MVar) +import Data.Word (Word32) +import Reflex (Event) +import SDL hiding (Event) ------------------------------------------------------------------------------ -- | Holds a slot of 'Event' for each kind of SDL2 event plus a couple extras: @@ -16,7 +17,7 @@ -- An event for reflex's post network build event. -- -- An event for each frame tick. -data SystemEvents r t = SystemEvents +data SystemEvents t = SystemEvents { sysPostBuildEvent :: Event t () -- ^ Fired just after the FRP network is built. , sysTicksEvent :: Event t Word32 @@ -64,6 +65,6 @@ , sysDropEvent :: Event t DropEventData , sysClipboardUpdateEvent :: Event t () , sysUnknownEvent :: Event t UnknownEventData - , sysUserData :: r - -- ^ A slot to hold any custom user data. + , sysQuitVar :: MVar () + -- ^ A var to sync quitting. }