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

module Reflex.Host.Headless where

import Control.Concurrent.Chan (newChan, readChan)
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)
import Data.Traversable (for)

import Reflex
import Reflex.Host.Class

type MonadHeadlessApp t m =
  ( Adjustable t m
  , MonadFix m
  , MonadHold t m
  , MonadIO (HostFrame t)
  , MonadIO (Performable m)
  , MonadIO m
  , MonadRef (HostFrame t)
  , NotReady t m
  , PerformEvent t m
  , PostBuild t m
  , PrimMonad (HostFrame t)
  , Ref (HostFrame t) ~ IORef
  , Ref m ~ IORef
  , Reflex t
  , 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 guest :: 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.
    (postBuild :: Event (SpiderTimeline x) ()
postBuild, postBuildTriggerRef :: 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.
    (result :: Event (SpiderTimeline x) ()
result, fc :: FireCommand (SpiderTimeline x) (SpiderHost x)
fc@(FireCommand fire :: 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

    -- When there is a subscriber to the post-build event, fire the event.
    Maybe (RootTrigger x ())
-> (RootTrigger x () -> SpiderHost x [()]) -> SpiderHost x ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (RootTrigger x ())
mPostBuildTrigger ((RootTrigger x () -> SpiderHost x [()]) -> SpiderHost x ())
-> (RootTrigger x () -> SpiderHost x [()]) -> SpiderHost x ()
forall a b. (a -> b) -> a -> b
$ \postBuildTrigger :: RootTrigger x ()
postBuildTrigger ->
      [DSum (EventTrigger (SpiderTimeline x)) Identity]
-> ReadPhase (SpiderHost x) () -> SpiderHost x [()]
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) () -> SpiderHost x [()])
-> ReadPhase (SpiderHost x) () -> SpiderHost x [()]
forall a b. (a -> b) -> a -> b
$ () -> ReadPhase x ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- 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

    -- The main application loop. We wait for new events and fire those that
    -- have subscribers. If we detect a shutdown request, the application
    -- terminates.
    (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
$ \loop :: 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 (Maybe (ReadPhase x ()))
forall t (m :: * -> *) a.
MonadReadEvent t m =>
EventHandle t a -> m (Maybe (m a))
readEvent EventHandle (SpiderTimeline x) ()
SpiderEventHandle x ()
shutdown ReadPhase x (Maybe (ReadPhase x ()))
-> (Maybe (ReadPhase x ()) -> ReadPhase x Bool) -> ReadPhase x Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Nothing -> Bool -> ReadPhase x Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            Just _ -> Bool -> ReadPhase x Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      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
    -- 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 fire :: forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire) ers :: [DSum (EventTriggerRef t) TriggerInvocation]
ers rcb :: 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 er :: IORef (Maybe (EventTrigger t a))
er :=> TriggerInvocation a :: a
a _) -> 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
$ \(_ :=> TriggerInvocation _ cb :: IO ()
cb) -> IO ()
cb
      [a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
a