reflex-sdl2-0.2.0.0: src/Reflex/SDL2.hs
{-# 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 an example see
-- [app/Main.hs](https://github.com/schell/reflex-sdl2/blob/master/app/Main.hs)
module Reflex.SDL2
(-- * 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
-- * SDL2 events
, getTicksEvent
, getAnySDLEvent
, getWindowShownEvent
, getWindowHiddenEvent
, getWindowExposedEvent
, getWindowMovedEvent
, getWindowResizedEvent
, getWindowSizeChangedEvent
, getWindowMinimizedEvent
, getWindowMaximizedEvent
, getWindowRestoredEvent
, getWindowGainedMouseFocusEvent
, getWindowLostMouseFocusEvent
, getWindowGainedKeyboardFocusEvent
, getWindowLostKeyboardFocusEvent
, getWindowClosedEvent
, getKeyboardEvent
, getTextEditingEvent
, getTextInputEvent
, getKeymapChangedEvent
, getMouseMotionEvent
, getMouseButtonEvent
, getMouseWheelEvent
, getJoyAxisEvent
, getJoyBallEvent
, getJoyHatEvent
, getJoyButtonEvent
, getJoyDeviceEvent
, getControllerAxisEvent
, getControllerButtonEvent
, getControllerDeviceEvent
, getAudioDeviceEvent
, getQuitEvent
, getUserEvent
, getSysWMEvent
, getTouchFingerEvent
, getMultiGestureEvent
, getDollarGestureEvent
, getDropEvent
, getClipboardUpdateEvent
, getUnknownEvent
, getUserData
-- * Re-exports
, module Reflex
, module SDL
, MonadIO
, liftIO
) where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async)
import Control.Monad (forM_, void)
import Control.Monad.Exception (MonadException)
import Control.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 Reflex.SDL2.Internal
------------------------------------------------------------------------------
-- | A collection of constraints that represent the default reflex-sdl2 network.
type ReflexSDL2 r t m =
( Reflex t
, MonadHold t m
, MonadSample t m
, MonadAdjust t m
, PostBuild t m
, PerformEvent t m
, MonadFix m
, MonadIO m
, MonadIO (Performable m)
, MonadReader (SystemEvents r t) m
)
------------------------------------------------------------------------------
-- | Run a @('Reader' 'SystemEvents' r t)@ computation with a modified
-- 'sysUserData' @r@.
userLocal :: MonadReader (SystemEvents r t) m => (r -> r) -> m a -> m a
userLocal f = local (\se -> se{sysUserData = f $ sysUserData se})
------------------------------------------------------------------------------
-- | Provides a basic implementation of 'ReflexSDL2' constraints.
newtype ReflexSDL2T r t (m :: * -> *) a =
ReflexSDL2T { runReflexSDL2T :: ReaderT (SystemEvents r t) m a }
deriving instance (ReflexHost t, Functor m) => Functor (ReflexSDL2T r t m)
deriving instance (ReflexHost t, Applicative m) => Applicative (ReflexSDL2T r t m)
deriving instance (ReflexHost t, Monad m) => Monad (ReflexSDL2T r t m)
deriving instance (ReflexHost t, MonadFix m) => MonadFix (ReflexSDL2T r t m)
deriving instance (ReflexHost t, Monad m) => MonadReader (SystemEvents r t) (ReflexSDL2T r t m)
deriving instance (ReflexHost t, MonadIO m) => MonadIO (ReflexSDL2T r t m)
deriving instance ReflexHost t => MonadTrans (ReflexSDL2T r t)
deriving instance (ReflexHost t, MonadException m) => MonadException (ReflexSDL2T r t m)
------------------------------------------------------------------------------
-- | 'ReflexSDL2T' is an instance of 'PostBuild'.
instance (Reflex t, PostBuild t m, ReflexHost t, Monad m) => PostBuild t (ReflexSDL2T r t m) where
getPostBuild = lift getPostBuild
------------------------------------------------------------------------------
-- | 'ReflexSDL2T' is an instance of 'PerformEvent'.
instance (ReflexHost t, PerformEvent t m) => PerformEvent t (ReflexSDL2T r t m) where
type Performable (ReflexSDL2T r t m) = ReflexSDL2T r t (Performable m)
performEvent_ = ReflexSDL2T . performEvent_ . fmap runReflexSDL2T
performEvent = ReflexSDL2T . performEvent . fmap runReflexSDL2T
------------------------------------------------------------------------------
-- | 'ReflexSDL2T' is an instance of 'MonadAdjust'.
instance ( Reflex t
, ReflexHost t
, MonadAdjust t m
, Monad m
--, PrimMonad (HostFrame t)
) => MonadAdjust t (ReflexSDL2T r t m) where
runWithReplace ma evmb =
ReflexSDL2T $ runWithReplace (runReflexSDL2T ma) (runReflexSDL2T <$> evmb)
traverseDMapWithKeyWithAdjust kvma dMapKV = ReflexSDL2T .
traverseDMapWithKeyWithAdjust (\ka -> runReflexSDL2T . kvma ka) dMapKV
traverseDMapWithKeyWithAdjustWithMove kvma dMapKV = ReflexSDL2T .
traverseDMapWithKeyWithAdjustWithMove (\ka -> runReflexSDL2T . kvma ka) dMapKV
------------------------------------------------------------------------------
-- | 'ReflexSDL2T' is an instance of 'MonadHold'.
instance ( ReflexHost t
, Applicative m
, Monad m
, MonadSample t m
) => MonadSample t (ReflexSDL2T r t m) where
sample = lift . sample
------------------------------------------------------------------------------
-- | 'ReflexSDL2T' is an instance of 'MonadHold'.
instance (ReflexHost t, MonadHold t m) => MonadHold t (ReflexSDL2T r t m) where
hold a = lift . hold a
holdDyn a = lift . holdDyn a
holdIncremental p = lift . holdIncremental p
buildDynamic ma = lift . buildDynamic ma
--------------------------------------------------------------------------------
data TimerData = TimerData Int32 Timestamp
toTimerData :: Int32 -> RegisteredEventData -> Timestamp -> IO (Maybe TimerData)
toTimerData eventCode rdat ts
| eventCode == registeredEventCode rdat =
return $ Just $ TimerData eventCode ts
| otherwise = return Nothing
fromTimerData :: TimerData -> IO RegisteredEventData
fromTimerData (TimerData code _) =
return $ emptyRegisteredEvent{ registeredEventCode = code }
--------------------------------------------------------------------------------
-- $witheventcode
-- The *WithEventCode flavor of events use sdl2's user events system. Each
-- function evaluates on the current thread, returning an 'Event' that will fire
-- on the main thread and can be used to drive GL updates. It uses sdl2's
-- user event machinery, requiring a special single use event code to identify
-- the event on the other side of sdl2's FFI. This is a great use case for a
-- @Fresh@ effect in your app.
--------------------------------------------------------------------------------
-- | Retrieves an event that fires every 'n' milliseconds.
getRecurringTimerEventWithEventCode
:: ReflexSDL2 r t m
=> Int32
-- ^ Single use event code.
-> Int
-- ^ Number of milliseconds.
-> m (Event t ())
getRecurringTimerEventWithEventCode eventCode n = do
-- Register the timer event as a user event so it will wake `waitEvent` when
-- pushed into the queue.
let toData = toTimerData eventCode
registerEvent toData fromTimerData >>= \case
Nothing -> return ()
Just (RegisteredEventType pushIt _) -> liftIO $ void $ async $ fix $ \loop -> do
threadDelay $ n * 1000
ts <- ticks
pushIt (TimerData eventCode ts) >>= \case
EventPushSuccess -> return ()
EventPushFiltered -> putStrLn "timer push filtered"
EventPushFailure t -> print t
loop
-- Filter the user event to only fire when the incoming code matches.
evUser <- getUserEvent
return $ fmapMaybe (guard . (eventCode ==) . userEventCode) evUser
--------------------------------------------------------------------------------
-- | 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'.
--
-- 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. This function is your application's main loop and
-- will not terminate.
host
:: 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 void
host sysUserData app = runSpiderHost $ do
-- Get events and trigger refs for all things that can happen.
(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 $
runPostBuildT (runReaderT (runReflexSDL2T app) SystemEvents{..})
sysPostBuildEvent
-- Trigger the post build event.
(readRef trPostBuildRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity ()] $ return ()
-- Loop forever doing all of our main loop stuff.
fix $ \loop -> do
-- 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 ->
fire [tr :=> Identity dat] $ return ()
WindowExposedEvent dat -> (readRef trWindowExposedRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowMovedEvent dat -> (readRef trWindowMovedRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowResizedEvent dat -> (readRef trWindowResizedRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowSizeChangedEvent dat -> (readRef trWindowSizeChangedRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowMinimizedEvent dat -> (readRef trWindowMinimizedRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowMaximizedEvent dat -> (readRef trWindowMaximizedRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowRestoredEvent dat -> (readRef trWindowRestoredRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowGainedMouseFocusEvent dat -> (readRef trWindowGainedMouseFocusRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowLostMouseFocusEvent dat -> (readRef trWindowLostMouseFocusRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowGainedKeyboardFocusEvent dat -> (readRef trWindowGainedKeyboardFocusRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowLostKeyboardFocusEvent dat -> (readRef trWindowLostKeyboardFocusRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
WindowClosedEvent dat -> (readRef trWindowClosedRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
KeyboardEvent dat -> (readRef trKeyboardRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
TextEditingEvent dat -> (readRef trTextEditingRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
TextInputEvent dat -> (readRef trTextInputRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
KeymapChangedEvent -> (readRef trKeymapChangedRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity ()] $ return ()
MouseMotionEvent dat -> (readRef trMouseMotionRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
MouseButtonEvent dat -> (readRef trMouseButtonRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
MouseWheelEvent dat -> (readRef trMouseWheelRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
JoyAxisEvent dat -> (readRef trJoyAxisRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
JoyBallEvent dat -> (readRef trJoyBallRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
JoyHatEvent dat -> (readRef trJoyHatRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
JoyButtonEvent dat -> (readRef trJoyButtonRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
JoyDeviceEvent dat -> (readRef trJoyDeviceRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
ControllerAxisEvent dat -> (readRef trControllerAxisRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
ControllerButtonEvent dat -> (readRef trControllerButtonRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
ControllerDeviceEvent dat -> (readRef trControllerDeviceRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
AudioDeviceEvent dat -> (readRef trAudioDeviceRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
QuitEvent -> (readRef trQuitRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity ()] $ return ()
UserEvent dat -> (readRef trUserRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
SysWMEvent dat -> (readRef trSysWMRef >>=) . mapM_ $ \tr ->
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 ->
fire [tr :=> Identity dat] $ return ()
DropEvent dat -> (readRef trDropRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
ClipboardUpdateEvent -> (readRef trClipboardUpdateRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity ()] $ return ()
UnknownEvent dat -> (readRef trUnknownRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
-- Fire an event for the wrapped payload as well.
(readRef trAnySDLRef >>=) . mapM_ $ \tr ->
forM_ payloads $ \payload ->
fire [tr :=> Identity payload] $ return ()
loop
------------------------------------------------------------------------------
-- | Like 'putStrLn', but for 'Event's.
putDebugLnE
:: (PerformEvent t m, Reflex t, MonadIO (Performable m))
=> Event t a
-- ^ The 'Event' to trigger the print.
-> (a -> String)
-- ^ A function to show the 'Event's value.
-> m ()
putDebugLnE ev showf = performEvent_ $ liftIO . putStrLn . showf <$> ev
------------------------------------------------------------------------------
-- | 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