reflex-sdl2 0.1.0.0 → 0.2.0.0
raw patch · 5 files changed
+863/−253 lines, 5 filesdep +asyncdep +containersdep +exception-transformersdep ~dependent-sumdep ~mtldep ~ref-tf
Dependencies added: async, containers, exception-transformers, primitive, stm
Dependency ranges changed: dependent-sum, mtl, ref-tf, reflex, sdl2
Files
- README.md +22/−13
- app/Main.hs +199/−36
- reflex-sdl2.cabal +16/−9
- src/Reflex/SDL2.hs +557/−195
- src/Reflex/SDL2/Internal.hs +69/−0
README.md view
@@ -1,19 +1,31 @@ # reflex-sdl2 -This is a very minimal host for running [reflex][2] apps using [sdl2][0].--## installation+This is a [reflex][2] host for [sdl2][0]. Writing and running [sdl2][0] apps requires version 2 of the awesome [SDL][1]-library.+library. If you have [nix][4] then the build process will install SDL2 for you. ++## 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.+ ### macOS Using [homebrew](https://brew.sh/)... brew install sdl2 -### Ubuntu+### Ubuntu / Debian The [sdl2 bindings][0] require SDL >= 2.0.4, or for special instructions to be followed. Assuming you're on `Ubuntu >= 16.04`, you can run@@ -22,23 +34,20 @@ otherwise please visit the org page above and install via their README. -## building -This project uses [stack][3] for building. From the project directory:-- stack build- ## examples -You can view an example using the built-in 2d renderer in+After building you can view an example using the built-in 2d renderer in [app/Main.hs](https://github.com/schell/reflex-sdl2/blob/master/app/Main.hs).+ To run the example do: - stack build- stack exec reflex-sdl2-exe+ stack --nix 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"
app/Main.hs view
@@ -1,66 +1,218 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} module Main where -import Control.Monad (forM_, void)+import Control.Concurrent (threadDelay)+import Control.Monad (forM_, guard, void) import Reflex.SDL2-import System.Exit (exitSuccess)+import System.Exit (exitSuccess) +--------------------------------------------------------------------------------+-- | An axis aligned bounding box. data AABB = AABB InputMotion (V2 Int) +--------------------------------------------------------------------------------+-- | Convert a mouse button to an AABB. mouseButtonToAABB :: MouseButtonEventData -> AABB mouseButtonToAABB dat = AABB (mouseButtonEventMotion dat) pos where P pos32 = mouseButtonEventPos dat pos = fromIntegral <$> pos32 +--------------------------------------------------------------------------------+-- | Convert a mouse button motion to color. motionToColor :: InputMotion -> V4 Int-motionToColor Released = V4 255 255 0 128-motionToColor Pressed = V4 255 0 255 128+motionToColor Released = V4 255 0 0 128+motionToColor Pressed = V4 0 0 255 128 -renderAABBs :: MonadIO m => Maybe Renderer -> [AABB] -> Maybe (m ())-renderAABBs mayRenderer aabbs = ffor mayRenderer $ \r -> do- rendererDrawColor r $= V4 0 0 0 255- clear r- forM_ aabbs $ \(AABB motion pos) -> do- let color = motionToColor motion- rendererDrawColor r $= (fromIntegral <$> color)- fillRect r $ Just $ Rectangle (P $ fromIntegral <$> pos - 10) 20- present r+--------------------------------------------------------------------------------+-- | Renders an AABB using the handy SDL 2d 'Renderer'.+renderAABB :: MonadIO m => Renderer -> V4 Int -> V2 Int -> m ()+renderAABB r color pos = do+ rendererDrawColor r $= (fromIntegral <$> color)+ fillRect r $ Just $ Rectangle (P $ fromIntegral <$> pos - 10) 20 -guest :: ReflexSDL2 t m => m ()-guest = do+-------------------------------------------------------------------------------+-- | A type representing one layer in our app.+type Layer m = Performable m ()+++----------------------------------------------------------------------+-- | Commit a layer stack that changes over time.+commitLayers :: (ReflexSDL2 r 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)+ => Dynamic t (Layer m) -> m ()+commitLayer = tellDyn . fmap pure+++ffor2 :: Reflex t => Dynamic t a -> Dynamic t b -> (a -> b -> c) -> Dynamic t c+ffor2 a b f = zipDynWith f a b++ffor2up+ :: Reflex t => Dynamic t a -> Dynamic t b1 -> ((a, b1) -> b) -> Dynamic t b+ffor2up a b = ffor (zipDyn a b)+++data ButtonState = ButtonStateUp+ | ButtonStateOver+ | ButtonStateDown+ deriving Eq+++buttonState :: Bool -> Bool -> ButtonState+buttonState isInside isDown+ | not isInside = ButtonStateUp+ | isDown = ButtonStateDown+ | otherwise = ButtonStateOver+++button :: (ReflexSDL2 r t m, MonadDynamicWriter t [Layer m] m)+ => Renderer+ -> m (Event t ButtonState)+button r = do+ evMotionData <- getMouseMotionEvent+ let position = V2 100 100+ size = V2 100 100+ V2 tlx tly = position+ V2 brx bry = position + size+ evMotionPos = fmap fromIntegral . mouseMotionEventPos <$> evMotionData+ evMouseIsInside = ffor evMotionPos $ \(P (V2 x y)) ->+ (x >= tlx && x <= brx) && (y >= tly && y <= bry)+ dMouseIsInside <- holdDyn False evMouseIsInside++ evBtn <- getMouseButtonEvent+ let evBtnIsDown = ffor evBtn $ (== Pressed) . mouseButtonEventMotion+ dButtonIsDown <- holdDyn False evBtnIsDown++ let dButtonStatePre = buttonState <$> dMouseIsInside <*> dButtonIsDown+ evPB <- getPostBuild+ dButtonState <- holdDyn ButtonStateUp $ leftmost [ updated dButtonStatePre+ , ButtonStateUp <$ evPB+ ]+ commitLayer $ ffor dButtonState $ \st -> do+ let color = case st of+ ButtonStateUp -> V4 192 192 192 255+ ButtonStateOver -> 255+ ButtonStateDown -> V4 128 128 128 255+ rendererDrawColor r $= color+ fillRect r $ Just $ Rectangle (P position) size++ updated <$> holdUniqDyn dButtonState+++guest+ :: (ReflexSDL2 r t m, MonadDynamicWriter t [Layer m] m)+ => Renderer+ -> m ()+guest r = do -- Print some stuff after the network is built.- evPB <- asks sysPostBuildEvent+ evPB <- getPostBuild performEvent_ $ ffor evPB $ \() -> liftIO $ putStrLn "starting up..."+ ------------------------------------------------------------------------------+ -- Test async events.+ -- This will wait three seconds before coloring the background black.+ ------------------------------------------------------------------------------+ evDelay <- getAsyncEventWithEventCode 0xBEEF $ threadDelay 3000000+ dDelay <- holdDyn False $ True <$ evDelay+ commitLayers $ ffor dDelay $ \case+ False -> pure $ do+ rendererDrawColor r $= V4 128 128 128 255+ fillRect r Nothing+ True -> pure $ do+ rendererDrawColor r $= V4 0 0 0 255+ fillRect r Nothing - -- Get the window shown event and use it to create a renderer event.- -- We use 'headE' because we only want to create one renderer, ever.- evWindow <- headE =<< asks (fmap windowShownEventWindow . sysWindowShownEvent)- evRenderer <- performEvent $ ffor evWindow $ \window -> do- liftIO $ putStrLn "creating renderer..."- r <- createRenderer window (-1) defaultRenderer- rendererDrawBlendMode r $= BlendAdditive- return r+ ------------------------------------------------------------------------------+ -- A button!+ ------------------------------------------------------------------------------+ evBtnState <- button r+ let evBtnPressed = fmapMaybe (guard . (== ButtonStateDown)) evBtnState+ performEvent_ $ ffor evBtnPressed $ const $ liftIO $ putStrLn "Button pressed!" + ------------------------------------------------------------------------------+ -- Ghosty trail of squares+ ------------------------------------------------------------------------------+ -- Gather all mouse motion events into a list, then commit a commitLayers that+ -- renders each move as a quarter alpha'd yello or cyan square.+ evMouseMove <- getMouseMotionEvent+ dMoves <- foldDyn (\x xs -> take 100 $ x : xs) [] evMouseMove+ commitLayer $ ffor dMoves $ \moves ->+ forM_ (reverse moves) $ \dat -> do+ let P pos = fromIntegral <$> mouseMotionEventPos dat+ color = if null (mouseMotionEventState dat)+ then V4 255 255 0 128+ else V4 0 255 255 128+ renderAABB r color pos++ ------------------------------------------------------------------------------+ -- Up and down squares+ ------------------------------------------------------------------------------ -- Get any mouse button event and accumulate them as a list of- -- AABBs. Then combine the dynamic list of AABBs with the renderer- -- to perform a rendering event.- evMouseButton <- asks sysMouseButtonEvent- dAABBs <- foldDyn (:) [] $ mouseButtonToAABB <$> evMouseButton- dMayRenderer <- holdDyn Nothing $ Just <$> evRenderer- let dRendering = renderAABBs <$> dMayRenderer <*> dAABBs- evRendering = fmapMaybe id $ updated dRendering- performEvent_ evRendering+ -- AABBs. Commit a commitLayers of those rendered up/down AABBs.+ evMouseButton <- getMouseButtonEvent+ dBtns <- foldDyn (\x xs -> take 100 $ x : xs) [] evMouseButton+ commitLayer $ ffor dBtns $ \btns ->+ forM_ (reverse btns) $ \dat -> do+ let AABB motion pos = mouseButtonToAABB dat+ color = motionToColor motion+ renderAABB r color pos - -- Quit on any quit event.- evQuit <- asks sysQuitEvent+ ------------------------------------------------------------------------------+ -- An ephemeral commitLayers that only renders when a key is down, and only listens+ -- to the tick event while that key is down.+ -- This is an example of the higher-order nature of the reflex network. We+ -- can update the shape of the network in response to events within it.+ ------------------------------------------------------------------------------+ evKey <- getKeyboardEvent+ let evKeyNoRepeat = fmapMaybe (\k -> k <$ guard (not $ keyboardEventRepeat k)) evKey+ dPressed <- holdDyn False $ ((== Pressed) . keyboardEventKeyMotion) <$> evKeyNoRepeat+ void $ holdView (return ()) $ ffor (updated dPressed) $ \case+ False -> return ()+ True -> do+ evDeltaTick <- getDeltaTickEvent+ dTimePressed <- foldDyn (+) 0 evDeltaTick+ commitLayer $ ffor dTimePressed $ \t -> do+ let wrap :: Float -> Int+ wrap x = if x > 255 then wrap (x - 255) else floor x+ rc = wrap $ fromIntegral t/1000 * 255+ gc = wrap $ fromIntegral t/2000 * 255+ bc = wrap $ fromIntegral t/3000 * 255+ color :: V4 Int+ color = fromIntegral <$> V4 rc gc bc 255+ renderAABB r color 100++ ------------------------------------------------------------------------------+ -- 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+ performDeltaSecondTimer 1+ performDeltaSecondTimer 2++ ------------------------------------------------------------------------------+ -- Quit on a quit event+ ------------------------------------------------------------------------------+ evQuit <- getQuitEvent performEvent_ $ ffor evQuit $ \() -> liftIO $ do putStrLn "bye!" exitSuccess@@ -75,5 +227,16 @@ , windowHighDPI = False , windowInitialSize = V2 640 480 }- createWindow "reflex-sdl2-exe" cfg >>= void . glCreateContext- host guest+ window <- createWindow "reflex-sdl2-exe" cfg+ void $ glCreateContext window++ 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
reflex-sdl2.cabal view
@@ -1,12 +1,12 @@ name: reflex-sdl2-version: 0.1.0.0+version: 0.2.0.0 synopsis: SDL2 and reflex FRP description: A minimal host for sdl2 based reflex apps. homepage: https://github.com/schell/reflex-sdl2#readme license: MIT license-file: LICENSE author: Schell Scivally-maintainer: efsubenovex@gmail.com+maintainer: schell@takt.com copyright: Copyright: (c) 2017 Schell Scivally category: Game build-type: Simple@@ -15,19 +15,26 @@ library hs-source-dirs: src+ ghc-options: -Wall exposed-modules: Reflex.SDL2- build-depends: base >= 4.7 && < 5- , dependent-sum >= 0.4- , mtl >= 2.2.1- , reflex- , ref-tf- , sdl2+ , Reflex.SDL2.Internal+ build-depends: async >= 2.1 && < 2.2+ , base >= 4.7 && < 5+ , containers >= 0.5 && < 0.6+ , dependent-sum >= 0.4 && < 0.5+ , exception-transformers >= 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 default-language: Haskell2010 executable reflex-sdl2-exe hs-source-dirs: app main-is: Main.hs- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base , reflex-sdl2 default-language: Haskell2010
src/Reflex/SDL2.hs view
@@ -1,213 +1,566 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--- | This module contains the bare minimum needed to get started writing--- reflex apps using sdl2.+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- | This module contains a minimum yet convenient API needed to get started+-- writing reflex apps with sdl2. ----- For a tutorial see--- [app/Main.hs](https://github.com/reflex-frp/reflex-sdl2/blob/master/app/Main.hs)+-- For an example see+-- [app/Main.hs](https://github.com/schell/reflex-sdl2/blob/master/app/Main.hs) module Reflex.SDL2- ( -- * All SDL events, packaged into reflex events- SystemEvents(..)- -- * Running an app- , host+ (-- * Running an app+ host+ -- * The reflex-sdl2 base type and constraints+ , ReflexSDL2+ , ReflexSDL2T+ , ConcreteReflexSDL2+ -- * Higher order switching+ , holdView+ , dynView+ , -- * Time delta events+ getDeltaTickEvent+ , performEventDelta+ -- * *WithEventCode events+ -- $witheventcode+ , getRecurringTimerEventWithEventCode+ , getAsyncEventWithEventCode+ , delayEventWithEventCode++ -- * User data+ , userLocal+ -- * Debugging , putDebugLnE- -- * Convenience constraints- , ReflexSDL2++ -- * 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- , MonadReader- , asks , MonadIO , liftIO ) where -import Control.Monad.Fix (MonadFix)-import Control.Monad.Identity (Identity (..))-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Reader (MonadReader, ReaderT (..), asks,- runReaderT)-import Control.Monad.Ref-import Data.Dependent.Sum (DSum ((:=>)))-import Data.Function (fix)-import Data.Word (Word32)-import Reflex hiding (Additive)+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (async)+import Control.Monad (forM_, void)+import Control.Monad.Exception (MonadException)+import Control.Monad.Fix (MonadFix)+import Control.Monad.Identity (Identity (..))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader+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 Reflex hiding (Additive) import Reflex.Host.Class-import SDL hiding (Event)+import SDL hiding (Event) +import Reflex.SDL2.Internal++ --------------------------------------------------------------------------------- | Holds a slot of 'Event' for each kind of SDL2 event plus a couple extras:------ An event for *any* SDL2 event payload.------ An event for reflex's post network build event.+-- | 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+++--------------------------------------------------------------------------------+-- | Returns an event that fires each frame with the number of milliseconds+-- 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 = do+ let f (lastTick, _) thisTick = (thisTick, thisTick - lastTick)+ evTickAndDel <- accum f (0, 0) =<< asks sysTicksEvent+ 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 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'. ----- An event for each frame tick.-data SystemEvents t = SystemEvents- { sysPostBuildEvent :: Event t ()- -- ^ Fired just after the FRP network is built.- , sysTicksEvent :: Event t Word32- -- ^ Fired once per frame tick, contains the number of- -- milliseconds since SDL library initialization.- , sysAnySDLEvent :: Event t EventPayload- -- ^ Fired when SDL receives any event.- , sysWindowShownEvent :: Event t WindowShownEventData- , sysWindowHiddenEvent :: Event t WindowHiddenEventData- , sysWindowExposedEvent :: Event t WindowExposedEventData- , sysWindowMovedEvent :: Event t WindowMovedEventData- , sysWindowResizedEvent :: Event t WindowResizedEventData- , sysWindowSizeChangedEvent :: Event t WindowSizeChangedEventData- , sysWindowMinimizedEvent :: Event t WindowMinimizedEventData- , sysWindowMaximizedEvent :: Event t WindowMaximizedEventData- , sysWindowRestoredEvent :: Event t WindowRestoredEventData- , sysWindowGainedMouseFocusEvent :: Event t WindowGainedMouseFocusEventData- , sysWindowLostMouseFocusEvent :: Event t WindowLostMouseFocusEventData- , sysWindowGainedKeyboardFocusEvent :: Event t WindowGainedKeyboardFocusEventData- , sysWindowLostKeyboardFocusEvent :: Event t WindowLostKeyboardFocusEventData- , sysWindowClosedEvent :: Event t WindowClosedEventData- , sysKeyboardEvent :: Event t KeyboardEventData- , sysTextEditingEvent :: Event t TextEditingEventData- , sysTextInputEvent :: Event t TextInputEventData- , sysKeymapChangedEvent :: Event t ()- , sysMouseMotionEvent :: Event t MouseMotionEventData- , sysMouseButtonEvent :: Event t MouseButtonEventData- , sysMouseWheelEvent :: Event t MouseWheelEventData- , sysJoyAxisEvent :: Event t JoyAxisEventData- , sysJoyBallEvent :: Event t JoyBallEventData- , sysJoyHatEvent :: Event t JoyHatEventData- , sysJoyButtonEvent :: Event t JoyButtonEventData- , sysJoyDeviceEvent :: Event t JoyDeviceEventData- , sysControllerAxisEvent :: Event t ControllerAxisEventData- , sysControllerButtonEvent :: Event t ControllerButtonEventData- , sysControllerDeviceEvent :: Event t ControllerDeviceEventData- , sysAudioDeviceEvent :: Event t AudioDeviceEventData- , sysQuitEvent :: Event t ()- , sysUserEvent :: Event t UserEventData- , sysSysWMEvent :: Event t SysWMEventData- , sysTouchFingerEvent :: Event t TouchFingerEventData- , sysMultiGestureEvent :: Event t MultiGestureEventData- , sysDollarGestureEvent :: Event t DollarGestureEventData- , sysDropEvent :: Event t DropEventData- , sysClipboardUpdateEvent :: Event t ()- , sysUnknownEvent :: Event t UnknownEventData- }+-- 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 +--------------------------------------------------------------------------------+-- | 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+++--------------------------------------------------------------------------------+-- | 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)++ --------------------------------------------------------------------------------- | Host a reflex-sdl2 app.+-- | Host a reflex-sdl2 app. This function is your application's main loop and+-- will not terminate. host- :: ReaderT (SystemEvents Spider) (PerformEventT Spider (SpiderHost Global)) a+ :: r+ -- ^ A user data value of type 'r'.+ -- Use 'getUserData' to access this value within your app network.+ -> ConcreteReflexSDL2 r () -- ^ A concrete reflex-sdl2 network to run.- -> IO ()-host app = runSpiderHost $ do+ -> IO void+host sysUserData app = runSpiderHost $ do -- Get events and trigger refs for all things that can happen.- (evPostBuild, trPostBuildRef) <- newEventWithTriggerRef- (evAnySDL, trAnySDLRef) <- newEventWithTriggerRef- (evTicks, trTicksRef) <- newEventWithTriggerRef- (evWindowShownEvent, trWindowShownRef) <- newEventWithTriggerRef- (evWindowHiddenEvent, trWindowHiddenRef) <- newEventWithTriggerRef- (evWindowExposedEvent, trWindowExposedRef) <- newEventWithTriggerRef- (evWindowMovedEvent, trWindowMovedRef) <- newEventWithTriggerRef- (evWindowResizedEvent, trWindowResizedRef) <- newEventWithTriggerRef- (evWindowSizeChangedEvent, trWindowSizeChangedRef) <- newEventWithTriggerRef- (evWindowMinimizedEvent, trWindowMinimizedRef) <- newEventWithTriggerRef- (evWindowMaximizedEvent, trWindowMaximizedRef) <- newEventWithTriggerRef- (evWindowRestoredEvent, trWindowRestoredRef) <- newEventWithTriggerRef- (evWindowGainedMouseFocusEvent, trWindowGainedMouseFocusRef) <- newEventWithTriggerRef- (evWindowLostMouseFocusEvent, trWindowLostMouseFocusRef) <- newEventWithTriggerRef- (evWindowGainedKeyboardFocusEvent, trWindowGainedKeyboardFocusRef) <- newEventWithTriggerRef- (evWindowLostKeyboardFocusEvent, trWindowLostKeyboardFocusRef) <- newEventWithTriggerRef- (evWindowClosedEvent, trWindowClosedRef) <- newEventWithTriggerRef- (evKeyboardEvent, trKeyboardRef) <- newEventWithTriggerRef- (evTextEditingEvent, trTextEditingRef) <- newEventWithTriggerRef- (evTextInputEvent, trTextInputRef) <- newEventWithTriggerRef- (evKeymapChangedEvent, trKeymapChangedRef) <- newEventWithTriggerRef- (evMouseMotionEvent, trMouseMotionRef) <- newEventWithTriggerRef- (evMouseButtonEvent, trMouseButtonRef) <- newEventWithTriggerRef- (evMouseWheelEvent, trMouseWheelRef) <- newEventWithTriggerRef- (evJoyAxisEvent, trJoyAxisRef) <- newEventWithTriggerRef- (evJoyBallEvent, trJoyBallRef) <- newEventWithTriggerRef- (evJoyHatEvent, trJoyHatRef) <- newEventWithTriggerRef- (evJoyButtonEvent, trJoyButtonRef) <- newEventWithTriggerRef- (evJoyDeviceEvent, trJoyDeviceRef) <- newEventWithTriggerRef- (evControllerAxisEvent, trControllerAxisRef) <- newEventWithTriggerRef- (evControllerButtonEvent, trControllerButtonRef) <- newEventWithTriggerRef- (evControllerDeviceEvent, trControllerDeviceRef) <- newEventWithTriggerRef- (evAudioDeviceEvent, trAudioDeviceRef) <- newEventWithTriggerRef- (evQuitEvent, trQuitRef) <- newEventWithTriggerRef- (evUserEvent, trUserRef) <- newEventWithTriggerRef- (evSysWMEvent, trSysWMRef) <- newEventWithTriggerRef- (evTouchFingerEvent, trTouchFingerRef) <- newEventWithTriggerRef- (evMultiGestureEvent, trMultiGestureRef) <- newEventWithTriggerRef- (evDollarGestureEvent, trDollarGestureRef) <- newEventWithTriggerRef- (evDropEvent, trDropRef) <- newEventWithTriggerRef- (evClipboardUpdateEvent, trClipboardUpdateRef) <- newEventWithTriggerRef- (evUnknownEvent, trUnknownRef) <- newEventWithTriggerRef+ (sysPostBuildEvent, trPostBuildRef) <- newEventWithTriggerRef+ (sysAnySDLEvent, trAnySDLRef) <- newEventWithTriggerRef+ (sysTicksEvent, trTicksRef) <- newEventWithTriggerRef+ (sysWindowShownEvent, trWindowShownRef) <- newEventWithTriggerRef+ (sysWindowHiddenEvent, trWindowHiddenRef) <- newEventWithTriggerRef+ (sysWindowExposedEvent, trWindowExposedRef) <- newEventWithTriggerRef+ (sysWindowMovedEvent, trWindowMovedRef) <- newEventWithTriggerRef+ (sysWindowResizedEvent, trWindowResizedRef) <- newEventWithTriggerRef+ (sysWindowSizeChangedEvent, trWindowSizeChangedRef) <- newEventWithTriggerRef+ (sysWindowMinimizedEvent, trWindowMinimizedRef) <- newEventWithTriggerRef+ (sysWindowMaximizedEvent, trWindowMaximizedRef) <- newEventWithTriggerRef+ (sysWindowRestoredEvent, trWindowRestoredRef) <- newEventWithTriggerRef+ (sysWindowGainedMouseFocusEvent, trWindowGainedMouseFocusRef) <- newEventWithTriggerRef+ (sysWindowLostMouseFocusEvent, trWindowLostMouseFocusRef) <- newEventWithTriggerRef+ (sysWindowGainedKeyboardFocusEvent, trWindowGainedKeyboardFocusRef) <- newEventWithTriggerRef+ (sysWindowLostKeyboardFocusEvent, trWindowLostKeyboardFocusRef) <- newEventWithTriggerRef+ (sysWindowClosedEvent, trWindowClosedRef) <- newEventWithTriggerRef+ (sysKeyboardEvent, trKeyboardRef) <- newEventWithTriggerRef+ (sysTextEditingEvent, trTextEditingRef) <- newEventWithTriggerRef+ (sysTextInputEvent, trTextInputRef) <- newEventWithTriggerRef+ (sysKeymapChangedEvent, trKeymapChangedRef) <- newEventWithTriggerRef+ (sysMouseMotionEvent, trMouseMotionRef) <- newEventWithTriggerRef+ (sysMouseButtonEvent, trMouseButtonRef) <- newEventWithTriggerRef+ (sysMouseWheelEvent, trMouseWheelRef) <- newEventWithTriggerRef+ (sysJoyAxisEvent, trJoyAxisRef) <- newEventWithTriggerRef+ (sysJoyBallEvent, trJoyBallRef) <- newEventWithTriggerRef+ (sysJoyHatEvent, trJoyHatRef) <- newEventWithTriggerRef+ (sysJoyButtonEvent, trJoyButtonRef) <- newEventWithTriggerRef+ (sysJoyDeviceEvent, trJoyDeviceRef) <- newEventWithTriggerRef+ (sysControllerAxisEvent, trControllerAxisRef) <- newEventWithTriggerRef+ (sysControllerButtonEvent, trControllerButtonRef) <- newEventWithTriggerRef+ (sysControllerDeviceEvent, trControllerDeviceRef) <- newEventWithTriggerRef+ (sysAudioDeviceEvent, trAudioDeviceRef) <- newEventWithTriggerRef+ (sysQuitEvent, trQuitRef) <- newEventWithTriggerRef+ (sysUserEvent, trUserRef) <- newEventWithTriggerRef+ (sysSysWMEvent, trSysWMRef) <- newEventWithTriggerRef+ (sysTouchFingerEvent, trTouchFingerRef) <- newEventWithTriggerRef+ (sysTouchFingerMotionEvent, trTouchFingerMotionRef) <- newEventWithTriggerRef+ (sysMultiGestureEvent, trMultiGestureRef) <- newEventWithTriggerRef+ (sysDollarGestureEvent, trDollarGestureRef) <- newEventWithTriggerRef+ (sysDropEvent, trDropRef) <- newEventWithTriggerRef+ (sysClipboardUpdateEvent, trClipboardUpdateRef) <- newEventWithTriggerRef+ (sysUnknownEvent, trUnknownRef) <- newEventWithTriggerRef -- Build the network and get our firing command to trigger the post build event.- (_, FireCommand fire) <-- hostPerformEventT $ runReaderT app- SystemEvents{ sysPostBuildEvent = evPostBuild- , sysAnySDLEvent = evAnySDL- , sysTicksEvent = evTicks- , sysWindowShownEvent = evWindowShownEvent- , sysWindowHiddenEvent = evWindowHiddenEvent- , sysWindowExposedEvent = evWindowExposedEvent- , sysWindowMovedEvent = evWindowMovedEvent- , sysWindowResizedEvent = evWindowResizedEvent- , sysWindowSizeChangedEvent = evWindowSizeChangedEvent- , sysWindowMinimizedEvent = evWindowMinimizedEvent- , sysWindowMaximizedEvent = evWindowMaximizedEvent- , sysWindowRestoredEvent = evWindowRestoredEvent- , sysWindowGainedMouseFocusEvent = evWindowGainedMouseFocusEvent- , sysWindowLostMouseFocusEvent = evWindowLostMouseFocusEvent- , sysWindowGainedKeyboardFocusEvent = evWindowGainedKeyboardFocusEvent- , sysWindowLostKeyboardFocusEvent = evWindowLostKeyboardFocusEvent- , sysWindowClosedEvent = evWindowClosedEvent- , sysKeyboardEvent = evKeyboardEvent- , sysTextEditingEvent = evTextEditingEvent- , sysTextInputEvent = evTextInputEvent- , sysKeymapChangedEvent = evKeymapChangedEvent- , sysMouseMotionEvent = evMouseMotionEvent- , sysMouseButtonEvent = evMouseButtonEvent- , sysMouseWheelEvent = evMouseWheelEvent- , sysJoyAxisEvent = evJoyAxisEvent- , sysJoyBallEvent = evJoyBallEvent- , sysJoyHatEvent = evJoyHatEvent- , sysJoyButtonEvent = evJoyButtonEvent- , sysJoyDeviceEvent = evJoyDeviceEvent- , sysControllerAxisEvent = evControllerAxisEvent- , sysControllerButtonEvent = evControllerButtonEvent- , sysControllerDeviceEvent = evControllerDeviceEvent- , sysAudioDeviceEvent = evAudioDeviceEvent- , sysQuitEvent = evQuitEvent- , sysUserEvent = evUserEvent- , sysSysWMEvent = evSysWMEvent- , sysTouchFingerEvent = evTouchFingerEvent- , sysMultiGestureEvent = evMultiGestureEvent- , sysDollarGestureEvent = evDollarGestureEvent- , sysDropEvent = evDropEvent- , sysClipboardUpdateEvent = evClipboardUpdateEvent- , sysUnknownEvent = evUnknownEvent- }+ ((), FireCommand fire) <-+ hostPerformEventT $+ runPostBuildT (runReaderT (runReflexSDL2T app) SystemEvents{..})+ sysPostBuildEvent -- Trigger the post build event. (readRef trPostBuildRef >>=) . mapM_ $ \tr -> fire [tr :=> Identity ()] $ return () - ---- Loop forever getting sdl2 events and triggering them.+ -- Loop forever doing all of our main loop stuff. fix $ \loop -> do- payload <- eventPayload <$> waitEvent- case payload of+ -- 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+ void $ fire [tr :=> Identity t] $ return ()+ return False++ payloads <- map eventPayload <$> if shouldWait+ then (:) <$> waitEvent+ <*> pollEvents+ else pollEvents++ forM_ payloads $ \case WindowShownEvent dat -> (readRef trWindowShownRef >>=) . mapM_ $ \tr -> fire [tr :=> Identity dat] $ return () WindowHiddenEvent dat -> (readRef trWindowHiddenRef >>=) . mapM_ $ \tr ->@@ -276,6 +629,8 @@ fire [tr :=> Identity dat] $ return () TouchFingerEvent dat -> (readRef trTouchFingerRef >>=) . mapM_ $ \tr -> fire [tr :=> Identity dat] $ return ()+ TouchFingerMotionEvent dat -> (readRef trTouchFingerMotionRef >>=) . mapM_ $ \tr ->+ fire [tr :=> Identity dat] $ return () MultiGestureEvent dat -> (readRef trMultiGestureRef >>=) . mapM_ $ \tr -> fire [tr :=> Identity dat] $ return () DollarGestureEvent dat -> (readRef trDollarGestureRef >>=) . mapM_ $ \tr ->@@ -289,10 +644,8 @@ -- Fire an event for the wrapped payload as well. (readRef trAnySDLRef >>=) . mapM_ $ \tr ->- fire [tr :=> Identity payload] $ return ()- -- Fire any tick events, if anyone is listening.- (readRef trTicksRef >>=) . mapM_ $ \tr -> ticks >>= \t ->- fire [tr :=> Identity t] $ return ()+ forM_ payloads $ \payload ->+ fire [tr :=> Identity payload] $ return () loop @@ -310,13 +663,22 @@ --------------------------------------------------------------------------------- | A collection of constraints that represent a reflex-sdl2 network.-type ReflexSDL2 t m =- ( Reflex t- , MonadHold t m- , PerformEvent t m- , MonadFix m- , MonadIO m- , MonadIO (Performable m)- , MonadReader (SystemEvents t) m- )+-- | Run a placeholder network until the given 'Event' fires, then replace it+-- 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 child0 newChild = do+ (result0, newResult) <- runWithReplace child0 newChild+ holdDyn result0 newResult+++------------------------------------------------------------------------------+-- | 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 child = do+ evPB <- getPostBuild+ let newChild = leftmost [updated child, tagCheap (current child) evPB]+ snd <$> runWithReplace (return ()) newChild
+ src/Reflex/SDL2/Internal.hs view
@@ -0,0 +1,69 @@+-- | This module holds low-level implementation details of reflex-sdl2+-- that are not meant to be dealt with by the user of the library.+-- None-the-less these details are exported here just in case you+-- need them :)+module Reflex.SDL2.Internal where++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:+--+-- An event for *any* SDL2 event payload.+--+-- An event for reflex's post network build event.+--+-- An event for each frame tick.+data SystemEvents r t = SystemEvents+ { sysPostBuildEvent :: Event t ()+ -- ^ Fired just after the FRP network is built.+ , sysTicksEvent :: Event t Word32+ -- ^ Fired once per frame tick, contains the number of+ -- milliseconds since SDL library initialization.+ , sysAnySDLEvent :: Event t EventPayload+ -- ^ Fired when SDL receives any event.+ , sysWindowShownEvent :: Event t WindowShownEventData+ , sysWindowHiddenEvent :: Event t WindowHiddenEventData+ , sysWindowExposedEvent :: Event t WindowExposedEventData+ , sysWindowMovedEvent :: Event t WindowMovedEventData+ , sysWindowResizedEvent :: Event t WindowResizedEventData+ , sysWindowSizeChangedEvent :: Event t WindowSizeChangedEventData+ , sysWindowMinimizedEvent :: Event t WindowMinimizedEventData+ , sysWindowMaximizedEvent :: Event t WindowMaximizedEventData+ , sysWindowRestoredEvent :: Event t WindowRestoredEventData+ , sysWindowGainedMouseFocusEvent :: Event t WindowGainedMouseFocusEventData+ , sysWindowLostMouseFocusEvent :: Event t WindowLostMouseFocusEventData+ , sysWindowGainedKeyboardFocusEvent :: Event t WindowGainedKeyboardFocusEventData+ , sysWindowLostKeyboardFocusEvent :: Event t WindowLostKeyboardFocusEventData+ , sysWindowClosedEvent :: Event t WindowClosedEventData+ , sysKeyboardEvent :: Event t KeyboardEventData+ , sysTextEditingEvent :: Event t TextEditingEventData+ , sysTextInputEvent :: Event t TextInputEventData+ , sysKeymapChangedEvent :: Event t ()+ , sysMouseMotionEvent :: Event t MouseMotionEventData+ , sysMouseButtonEvent :: Event t MouseButtonEventData+ , sysMouseWheelEvent :: Event t MouseWheelEventData+ , sysJoyAxisEvent :: Event t JoyAxisEventData+ , sysJoyBallEvent :: Event t JoyBallEventData+ , sysJoyHatEvent :: Event t JoyHatEventData+ , sysJoyButtonEvent :: Event t JoyButtonEventData+ , sysJoyDeviceEvent :: Event t JoyDeviceEventData+ , sysControllerAxisEvent :: Event t ControllerAxisEventData+ , sysControllerButtonEvent :: Event t ControllerButtonEventData+ , sysControllerDeviceEvent :: Event t ControllerDeviceEventData+ , sysAudioDeviceEvent :: Event t AudioDeviceEventData+ , sysQuitEvent :: Event t ()+ , sysUserEvent :: Event t UserEventData+ , sysSysWMEvent :: Event t SysWMEventData+ , sysTouchFingerEvent :: Event t TouchFingerEventData+ , sysTouchFingerMotionEvent :: Event t TouchFingerMotionEventData+ , sysMultiGestureEvent :: Event t MultiGestureEventData+ , sysDollarGestureEvent :: Event t DollarGestureEventData+ , sysDropEvent :: Event t DropEventData+ , sysClipboardUpdateEvent :: Event t ()+ , sysUnknownEvent :: Event t UnknownEventData+ , sysUserData :: r+ -- ^ A slot to hold any custom user data.+ }