{-# LANGUAGE RecordWildCards #-}

-- |
-- Module:
--   Reflex.Test.SimpleHost
-- Description:
--   This module contains reflex host methods for testing without external events

module Reflex.Test.SimpleHost
  ( TestGuestConstraints
  , TestGuestT
  , AppIn(..)
  , AppOut(..)
  , AppFrame(..)
  , getAppFrame
  , tickAppFrame
  , runAppSimple
  , runApp
  , runApp'
  , runAppB
  )
where

import           Prelude

import           Control.Monad
import           Control.Monad.Fix
import           Control.Monad.IO.Class
import           Control.Monad.Ref
import           Data.Dependent.Sum
import           Data.Functor.Identity
import           Data.Kind
import           Data.These

import           Reflex
import           Reflex.Host.Class


type TestGuestT t (m :: Type -> Type) = PostBuildT t (PerformEventT t m)

-- TODO some of these constraints can be dropped probably
type TestGuestConstraints t (m :: Type -> Type)
  = ( MonadReflexHost t m
    , MonadHold t m
    , MonadSample t m
    , Ref m ~ Ref IO
    , MonadRef m
    , MonadRef (HostFrame t)
    , Ref (HostFrame t) ~ Ref IO
    , MonadIO (HostFrame t)
  --, PrimMonad (HostFrame t)
    , MonadIO m
    , MonadFix m
    )

data AppIn t b e = AppIn
    { forall t b e. AppIn t b e -> Behavior t b
_appIn_behavior :: Behavior t b
    , forall t b e. AppIn t b e -> Event t e
_appIn_event    :: Event t e
    }

data AppOut t b e = AppOut
    { forall t b e. AppOut t b e -> Behavior t b
_appOut_behavior :: Behavior t b
    , forall t b e. AppOut t b e -> Event t e
_appOut_event    :: Event t e
    }

data AppFrame t bIn eIn bOut eOut m = AppFrame
    { forall t bIn eIn bOut eOut (m :: * -> *).
AppFrame t bIn eIn bOut eOut m -> ReadPhase m (bOut, Maybe eOut)
_appFrame_readPhase :: ReadPhase m (bOut, Maybe eOut)
    , forall t bIn eIn bOut eOut (m :: * -> *).
AppFrame t bIn eIn bOut eOut m -> Maybe (EventTrigger t bIn)
_appFrame_mpulseB :: Maybe (EventTrigger t bIn)
    , forall t bIn eIn bOut eOut (m :: * -> *).
AppFrame t bIn eIn bOut eOut m -> Maybe (EventTrigger t eIn)
_appFrame_mpulseE :: Maybe (EventTrigger t eIn)
    , forall t bIn eIn bOut eOut (m :: * -> *).
AppFrame t bIn eIn bOut eOut m
-> forall a.
   [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
_appFrame_fire :: forall a .
  [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
    }

-- | make an 'AppFrame' that takes an input behavior and event and returns an
-- output behavior and event. This will also fire the 'PostBuild' event if there
-- are any subscribers.
getAppFrame
  :: forall t bIn eIn bOut eOut m
   . (TestGuestConstraints t m)
  => (AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut))
  -> bIn
  -> m (AppFrame t bIn eIn bOut eOut m)
getAppFrame :: forall t bIn eIn bOut eOut (m :: * -> *).
TestGuestConstraints t m =>
(AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut))
-> bIn -> m (AppFrame t bIn eIn bOut eOut m)
getAppFrame AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut)
app bIn
b0 = do

  -- Create the "post-build" event and associated trigger. This event fires
  -- once, when the application starts.
  (Event t ()
postBuild , IORef (Maybe (EventTrigger t ()))
postBuildTriggerRef ) <- 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 input behavior, events, and  assosciated triggers.
  (Event t bIn
appInHoldE, IORef (Maybe (EventTrigger t bIn))
pulseHoldTriggerRef ) <- forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
newEventWithTriggerRef
  (Event t eIn
appInE    , IORef (Maybe (EventTrigger t eIn))
pulseEventTriggerRef) <- forall t (m :: * -> *) a.
(MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) =>
m (Event t a, Ref m (Maybe (EventTrigger t a)))
newEventWithTriggerRef
  Behavior t bIn
appInB                             <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Behavior t a)
hold bIn
b0 Event t bIn
appInHoldE

  -- Setup the app and obtain its output events and 'FireCommand'
  (AppOut t bOut eOut
out :: AppOut t bOut eOut, FireCommand forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire) <-
    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 forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall t (m :: * -> *) a. PostBuildT t m a -> Event t () -> m a
runPostBuildT Event t ()
postBuild forall a b. (a -> b) -> a -> b
$ AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut)
app forall a b. (a -> b) -> a -> b
$ AppIn
      { _appIn_event :: Event t eIn
_appIn_event    = Event t eIn
appInE
      , _appIn_behavior :: Behavior t bIn
_appIn_behavior = Behavior t bIn
appInB
      }


  -- Read the trigger reference for the post-build event. This will be
  -- 'Nothing' if the guest application hasn't subscribed to this event.
  Maybe (EventTrigger t ())
mPostBuildTrigger <- forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef IORef (Maybe (EventTrigger t ()))
postBuildTriggerRef

  -- When there is a subscriber to the post-build event, fire the event.
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (EventTrigger t ())
mPostBuildTrigger
    forall a b. (a -> b) -> a -> b
$ \EventTrigger t ()
postBuildTrigger -> forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire [EventTrigger t ()
postBuildTrigger forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall a. a -> Identity a
Identity ()] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()

  --
  EventHandle t eOut
hnd :: EventHandle t eOut <- forall t (m :: * -> *) a.
MonadSubscribeEvent t m =>
Event t a -> m (EventHandle t a)
subscribeEvent (forall t b e. AppOut t b e -> Event t e
_appOut_event AppOut t bOut eOut
out)
  Maybe (EventTrigger t bIn)
mpulseB                   <- forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef IORef (Maybe (EventTrigger t bIn))
pulseHoldTriggerRef
  Maybe (EventTrigger t eIn)
mpulseE                   <- forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef IORef (Maybe (EventTrigger t eIn))
pulseEventTriggerRef
  let readPhase :: ReadPhase m (bOut, Maybe eOut)
readPhase = do
        bOut
b      <- forall {k} (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample (forall t b e. AppOut t b e -> Behavior t b
_appOut_behavior AppOut t bOut eOut
out)
        Maybe eOut
frames <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall t (m :: * -> *) a.
MonadReadEvent t m =>
EventHandle t a -> m (Maybe (m a))
readEvent EventHandle t eOut
hnd
        return (bOut
b, Maybe eOut
frames)
  return AppFrame { _appFrame_readPhase :: ReadPhase m (bOut, Maybe eOut)
_appFrame_readPhase = ReadPhase m (bOut, Maybe eOut)
readPhase
                  , _appFrame_mpulseB :: Maybe (EventTrigger t bIn)
_appFrame_mpulseB   = Maybe (EventTrigger t bIn)
mpulseB
                  , _appFrame_mpulseE :: Maybe (EventTrigger t eIn)
_appFrame_mpulseE   = Maybe (EventTrigger t eIn)
mpulseE
                  , _appFrame_fire :: forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
_appFrame_fire      = forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
fire
                  }

-- | Tick an app frame once with optional input behavior and event values.
-- Returns behaviors and events from the app's output for each frame that run
-- for the input (i.e. 'runWithAdjust' and 'performEvent' may cause several
-- frames to run for each input)
--
-- N.B. output behavior will not reflect changes that happen during its frame
-- i.e. this is analogous to 'tag' and 'tagPromptlyDyn'. If you need the most
-- recent behavior value you can always call 'tickAppFrame' with 'Nothing' as
-- input
tickAppFrame
  :: AppFrame t bIn eIn bOut eOut m
  -> Maybe (These bIn eIn)
  -> m [(bOut, Maybe eOut)]
tickAppFrame :: forall t bIn eIn bOut eOut (m :: * -> *).
AppFrame t bIn eIn bOut eOut m
-> Maybe (These bIn eIn) -> m [(bOut, Maybe eOut)]
tickAppFrame AppFrame {Maybe (EventTrigger t bIn)
Maybe (EventTrigger t eIn)
ReadPhase m (bOut, Maybe eOut)
forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
_appFrame_fire :: forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
_appFrame_mpulseE :: Maybe (EventTrigger t eIn)
_appFrame_mpulseB :: Maybe (EventTrigger t bIn)
_appFrame_readPhase :: ReadPhase m (bOut, Maybe eOut)
_appFrame_fire :: forall t bIn eIn bOut eOut (m :: * -> *).
AppFrame t bIn eIn bOut eOut m
-> forall a.
   [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
_appFrame_mpulseE :: forall t bIn eIn bOut eOut (m :: * -> *).
AppFrame t bIn eIn bOut eOut m -> Maybe (EventTrigger t eIn)
_appFrame_mpulseB :: forall t bIn eIn bOut eOut (m :: * -> *).
AppFrame t bIn eIn bOut eOut m -> Maybe (EventTrigger t bIn)
_appFrame_readPhase :: forall t bIn eIn bOut eOut (m :: * -> *).
AppFrame t bIn eIn bOut eOut m -> ReadPhase m (bOut, Maybe eOut)
..} Maybe (These bIn eIn)
input = m [(bOut, Maybe eOut)]
r where
  fire :: [DSum (EventTrigger t) Identity]
-> ReadPhase m (bOut, Maybe eOut) -> m [(bOut, Maybe eOut)]
fire      = forall a.
[DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a]
_appFrame_fire
  readPhase :: ReadPhase m (bOut, Maybe eOut)
readPhase = ReadPhase m (bOut, Maybe eOut)
_appFrame_readPhase
  mpulseB :: Maybe (EventTrigger t bIn)
mpulseB   = Maybe (EventTrigger t bIn)
_appFrame_mpulseB
  mpulseE :: Maybe (EventTrigger t eIn)
mpulseE   = Maybe (EventTrigger t eIn)
_appFrame_mpulseE
  makeFiring :: Maybe (tag a) -> a -> [DSum tag Identity]
makeFiring Maybe (tag a)
mpulse a
v = case Maybe (tag a)
mpulse of
    Just tag a
pulse -> [tag a
pulse forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=> forall a. a -> Identity a
Identity a
v]
    Maybe (tag a)
Nothing    -> []
  firings :: [DSum (EventTrigger t) Identity]
firings =    case Maybe (These bIn eIn)
input of
    Maybe (These bIn eIn)
Nothing -> []
    Just These bIn eIn
i  -> case These bIn eIn
i of
      This bIn
b'     -> forall {tag :: * -> *} {a}.
Maybe (tag a) -> a -> [DSum tag Identity]
makeFiring Maybe (EventTrigger t bIn)
mpulseB bIn
b'
      That eIn
e'        -> forall {tag :: * -> *} {a}.
Maybe (tag a) -> a -> [DSum tag Identity]
makeFiring Maybe (EventTrigger t eIn)
mpulseE eIn
e'
      These bIn
b'       eIn
e' -> forall {tag :: * -> *} {a}.
Maybe (tag a) -> a -> [DSum tag Identity]
makeFiring Maybe (EventTrigger t bIn)
mpulseB bIn
b' forall a. Semigroup a => a -> a -> a
<> forall {tag :: * -> *} {a}.
Maybe (tag a) -> a -> [DSum tag Identity]
makeFiring Maybe (EventTrigger t eIn)
mpulseE eIn
e'
  r :: m [(bOut, Maybe eOut)]
r = [DSum (EventTrigger t) Identity]
-> ReadPhase m (bOut, Maybe eOut) -> m [(bOut, Maybe eOut)]
fire [DSum (EventTrigger t) Identity]
firings ReadPhase m (bOut, Maybe eOut)
readPhase


-- | calls 'tickAppFrame' for each input in a list and returns collected results
-- see comments for 'tickAppFrame'
runApp
  :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
  => (AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut))
  -> bIn
  -> [Maybe (These bIn eIn)]
  -> IO [[(bOut, Maybe eOut)]]
runApp :: forall t (m :: * -> *) bIn eIn bOut eOut.
(t ~ SpiderTimeline Global, m ~ SpiderHost Global) =>
(AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut))
-> bIn -> [Maybe (These bIn eIn)] -> IO [[(bOut, Maybe eOut)]]
runApp AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut)
app bIn
b0 [Maybe (These bIn eIn)]
input = forall a. SpiderHost Global a -> IO a
runSpiderHost forall a b. (a -> b) -> a -> b
$ do
  AppFrame t bIn eIn bOut eOut (SpiderHost Global)
appFrame <- forall t bIn eIn bOut eOut (m :: * -> *).
TestGuestConstraints t m =>
(AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut))
-> bIn -> m (AppFrame t bIn eIn bOut eOut m)
getAppFrame AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut)
app bIn
b0
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Maybe (These bIn eIn)]
input forall a b. (a -> b) -> a -> b
$ forall t bIn eIn bOut eOut (m :: * -> *).
AppFrame t bIn eIn bOut eOut m
-> Maybe (These bIn eIn) -> m [(bOut, Maybe eOut)]
tickAppFrame AppFrame t bIn eIn bOut eOut (SpiderHost Global)
appFrame

-- | run an app with provided list of input events returns list of results for
-- each input. Each result is a list of events from the app's output for each
-- frame that run for the input.
-- see comments for 'tickAppFrame'
runAppSimple
  :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
  => (Event t eIn -> TestGuestT t m (Event t eOut))
  -> [eIn]
  -> IO [[Maybe eOut]]
runAppSimple :: forall t (m :: * -> *) eIn eOut.
(t ~ SpiderTimeline Global, m ~ SpiderHost Global) =>
(Event t eIn -> TestGuestT t m (Event t eOut))
-> [eIn] -> IO [[Maybe eOut]]
runAppSimple Event t eIn -> TestGuestT t m (Event t eOut)
app [eIn]
input = forall t (m :: * -> *) eIn eOut.
(t ~ SpiderTimeline Global, m ~ SpiderHost Global) =>
(Event t eIn -> TestGuestT t m (Event t eOut))
-> [Maybe eIn] -> IO [[Maybe eOut]]
runApp' Event t eIn -> TestGuestT t m (Event t eOut)
app (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [eIn]
input)

-- | same as runAppSimple except input event for each frame is optional
-- see comments for 'tickAppFrame'
runApp'
  :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
  => (Event t eIn -> TestGuestT t m (Event t eOut))
  -> [Maybe eIn]
  -> IO [[Maybe eOut]]
runApp' :: forall t (m :: * -> *) eIn eOut.
(t ~ SpiderTimeline Global, m ~ SpiderHost Global) =>
(Event t eIn -> TestGuestT t m (Event t eOut))
-> [Maybe eIn] -> IO [[Maybe eOut]]
runApp' Event t eIn -> TestGuestT t m (Event t eOut)
app [Maybe eIn]
input = do
  let app' :: Event t eIn -> PostBuildT t (PerformEventT t m) (AppOut t () eOut)
app' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall t b e. Behavior t b -> Event t e -> AppOut t b e
AppOut (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event t eIn -> TestGuestT t m (Event t eOut)
app
  forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *) bIn eIn bOut eOut.
(t ~ SpiderTimeline Global, m ~ SpiderHost Global) =>
(AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut))
-> bIn -> [Maybe (These bIn eIn)] -> IO [[(bOut, Maybe eOut)]]
runApp (Event t eIn -> PostBuildT t (PerformEventT t m) (AppOut t () eOut)
app' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t b e. AppIn t b e -> Event t e
_appIn_event) () (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> These a b
That) [Maybe eIn]
input)

-- | same as runApp' except only returns sampled output behavior
-- see comments for 'tickAppFrame'
runAppB
  :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
  => (Event t eIn -> TestGuestT t m (Behavior t bOut))
  -> [Maybe eIn]
  -> IO [[bOut]]
runAppB :: forall t (m :: * -> *) eIn bOut.
(t ~ SpiderTimeline Global, m ~ SpiderHost Global) =>
(Event t eIn -> TestGuestT t m (Behavior t bOut))
-> [Maybe eIn] -> IO [[bOut]]
runAppB Event t eIn -> TestGuestT t m (Behavior t bOut)
app [Maybe eIn]
input = do
  let app' :: Event t eIn -> PostBuildT t (PerformEventT t m) (AppOut t bOut Any)
app' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall t b e. Behavior t b -> Event t e -> AppOut t b e
AppOut forall {k} (t :: k) a. Reflex t => Event t a
never) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event t eIn -> TestGuestT t m (Behavior t bOut)
app
  forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *) bIn eIn bOut eOut.
(t ~ SpiderTimeline Global, m ~ SpiderHost Global) =>
(AppIn t bIn eIn -> TestGuestT t m (AppOut t bOut eOut))
-> bIn -> [Maybe (These bIn eIn)] -> IO [[(bOut, Maybe eOut)]]
runApp (Event t eIn -> PostBuildT t (PerformEventT t m) (AppOut t bOut Any)
app' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t b e. AppIn t b e -> Event t e
_appIn_event) () (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> These a b
That) [Maybe eIn]
input)