{-# LANGUAGE FlexibleContexts, GADTs, RankNTypes, ScopedTypeVariables #-}
-- | Internal helpers for taking asynchronous machine steps.
module Data.Machine.Concurrent.AsyncStep where
import Control.Concurrent.Async.Lifted (Async, async, wait)
import Control.Monad.Trans.Control (MonadBaseControl, StM)
import Data.Machine

-- | Slightly more compact notation for a 'Step'.
type MachineStep m k o = Step k o (MachineT m k o)

-- | Compact notation for a 'Step' taken asynchronously.
type AsyncStep m k o = Async (StM m (MachineStep m k o))

-- | Build an 'Await' step given a continuation that provides
-- subsequent steps. @awaitStep f sel ff k@ is like applying the
-- 'Await' constructor directly, but the continuation @k@ is used to
-- continue the machine. 
-- 
-- @awaitStep f sel ff k = Await (k . f) sel (k ff)@
awaitStep :: (a -> d) -> k' a -> d -> (d -> r) -> Step k' b r
awaitStep :: (a -> d) -> k' a -> d -> (d -> r) -> Step k' b r
awaitStep a -> d
f k' a
sel d
ff d -> r
k = (a -> r) -> k' a -> r -> Step k' b r
forall (k :: * -> *) o r t. (t -> r) -> k t -> r -> Step k o r
Await (d -> r
k (d -> r) -> (a -> d) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> d
f) k' a
sel (d -> r
k d
ff)

-- | Run one step of a machine as an 'Async' operation.
asyncRun :: MonadBaseControl IO m => MachineT m k o -> m (AsyncStep m k o)
asyncRun :: MachineT m k o -> m (AsyncStep m k o)
asyncRun = m (Step k o (MachineT m k o)) -> m (AsyncStep m k o)
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async (m (Step k o (MachineT m k o)) -> m (AsyncStep m k o))
-> (MachineT m k o -> m (Step k o (MachineT m k o)))
-> MachineT m k o
-> m (AsyncStep m k o)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MachineT m k o -> m (Step k o (MachineT m k o))
forall (m :: * -> *) (k :: * -> *) o.
MachineT m k o -> m (Step k o (MachineT m k o))
runMachineT

-- | Satisfy a downstream Await by blocking on an upstream step.
stepAsync :: forall m k k' a' d b.
             MonadBaseControl IO m
           => (forall c. k c -> k' c)
           -> AsyncStep m k a'
           -> (a' -> d)
           -> d
           -> d
           -> (AsyncStep m k a' -> d -> MachineT m k' b)
           -> MachineT m k' b
stepAsync :: (forall c. k c -> k' c)
-> AsyncStep m k a'
-> (a' -> d)
-> d
-> d
-> (AsyncStep m k a' -> d -> MachineT m k' b)
-> MachineT m k' b
stepAsync forall c. k c -> k' c
sel AsyncStep m k a'
src a' -> d
f d
def d
prev AsyncStep m k a' -> d -> MachineT m k' b
go = m (Step k' b (MachineT m k' b)) -> MachineT m k' b
forall (m :: * -> *) (k :: * -> *) o.
m (Step k o (MachineT m k o)) -> MachineT m k o
MachineT (m (Step k' b (MachineT m k' b)) -> MachineT m k' b)
-> m (Step k' b (MachineT m k' b)) -> MachineT m k' b
forall a b. (a -> b) -> a -> b
$ AsyncStep m k a' -> m (Step k a' (MachineT m k a'))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
Async (StM m a) -> m a
wait AsyncStep m k a'
src m (Step k a' (MachineT m k a'))
-> (Step k a' (MachineT m k a') -> m (Step k' b (MachineT m k' b)))
-> m (Step k' b (MachineT m k' b))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Step k a' (MachineT m k a')
u -> case Step k a' (MachineT m k a')
u of
  Step k a' (MachineT m k a')
Stop -> MachineT m k a' -> d -> m (Step k' b (MachineT m k' b))
go' MachineT m k a'
forall (k :: * -> *) b. Machine k b
stopped d
def
  Yield a'
a MachineT m k a'
k -> MachineT m k a' -> d -> m (Step k' b (MachineT m k' b))
go' MachineT m k a'
k (a' -> d
f a'
a)
  Await t -> MachineT m k a'
g k t
kg MachineT m k a'
fg -> Step k' b (MachineT m k' b) -> m (Step k' b (MachineT m k' b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Step k' b (MachineT m k' b) -> m (Step k' b (MachineT m k' b)))
-> Step k' b (MachineT m k' b) -> m (Step k' b (MachineT m k' b))
forall a b. (a -> b) -> a -> b
$ (t -> MachineT m k a')
-> k' t
-> MachineT m k a'
-> (MachineT m k a' -> MachineT m k' b)
-> Step k' b (MachineT m k' b)
forall a d (k' :: * -> *) r b.
(a -> d) -> k' a -> d -> (d -> r) -> Step k' b r
awaitStep t -> MachineT m k a'
g (k t -> k' t
forall c. k c -> k' c
sel k t
kg) MachineT m k a'
fg (m (Step k' b (MachineT m k' b)) -> MachineT m k' b
forall (m :: * -> *) (k :: * -> *) o.
m (Step k o (MachineT m k o)) -> MachineT m k o
MachineT (m (Step k' b (MachineT m k' b)) -> MachineT m k' b)
-> (MachineT m k a' -> m (Step k' b (MachineT m k' b)))
-> MachineT m k a'
-> MachineT m k' b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MachineT m k a' -> d -> m (Step k' b (MachineT m k' b)))
-> d -> MachineT m k a' -> m (Step k' b (MachineT m k' b))
forall a b c. (a -> b -> c) -> b -> a -> c
flip MachineT m k a' -> d -> m (Step k' b (MachineT m k' b))
go' d
prev)
  where go' :: MachineT m k a' -> d -> m (MachineStep m k' b)
        go' :: MachineT m k a' -> d -> m (Step k' b (MachineT m k' b))
go' MachineT m k a'
k d
d = MachineT m k a' -> m (AsyncStep m k a')
forall (m :: * -> *) (k :: * -> *) o.
MonadBaseControl IO m =>
MachineT m k o -> m (AsyncStep m k o)
asyncRun MachineT m k a'
k m (AsyncStep m k a')
-> (AsyncStep m k a' -> m (Step k' b (MachineT m k' b)))
-> m (Step k' b (MachineT m k' b))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MachineT m k' b -> m (Step k' b (MachineT m k' b))
forall (m :: * -> *) (k :: * -> *) o.
MachineT m k o -> m (Step k o (MachineT m k o))
runMachineT (MachineT m k' b -> m (Step k' b (MachineT m k' b)))
-> (AsyncStep m k a' -> MachineT m k' b)
-> AsyncStep m k a'
-> m (Step k' b (MachineT m k' b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AsyncStep m k a' -> d -> MachineT m k' b)
-> d -> AsyncStep m k a' -> MachineT m k' b
forall a b c. (a -> b -> c) -> b -> a -> c
flip AsyncStep m k a' -> d -> MachineT m k' b
go d
d

-- | @asyncEncased f x@ launches @x@ and provides the resulting
-- 'AsyncStep' to @f@. Turn a function on 'AsyncStep' to a funciton on
-- 'MachineT'.
asyncEncased :: MonadBaseControl IO m
             => (AsyncStep m k1 o1 -> MachineT m k o)
             -> MachineT m k1 o1
             -> MachineT m k o
asyncEncased :: (AsyncStep m k1 o1 -> MachineT m k o)
-> MachineT m k1 o1 -> MachineT m k o
asyncEncased AsyncStep m k1 o1 -> MachineT m k o
f MachineT m k1 o1
x = m (Step k o (MachineT m k o)) -> MachineT m k o
forall (m :: * -> *) (k :: * -> *) o.
m (Step k o (MachineT m k o)) -> MachineT m k o
MachineT (m (Step k o (MachineT m k o)) -> MachineT m k o)
-> m (Step k o (MachineT m k o)) -> MachineT m k o
forall a b. (a -> b) -> a -> b
$ MachineT m k1 o1 -> m (AsyncStep m k1 o1)
forall (m :: * -> *) (k :: * -> *) o.
MonadBaseControl IO m =>
MachineT m k o -> m (AsyncStep m k o)
asyncRun MachineT m k1 o1
x m (AsyncStep m k1 o1)
-> (AsyncStep m k1 o1 -> m (Step k o (MachineT m k o)))
-> m (Step k o (MachineT m k o))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MachineT m k o -> m (Step k o (MachineT m k o))
forall (m :: * -> *) (k :: * -> *) o.
MachineT m k o -> m (Step k o (MachineT m k o))
runMachineT (MachineT m k o -> m (Step k o (MachineT m k o)))
-> (AsyncStep m k1 o1 -> MachineT m k o)
-> AsyncStep m k1 o1
-> m (Step k o (MachineT m k o))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsyncStep m k1 o1 -> MachineT m k o
f

-- | Similar to 'awaitStep', but for continuations that want their inputs
-- to be run asynchronously.
asyncAwait :: MonadBaseControl IO m
           => (a -> MachineT m k o)
           -> k' a
           -> MachineT m k o
           -> (AsyncStep m k o -> MachineT m k1 o1)
           -> m (Step k' b (MachineT m k1 o1))
asyncAwait :: (a -> MachineT m k o)
-> k' a
-> MachineT m k o
-> (AsyncStep m k o -> MachineT m k1 o1)
-> m (Step k' b (MachineT m k1 o1))
asyncAwait a -> MachineT m k o
f k' a
sel MachineT m k o
ff = Step k' b (MachineT m k1 o1) -> m (Step k' b (MachineT m k1 o1))
forall (m :: * -> *) a. Monad m => a -> m a
return (Step k' b (MachineT m k1 o1) -> m (Step k' b (MachineT m k1 o1)))
-> ((AsyncStep m k o -> MachineT m k1 o1)
    -> Step k' b (MachineT m k1 o1))
-> (AsyncStep m k o -> MachineT m k1 o1)
-> m (Step k' b (MachineT m k1 o1))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> MachineT m k o)
-> k' a
-> MachineT m k o
-> (MachineT m k o -> MachineT m k1 o1)
-> Step k' b (MachineT m k1 o1)
forall a d (k' :: * -> *) r b.
(a -> d) -> k' a -> d -> (d -> r) -> Step k' b r
awaitStep a -> MachineT m k o
f k' a
sel MachineT m k o
ff ((MachineT m k o -> MachineT m k1 o1)
 -> Step k' b (MachineT m k1 o1))
-> ((AsyncStep m k o -> MachineT m k1 o1)
    -> MachineT m k o -> MachineT m k1 o1)
-> (AsyncStep m k o -> MachineT m k1 o1)
-> Step k' b (MachineT m k1 o1)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AsyncStep m k o -> MachineT m k1 o1)
-> MachineT m k o -> MachineT m k1 o1
forall (m :: * -> *) (k1 :: * -> *) o1 (k :: * -> *) o.
MonadBaseControl IO m =>
(AsyncStep m k1 o1 -> MachineT m k o)
-> MachineT m k1 o1 -> MachineT m k o
asyncEncased