{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}

module Reflex.Host.Headless where

import Control.Concurrent.Chan (newChan, readChan)
import Control.Monad (unless)
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_)
import Data.Functor.Identity (Identity(..))
import Data.IORef (IORef, readIORef)
import Data.Maybe (catMaybes, fromMaybe)
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
  )

-- | Run a headless FRP network. Inside the action, you will most probably use
-- the capabilities provided by the 'TriggerEvent' and 'PerformEvent' type
-- classes to interface the FRP network with the outside world. Useful for
-- testing. Each headless network runs on its own spider timeline.
runHeadlessApp
  :: (forall t m. MonadHeadlessApp t m => m (Event t ()))
  -- ^ The action to be run in the headless FRP network. The FRP network is
  -- closed at the first occurrence of the resulting 'Event'.
  -> IO ()
runHeadlessApp :: (forall t (m :: * -> *). MonadHeadlessApp t m => m (Event t ()))
-> IO ()
runHeadlessApp forall t (m :: * -> *). MonadHeadlessApp t m => m (Event t ())
guest =
  -- We are using the 'Spider' implementation of reflex. Running the host
  -- allows us to take actions on the FRP timeline.
  (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO ())
-> IO ()
forall r.
(forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r)
-> IO r
withSpiderTimeline ((forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO ())
 -> IO ())
-> (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ SpiderHost x () -> SpiderTimelineEnv x -> IO ()
forall x a. SpiderHost x a -> SpiderTimelineEnv x -> IO a
runSpiderHostForTimeline (SpiderHost x () -> SpiderTimelineEnv x -> IO ())
-> SpiderHost x () -> SpiderTimelineEnv x -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- Create the "post-build" event and associated trigger. This event fires
    -- once, when the application starts.
    (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
    -- Create a queue to which we will write 'Event's that need to be
    -- processed.
    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
    -- Run the "guest" application, providing the appropriate context. We'll
    -- pure the result of the action, and a 'FireCommand' that will be used to
    -- trigger events.
    (Event (SpiderTimeline x) ()
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) ())
-> SpiderHost
     x
     (Event (SpiderTimeline x) (),
      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) ())
 -> SpiderHost
      x
      (Event (SpiderTimeline x) (),
       FireCommand (SpiderTimeline x) (SpiderHost x)))
-> PerformEventT
     (SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) ())
-> SpiderHost
     x
     (Event (SpiderTimeline x) (),
      FireCommand (SpiderTimeline x) (SpiderHost x))
forall a b. (a -> b) -> a -> b
$                 -- Allows the guest app to run
                                          -- 'performEvent', so that actions
                                          -- (e.g., IO actions) can be run when
                                          -- 'Event's fire.

        (PostBuildT
   (SpiderTimeline x)
   (PerformEventT (SpiderTimeline x) (SpiderHost x))
   (Event (SpiderTimeline x) ())
 -> Event (SpiderTimeline x) ()
 -> PerformEventT
      (SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) ()))
-> Event (SpiderTimeline x) ()
-> PostBuildT
     (SpiderTimeline x)
     (PerformEventT (SpiderTimeline x) (SpiderHost x))
     (Event (SpiderTimeline x) ())
-> PerformEventT
     (SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip PostBuildT
  (SpiderTimeline x)
  (PerformEventT (SpiderTimeline x) (SpiderHost x))
  (Event (SpiderTimeline x) ())
-> Event (SpiderTimeline x) ()
-> PerformEventT
     (SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) ())
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) ())
 -> PerformEventT
      (SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) ()))
-> PostBuildT
     (SpiderTimeline x)
     (PerformEventT (SpiderTimeline x) (SpiderHost x))
     (Event (SpiderTimeline x) ())
-> PerformEventT
     (SpiderTimeline x) (SpiderHost x) (Event (SpiderTimeline x) ())
forall a b. (a -> b) -> a -> b
$    -- Allows the guest app to access to
                                          -- a "post-build" 'Event'

          (TriggerEventT
   (SpiderTimeline x)
   (PostBuildT
      (SpiderTimeline x)
      (PerformEventT (SpiderTimeline x) (SpiderHost x)))
   (Event (SpiderTimeline x) ())
 -> Chan
      [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
 -> PostBuildT
      (SpiderTimeline x)
      (PerformEventT (SpiderTimeline x) (SpiderHost x))
      (Event (SpiderTimeline x) ()))
-> Chan
     [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> TriggerEventT
     (SpiderTimeline x)
     (PostBuildT
        (SpiderTimeline x)
        (PerformEventT (SpiderTimeline x) (SpiderHost x)))
     (Event (SpiderTimeline x) ())
-> PostBuildT
     (SpiderTimeline x)
     (PerformEventT (SpiderTimeline x) (SpiderHost x))
     (Event (SpiderTimeline x) ())
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) ())
-> Chan
     [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> PostBuildT
     (SpiderTimeline x)
     (PerformEventT (SpiderTimeline x) (SpiderHost x))
     (Event (SpiderTimeline x) ())
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) ())
 -> PostBuildT
      (SpiderTimeline x)
      (PerformEventT (SpiderTimeline x) (SpiderHost x))
      (Event (SpiderTimeline x) ()))
-> TriggerEventT
     (SpiderTimeline x)
     (PostBuildT
        (SpiderTimeline x)
        (PerformEventT (SpiderTimeline x) (SpiderHost x)))
     (Event (SpiderTimeline x) ())
-> PostBuildT
     (SpiderTimeline x)
     (PerformEventT (SpiderTimeline x) (SpiderHost x))
     (Event (SpiderTimeline x) ())
forall a b. (a -> b) -> a -> b
$  -- Allows the guest app to create new
                                          -- events and triggers and write
                                          -- those triggers to a channel from
                                          -- which they will be read and
                                          -- processed.
            TriggerEventT
  (SpiderTimeline x)
  (PostBuildT
     (SpiderTimeline x)
     (PerformEventT (SpiderTimeline x) (SpiderHost x)))
  (Event (SpiderTimeline x) ())
forall t (m :: * -> *). MonadHeadlessApp t m => m (Event t ())
guest

    -- Read the trigger reference for the post-build event. This will be
    -- 'Nothing' if the guest application hasn't subscribed to this event.
    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

    -- Subscribe to an 'Event' of that the guest application can use to
    -- request application shutdown. We'll check whether this 'Event' is firing
    -- to determine whether to terminate.
    SpiderEventHandle x ()
shutdown <- Event (SpiderTimeline x) ()
-> SpiderHost x (EventHandle (SpiderTimeline x) ())
forall t (m :: * -> *) a.
MonadSubscribeEvent t m =>
Event t a -> m (EventHandle t a)
subscribeEvent Event (SpiderTimeline x) ()
result

    -- When there is a subscriber to the post-build event, fire the event.
    Maybe [Bool]
soa <- Maybe (RootTrigger x ())
-> (RootTrigger x () -> SpiderHost x [Bool])
-> SpiderHost x (Maybe [Bool])
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 [Bool])
 -> SpiderHost x (Maybe [Bool]))
-> (RootTrigger x () -> SpiderHost x [Bool])
-> SpiderHost x (Maybe [Bool])
forall a b. (a -> b) -> a -> b
$ \RootTrigger x ()
postBuildTrigger ->
      [DSum (EventTrigger (SpiderTimeline x)) Identity]
-> ReadPhase (SpiderHost x) Bool -> SpiderHost x [Bool]
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) Bool -> SpiderHost x [Bool])
-> ReadPhase (SpiderHost x) Bool -> SpiderHost x [Bool]
forall a b. (a -> b) -> a -> b
$ EventHandle (SpiderTimeline x) () -> ReadPhase x Bool
forall t (m :: * -> *) a.
MonadReadEvent t m =>
EventHandle t a -> m Bool
isFiring EventHandle (SpiderTimeline x) ()
SpiderEventHandle x ()
shutdown

    -- The main application loop. We wait for new events and fire those that
    -- have subscribers. If we detect a shutdown request, the application
    -- terminates.
    Bool -> SpiderHost x () -> SpiderHost x ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Maybe [Bool] -> [Bool]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Bool]
soa)) (SpiderHost x () -> SpiderHost x ())
-> SpiderHost x () -> SpiderHost x ()
forall a b. (a -> b) -> a -> b
$ (SpiderHost x () -> SpiderHost x ()) -> SpiderHost x ()
forall a. (a -> a) -> a
fix ((SpiderHost x () -> SpiderHost x ()) -> SpiderHost x ())
-> (SpiderHost x () -> SpiderHost x ()) -> SpiderHost x ()
forall a b. (a -> b) -> a -> b
$ \SpiderHost x ()
loop -> do
      -- Read the next event (blocking).
      [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
      [Bool]
stop <- do
        -- Fire events that have subscribers.
        FireCommand (SpiderTimeline x) (SpiderHost x)
-> [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
-> ReadPhase (SpiderHost x) Bool
-> SpiderHost x [Bool]
forall (m :: * -> *) t a.
MonadIO m =>
FireCommand t m
-> [DSum (EventTriggerRef t) TriggerInvocation]
-> ReadPhase m a
-> m [a]
fireEventTriggerRefs FireCommand (SpiderTimeline x) (SpiderHost x)
fc [DSum (EventTriggerRef (SpiderTimeline x)) TriggerInvocation]
ers (ReadPhase (SpiderHost x) Bool -> SpiderHost x [Bool])
-> ReadPhase (SpiderHost x) Bool -> SpiderHost x [Bool]
forall a b. (a -> b) -> a -> b
$
          -- Check if the shutdown 'Event' is firing.
          EventHandle (SpiderTimeline x) () -> ReadPhase x Bool
forall t (m :: * -> *) a.
MonadReadEvent t m =>
EventHandle t a -> m Bool
isFiring EventHandle (SpiderTimeline x) ()
SpiderEventHandle x ()
shutdown
      if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
stop
        then () -> SpiderHost x ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        else SpiderHost x ()
loop
  where
    isFiring :: EventHandle t a -> m Bool
isFiring EventHandle t a
ev = EventHandle t a -> m (Maybe (m a))
forall t (m :: * -> *) a.
MonadReadEvent t m =>
EventHandle t a -> m (Maybe (m a))
readEvent EventHandle t a
ev m (Maybe (m a)) -> (Maybe (m a) -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (m a)
Nothing -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Just m a
_ -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    -- Use the given 'FireCommand' to fire events that have subscribers
    -- and call the callback for the 'TriggerInvocation' of each.
    fireEventTriggerRefs
      :: MonadIO m
      => FireCommand t m
      -> [DSum (EventTriggerRef t) TriggerInvocation]
      -> ReadPhase m a
      -> m [a]
    fireEventTriggerRefs :: FireCommand t m
-> [DSum (EventTriggerRef t) TriggerInvocation]
-> ReadPhase m a
-> m [a]
fireEventTriggerRefs (FireCommand forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire) [DSum (EventTriggerRef t) TriggerInvocation]
ers ReadPhase m a
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
      [a]
a <- [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
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 a
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
      [a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
a