{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Reflex.Host.Headless where
import Control.Concurrent.Chan (newChan, readChan)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Fix (MonadFix, fix)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Primitive (PrimMonad)
import Control.Monad.Ref (MonadRef, Ref, readRef)
import Data.Dependent.Sum (DSum (..), (==>))
import Data.Foldable (for_, asum)
import Data.Functor.Identity (Identity(..))
import Data.IORef (IORef, readIORef)
import Data.Maybe (catMaybes)
import Data.Traversable (for)
import Reflex
import Reflex.Host.Class
type MonadHeadlessApp t m =
( Reflex t
, Adjustable t m
, MonadCatch m
, MonadFix (Performable m)
, MonadFix m
, MonadHold t (Performable m)
, MonadHold t m
, MonadIO (HostFrame t)
, MonadIO (Performable m)
, MonadIO m
, MonadMask m
, MonadRef (HostFrame t)
, MonadSample t (Performable m)
, MonadSample t m
, MonadThrow m
, NotReady t m
, PerformEvent t m
, PostBuild t m
, PrimMonad (HostFrame t)
, Ref (HostFrame t) ~ IORef
, Ref m ~ IORef
, ReflexHost t
, TriggerEvent t m
)
runHeadlessApp
:: forall a
. (forall t m. MonadHeadlessApp t m => m (Event t a))
-> IO a
runHeadlessApp :: (forall t (m :: * -> *). MonadHeadlessApp t m => m (Event t a))
-> IO a
runHeadlessApp forall t (m :: * -> *). MonadHeadlessApp t m => m (Event t a)
guest =
(forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO a)
-> IO a
forall r.
(forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r)
-> IO r
withSpiderTimeline ((forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO a)
-> IO a)
-> (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ SpiderHost x a -> SpiderTimelineEnv x -> IO a
forall x a. SpiderHost x a -> SpiderTimelineEnv x -> IO a
runSpiderHostForTimeline (SpiderHost x a -> SpiderTimelineEnv x -> IO a)
-> SpiderHost x a -> SpiderTimelineEnv x -> IO a
forall a b. (a -> b) -> a -> b
$ do
(Event (SpiderTimeline x) ()
postBuild, IORef (Maybe (RootTrigger x ()))
postBuildTriggerRef) <- SpiderHost
x (Event (SpiderTimeline x) (), IORef (Maybe (RootTrigger x ())))
forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
newEventWithTriggerRef
Chan [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
events <- IO
(Chan
[DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation])
-> SpiderHost
x
(Chan
[DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO
(Chan
[DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation])
forall a. IO (Chan a)
newChan
(Event (SpiderTimeline x) a
result, fc :: FireCommand (SpiderTimeline x) (SpiderHost x)
fc@(FireCommand forall a.
[DSum (EventTrigger (SpiderTimeline x)) Identity]
-> ReadPhase (SpiderHost x) a -> SpiderHost x [a]
fire)) <- do
PerformEventT
(SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) a)
-> SpiderHost
x
(Event (SpiderTimeline x) a,
FireCommand (SpiderTimeline x) (SpiderHost x))
forall t (m :: * -> *) a.
(Monad m, MonadSubscribeEvent t m, MonadReflexHost t m, MonadRef m,
Ref m ~ Ref IO) =>
PerformEventT t m a -> m (a, FireCommand t m)
hostPerformEventT (PerformEventT
(SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) a)
-> SpiderHost
x
(Event (SpiderTimeline x) a,
FireCommand (SpiderTimeline x) (SpiderHost x)))
-> PerformEventT
(SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) a)
-> SpiderHost
x
(Event (SpiderTimeline x) a,
FireCommand (SpiderTimeline x) (SpiderHost x))
forall a b. (a -> b) -> a -> b
$
(PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x))
(Event (SpiderTimeline x) a)
-> Event (SpiderTimeline x) ()
-> PerformEventT
(SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) a))
-> Event (SpiderTimeline x) ()
-> PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x))
(Event (SpiderTimeline x) a)
-> PerformEventT
(SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x))
(Event (SpiderTimeline x) a)
-> Event (SpiderTimeline x) ()
-> PerformEventT
(SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) a)
forall t (m :: * -> *) a. PostBuildT t m a -> Event t () -> m a
runPostBuildT Event (SpiderTimeline x) ()
postBuild (PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x))
(Event (SpiderTimeline x) a)
-> PerformEventT
(SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) a))
-> PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x))
(Event (SpiderTimeline x) a)
-> PerformEventT
(SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) a)
forall a b. (a -> b) -> a -> b
$
(TriggerEventT
(SpiderTimeline x)
(PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x)))
(Event (SpiderTimeline x) a)
-> Chan
[DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x))
(Event (SpiderTimeline x) a))
-> Chan
[DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> TriggerEventT
(SpiderTimeline x)
(PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x)))
(Event (SpiderTimeline x) a)
-> PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x))
(Event (SpiderTimeline x) a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TriggerEventT
(SpiderTimeline x)
(PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x)))
(Event (SpiderTimeline x) a)
-> Chan
[DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x))
(Event (SpiderTimeline x) a)
forall t (m :: * -> *) a.
TriggerEventT t m a
-> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
runTriggerEventT Chan [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
events (TriggerEventT
(SpiderTimeline x)
(PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x)))
(Event (SpiderTimeline x) a)
-> PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x))
(Event (SpiderTimeline x) a))
-> TriggerEventT
(SpiderTimeline x)
(PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x)))
(Event (SpiderTimeline x) a)
-> PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x))
(Event (SpiderTimeline x) a)
forall a b. (a -> b) -> a -> b
$
TriggerEventT
(SpiderTimeline x)
(PostBuildT
(SpiderTimeline x)
(PerformEventT (SpiderTimeline x) (SpiderHost x)))
(Event (SpiderTimeline x) a)
forall t (m :: * -> *). MonadHeadlessApp t m => m (Event t a)
guest
Maybe (RootTrigger x ())
mPostBuildTrigger <- Ref (SpiderHost x) (Maybe (RootTrigger x ()))
-> SpiderHost x (Maybe (RootTrigger x ()))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef IORef (Maybe (RootTrigger x ()))
Ref (SpiderHost x) (Maybe (RootTrigger x ()))
postBuildTriggerRef
SpiderEventHandle x a
shutdown <- Event (SpiderTimeline x) a
-> SpiderHost x (EventHandle (SpiderTimeline x) a)
forall t (m :: * -> *) a.
MonadSubscribeEvent t m =>
Event t a -> m (EventHandle t a)
subscribeEvent Event (SpiderTimeline x) a
result
Maybe [Maybe a]
initialShutdownEventFirings :: Maybe [Maybe a] <- Maybe (RootTrigger x ())
-> (RootTrigger x () -> SpiderHost x [Maybe a])
-> SpiderHost x (Maybe [Maybe a])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (RootTrigger x ())
mPostBuildTrigger ((RootTrigger x () -> SpiderHost x [Maybe a])
-> SpiderHost x (Maybe [Maybe a]))
-> (RootTrigger x () -> SpiderHost x [Maybe a])
-> SpiderHost x (Maybe [Maybe a])
forall a b. (a -> b) -> a -> b
$ \RootTrigger x ()
postBuildTrigger ->
[DSum (EventTrigger (SpiderTimeline x)) Identity]
-> ReadPhase (SpiderHost x) (Maybe a) -> SpiderHost x [Maybe a]
forall a.
[DSum (EventTrigger (SpiderTimeline x)) Identity]
-> ReadPhase (SpiderHost x) a -> SpiderHost x [a]
fire [RootTrigger x ()
postBuildTrigger RootTrigger x () -> Identity () -> DSum (RootTrigger x) Identity
forall k (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> () -> Identity ()
forall a. a -> Identity a
Identity ()] (ReadPhase (SpiderHost x) (Maybe a) -> SpiderHost x [Maybe a])
-> ReadPhase (SpiderHost x) (Maybe a) -> SpiderHost x [Maybe a]
forall a b. (a -> b) -> a -> b
$ Maybe (ReadPhase x a) -> ReadPhase x (Maybe a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Maybe (ReadPhase x a) -> ReadPhase x (Maybe a))
-> ReadPhase x (Maybe (ReadPhase x a)) -> ReadPhase x (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EventHandle (SpiderTimeline x) a
-> ReadPhase x (Maybe (ReadPhase x a))
forall t (m :: * -> *) a.
MonadReadEvent t m =>
EventHandle t a -> m (Maybe (m a))
readEvent EventHandle (SpiderTimeline x) a
SpiderEventHandle x a
shutdown
let shutdownImmediately :: Maybe a
shutdownImmediately = case Maybe [Maybe a]
initialShutdownEventFirings of
Maybe [Maybe a]
Nothing -> Maybe a
forall a. Maybe a
Nothing
Just [Maybe a]
firings -> [Maybe a] -> Maybe a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [Maybe a]
firings
case Maybe a
shutdownImmediately of
Just a
exitResult -> a -> SpiderHost x a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
exitResult
Maybe a
Nothing -> (SpiderHost x a -> SpiderHost x a) -> SpiderHost x a
forall a. (a -> a) -> a
fix ((SpiderHost x a -> SpiderHost x a) -> SpiderHost x a)
-> (SpiderHost x a -> SpiderHost x a) -> SpiderHost x a
forall a b. (a -> b) -> a -> b
$ \SpiderHost x a
loop -> do
[DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
ers <- IO [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> SpiderHost
x [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> SpiderHost
x [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation])
-> IO [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> SpiderHost
x [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
forall a b. (a -> b) -> a -> b
$ Chan [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> IO [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
forall a. Chan a -> IO a
readChan Chan [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
events
[Maybe a]
shutdownEventFirings :: [Maybe a] <- do
FireCommand (SpiderTimeline x) (SpiderHost x)
-> [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> ReadPhase (SpiderHost x) (Maybe a)
-> SpiderHost x [Maybe a]
forall b (m :: * -> *) t.
MonadIO m =>
FireCommand t m
-> [DSum (EventTriggerRef t) TriggerInvocation]
-> ReadPhase m b
-> m [b]
fireEventTriggerRefs FireCommand (SpiderTimeline x) (SpiderHost x)
fc [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
ers (ReadPhase (SpiderHost x) (Maybe a) -> SpiderHost x [Maybe a])
-> ReadPhase (SpiderHost x) (Maybe a) -> SpiderHost x [Maybe a]
forall a b. (a -> b) -> a -> b
$
Maybe (ReadPhase x a) -> ReadPhase x (Maybe a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Maybe (ReadPhase x a) -> ReadPhase x (Maybe a))
-> ReadPhase x (Maybe (ReadPhase x a)) -> ReadPhase x (Maybe a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EventHandle (SpiderTimeline x) a
-> ReadPhase x (Maybe (ReadPhase x a))
forall t (m :: * -> *) a.
MonadReadEvent t m =>
EventHandle t a -> m (Maybe (m a))
readEvent EventHandle (SpiderTimeline x) a
SpiderEventHandle x a
shutdown
let
shutdownNow :: Maybe a
shutdownNow = [Maybe a] -> Maybe a
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [Maybe a]
shutdownEventFirings
case Maybe a
shutdownNow of
Just a
exitResult -> a -> SpiderHost x a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
exitResult
Maybe a
Nothing -> SpiderHost x a
loop
where
fireEventTriggerRefs
:: forall b m t
. MonadIO m
=> FireCommand t m
-> [DSum (EventTriggerRef t) TriggerInvocation]
-> ReadPhase m b
-> m [b]
fireEventTriggerRefs :: FireCommand t m
-> [DSum (EventTriggerRef t) TriggerInvocation]
-> ReadPhase m b
-> m [b]
fireEventTriggerRefs (FireCommand forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire) [DSum (EventTriggerRef t) TriggerInvocation]
ers ReadPhase m b
rcb = do
[Maybe (DSum (EventTrigger t) Identity)]
mes <- IO [Maybe (DSum (EventTrigger t) Identity)]
-> m [Maybe (DSum (EventTrigger t) Identity)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Maybe (DSum (EventTrigger t) Identity)]
-> m [Maybe (DSum (EventTrigger t) Identity)])
-> IO [Maybe (DSum (EventTrigger t) Identity)]
-> m [Maybe (DSum (EventTrigger t) Identity)]
forall a b. (a -> b) -> a -> b
$
[DSum (EventTriggerRef t) TriggerInvocation]
-> (DSum (EventTriggerRef t) TriggerInvocation
-> IO (Maybe (DSum (EventTrigger t) Identity)))
-> IO [Maybe (DSum (EventTrigger t) Identity)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [DSum (EventTriggerRef t) TriggerInvocation]
ers ((DSum (EventTriggerRef t) TriggerInvocation
-> IO (Maybe (DSum (EventTrigger t) Identity)))
-> IO [Maybe (DSum (EventTrigger t) Identity)])
-> (DSum (EventTriggerRef t) TriggerInvocation
-> IO (Maybe (DSum (EventTrigger t) Identity)))
-> IO [Maybe (DSum (EventTrigger t) Identity)]
forall a b. (a -> b) -> a -> b
$ \(EventTriggerRef IORef (Maybe (EventTrigger t a))
er :=> TriggerInvocation a
a IO ()
_) -> do
Maybe (EventTrigger t a)
me <- IORef (Maybe (EventTrigger t a)) -> IO (Maybe (EventTrigger t a))
forall a. IORef a -> IO a
readIORef IORef (Maybe (EventTrigger t a))
er
Maybe (DSum (EventTrigger t) Identity)
-> IO (Maybe (DSum (EventTrigger t) Identity))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (DSum (EventTrigger t) Identity)
-> IO (Maybe (DSum (EventTrigger t) Identity)))
-> Maybe (DSum (EventTrigger t) Identity)
-> IO (Maybe (DSum (EventTrigger t) Identity))
forall a b. (a -> b) -> a -> b
$ (EventTrigger t a -> DSum (EventTrigger t) Identity)
-> Maybe (EventTrigger t a)
-> Maybe (DSum (EventTrigger t) Identity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EventTrigger t a -> a -> DSum (EventTrigger t) Identity
forall (f :: * -> *) (tag :: * -> *) a.
Applicative f =>
tag a -> a -> DSum tag f
==> a
a) Maybe (EventTrigger t a)
me
[b]
a <- [DSum (EventTrigger t) Identity] -> ReadPhase m b -> m [b]
forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire ([Maybe (DSum (EventTrigger t) Identity)]
-> [DSum (EventTrigger t) Identity]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (DSum (EventTrigger t) Identity)]
mes) ReadPhase m b
rcb
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [DSum (EventTriggerRef t) TriggerInvocation]
-> (DSum (EventTriggerRef t) TriggerInvocation -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [DSum (EventTriggerRef t) TriggerInvocation]
ers ((DSum (EventTriggerRef t) TriggerInvocation -> IO ()) -> IO ())
-> (DSum (EventTriggerRef t) TriggerInvocation -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(EventTriggerRef t a
_ :=> TriggerInvocation a
_ IO ()
cb) -> IO ()
cb
[b] -> m [b]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [b]
a