{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Reflex.SDL2
(
host
, shutdownOn
, HasSDL2Events (..)
, ReflexSDL2T
, ReflexSDL2
, ConcreteReflexSDL2
, holdView
, dynView
, TickInfo(..)
, getDeltaTickEvent
, performEventDelta
, getAsyncEvent
, putDebugLnE
, module SDL
, MonadIO
, liftIO
) where
import Control.Concurrent (newChan, newEmptyMVar, putMVar,
readChan, takeMVar)
import Control.Concurrent.Async (async, cancel)
import Control.Monad (forM_, unless, void)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Identity (Identity (..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader
import Control.Monad.Ref (readRef)
import Data.Dependent.Sum (DSum ((:=>)))
import Data.Function (fix)
import Data.Word (Word32)
import GHC.Conc (atomically, newTVar, readTVar,
readTVarIO, writeTVar)
import Reflex hiding (Additive)
import Reflex.Host.Class
import SDL hiding (Event, delay)
import Reflex.SDL2.Base
import Reflex.SDL2.Class
import Reflex.SDL2.Internal
type ReflexSDL2 t m = ( Reflex t
, MonadHold t m
, MonadSample t m
, Adjustable t m
, PostBuild t m
, PerformEvent t m
, TriggerEvent t m
, MonadFix m
, MonadIO m
, MonadIO (Performable m)
, HasSDL2Events t m
)
getDeltaTickEvent
:: (MonadHold t m, MonadFix m, HasSDL2Events t m) => m (Event t Word32)
getDeltaTickEvent = do
let f (lastTick, _) thisTick = (thisTick, thisTick - lastTick)
evTickAndDel <- accum f (0, 0) =<< getTicksEvent
return $ snd <$> evTickAndDel
performEventDelta :: ReflexSDL2 t m => Event t a -> m (Event t Word32)
performEventDelta ev = do
tnow <- ticks
evTicks <- performEvent $ ticks <$ ev
fmap fst <$> accum (\(_, prev) now -> (now - prev, now)) (0, tnow) evTicks
getAsyncEvent :: ReflexSDL2 t m => IO a -> m (Event t a)
getAsyncEvent f = do
(ev, g) <- newTriggerEvent
void $ liftIO $ async $ f >>= g
return ev
shutdownOn
:: (PerformEvent t m, MonadIO (Performable m), HasSDL2Events t m)
=> Event t ()
-> m ()
shutdownOn ev = do
var <- getQuitVar
performEvent_ $ liftIO (putMVar var ()) <$ ev
type ConcreteReflexSDL2 = ReflexSDL2T Spider (TriggerEventT Spider (PostBuildT Spider (PerformEventT Spider (SpiderHost Global))))
host
:: ConcreteReflexSDL2 ()
-> IO ()
host app = runSpiderHost $ do
(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
chan <- liftIO newChan
triggersVar <- liftIO $ atomically $ newTVar []
sysQuitVar <- liftIO newEmptyMVar
mainQuitVar <- liftIO $ atomically $ newTVar False
let reservedTriggerCode = 31337
isJustTriggerData dat _ =
return $ guard $ registeredEventCode dat == reservedTriggerCode
fromData () = return emptyRegisteredEvent{ registeredEventCode = reservedTriggerCode }
pushTrig <- registerEvent isJustTriggerData fromData >>= \case
Nothing -> error "Could not register an sdl event for TriggerEvent."
Just (RegisteredEventType pushTrig _) -> return pushTrig
asyncTrigger <- liftIO $ async $ fix $ \loop -> do
trigs <- readChan chan
atomically $ do
prevTrigs <- readTVar triggersVar
writeTVar triggersVar $ prevTrigs ++ trigs
pushTrig () >>= \case
EventPushSuccess -> return ()
EventPushFiltered -> putStrLn "trigger push filtered"
EventPushFailure t -> print t
loop
void $ liftIO $ async $ do
takeMVar sysQuitVar
atomically $ writeTVar mainQuitVar True
void $ pushTrig ()
cancel asyncTrigger
((), FireCommand fire) <-
hostPerformEventT $ flip runPostBuildT sysPostBuildEvent
$ flip runTriggerEventT chan
$ runReflexSDL2T app SystemEvents{..}
(readRef trPostBuildRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity ()] $ return ()
fix $ \loop -> do
shouldWait <- readRef trTicksRef >>= \case
Nothing -> return True
Just tr -> do
t <- ticks
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 ->
if userEventCode dat == reservedTriggerCode
then do
triggers <- liftIO $ atomically $ do
trigs <- readTVar triggersVar
writeTVar triggersVar []
return trigs
forM_ triggers $ \(EventTriggerRef ref :=> TriggerInvocation a _cb) ->
(readRef ref >>=) . mapM_ $ \tr -> fire [tr :=> Identity a] $ return ()
forM_ triggers $ \(_ :=> TriggerInvocation _a cb) -> liftIO cb
else (readRef trUserRef >>=) . mapM_ $ \tr -> fire [tr :=> Identity dat] $ return ()
SysWMEvent dat -> (readRef trSysWMRef >>=) . mapM_ $ \tr ->
fire [tr :=> Identity dat] $ return ()
TouchFingerEvent dat -> (readRef trTouchFingerRef >>=) . mapM_ $ \tr ->
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 ()
(readRef trAnySDLRef >>=) . mapM_ $ \tr ->
forM_ payloads $ \payload ->
fire [tr :=> Identity payload] $ return ()
shouldQuit <- liftIO $ readTVarIO mainQuitVar
unless shouldQuit loop
putDebugLnE
:: (PerformEvent t m, Reflex t, MonadIO (Performable m))
=> Event t a
-> (a -> String)
-> m ()
putDebugLnE ev showf = performEvent_ $ liftIO . putStrLn . showf <$> ev
holdView :: ReflexSDL2 t m => m a -> Event t (m a) -> m (Dynamic t a)
holdView child0 newChild = do
(result0, newResult) <- runWithReplace child0 newChild
holdDyn result0 newResult
dynView :: ReflexSDL2 t m => Dynamic t (m a) -> m (Event t a)
dynView child = do
evPB <- getPostBuild
let newChild = leftmost [updated child, tagCheap (current child) evPB]
snd <$> runWithReplace (return ()) newChild