diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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" diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/reflex-sdl2.cabal b/reflex-sdl2.cabal --- a/reflex-sdl2.cabal +++ b/reflex-sdl2.cabal @@ -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 diff --git a/src/Reflex/SDL2.hs b/src/Reflex/SDL2.hs --- a/src/Reflex/SDL2.hs +++ b/src/Reflex/SDL2.hs @@ -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 diff --git a/src/Reflex/SDL2/Internal.hs b/src/Reflex/SDL2/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/SDL2/Internal.hs @@ -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. + }