{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}

-- | Asynchronicity implementation using 'MVar's and free monads.
module Control.Monad.Schedule.FreeAsync (
  -- * 'FreeAsyncT'
  FreeAsyncT (..),
  FreeAsync,
  freeAsync,
  asyncMVar,
  runFreeAsync,
  runFreeAsyncT,

  -- * Concurrent 'Applicative' interface
  ConcurrentlyT (..),
  Concurrently,
  concurrently,
  concurrentlyMVar,
  lift',
  runConcurrentlyT,
  runConcurrently,
)
where

-- base
import Control.Arrow (second, (>>>))
import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay, tryTakeMVar, yield)
import Control.Monad.IO.Class
import Data.Either (partitionEithers)
import Data.List.NonEmpty (NonEmpty (..), appendList, toList)

-- transformers
import Control.Monad.Trans.Class

-- operational
import Control.Monad.Operational (ProgramT, ProgramViewT (..), interpretWithMonadT, singleton, unviewT, viewT)

-- monad-schedule
import Control.Monad.Schedule.Class (MonadSchedule (..), apSchedule)

{- | An 'IO'-like monad with the capability of async/await-style futures.

Synchronous (blocking) computations in this monad can be created using 'lift' and 'liftIO'.
Asynchronous computations that can run in the background are created with 'freeAsync' or 'asyncMVar'.

To leverage the asynchronicity, you can schedule computations with 'MonadSchedule' operations such as 'schedule' or 'race'.

Caution: Composing computations with 'Applicative' or 'Monad' operations like '<*>', '>>=' and @do@-notation
will force all but the final computation in order:
When running @a '*>' b '*>' c@, @b@ will not be started before @a@ has completed.
To start all operations and run them concurrently, use e.g. 'Control.Monad.Schedule.Class.scheduleWith'.
To use an 'Applicative' interface for concurrency, have a look at 'ConcurrentlyT'.
-}
newtype FreeAsyncT m a = FreeAsyncT {forall (m :: * -> *) a. FreeAsyncT m a -> ProgramT MVar m a
getFreeAsyncT :: ProgramT MVar m a}
  deriving newtype ((forall a b. (a -> b) -> FreeAsyncT m a -> FreeAsyncT m b)
-> (forall a b. a -> FreeAsyncT m b -> FreeAsyncT m a)
-> Functor (FreeAsyncT m)
forall a b. a -> FreeAsyncT m b -> FreeAsyncT m a
forall a b. (a -> b) -> FreeAsyncT m a -> FreeAsyncT m b
forall (m :: * -> *) a b.
Monad m =>
a -> FreeAsyncT m b -> FreeAsyncT m a
forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> FreeAsyncT m a -> FreeAsyncT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> FreeAsyncT m a -> FreeAsyncT m b
fmap :: forall a b. (a -> b) -> FreeAsyncT m a -> FreeAsyncT m b
$c<$ :: forall (m :: * -> *) a b.
Monad m =>
a -> FreeAsyncT m b -> FreeAsyncT m a
<$ :: forall a b. a -> FreeAsyncT m b -> FreeAsyncT m a
Functor, Functor (FreeAsyncT m)
Functor (FreeAsyncT m) =>
(forall a. a -> FreeAsyncT m a)
-> (forall a b.
    FreeAsyncT m (a -> b) -> FreeAsyncT m a -> FreeAsyncT m b)
-> (forall a b c.
    (a -> b -> c)
    -> FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m c)
-> (forall a b. FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m b)
-> (forall a b. FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m a)
-> Applicative (FreeAsyncT m)
forall a. a -> FreeAsyncT m a
forall a b. FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m a
forall a b. FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m b
forall a b.
FreeAsyncT m (a -> b) -> FreeAsyncT m a -> FreeAsyncT m b
forall a b c.
(a -> b -> c) -> FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m c
forall (m :: * -> *). Monad m => Functor (FreeAsyncT m)
forall (m :: * -> *) a. Monad m => a -> FreeAsyncT m a
forall (m :: * -> *) a b.
Monad m =>
FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m a
forall (m :: * -> *) a b.
Monad m =>
FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m b
forall (m :: * -> *) a b.
Monad m =>
FreeAsyncT m (a -> b) -> FreeAsyncT m a -> FreeAsyncT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> FreeAsyncT m a
pure :: forall a. a -> FreeAsyncT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
FreeAsyncT m (a -> b) -> FreeAsyncT m a -> FreeAsyncT m b
<*> :: forall a b.
FreeAsyncT m (a -> b) -> FreeAsyncT m a -> FreeAsyncT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m c
liftA2 :: forall a b c.
(a -> b -> c) -> FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m b
*> :: forall a b. FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m a
<* :: forall a b. FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m a
Applicative, Applicative (FreeAsyncT m)
Applicative (FreeAsyncT m) =>
(forall a b.
 FreeAsyncT m a -> (a -> FreeAsyncT m b) -> FreeAsyncT m b)
-> (forall a b. FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m b)
-> (forall a. a -> FreeAsyncT m a)
-> Monad (FreeAsyncT m)
forall a. a -> FreeAsyncT m a
forall a b. FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m b
forall a b.
FreeAsyncT m a -> (a -> FreeAsyncT m b) -> FreeAsyncT m b
forall (m :: * -> *). Monad m => Applicative (FreeAsyncT m)
forall (m :: * -> *) a. Monad m => a -> FreeAsyncT m a
forall (m :: * -> *) a b.
Monad m =>
FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m b
forall (m :: * -> *) a b.
Monad m =>
FreeAsyncT m a -> (a -> FreeAsyncT m b) -> FreeAsyncT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
FreeAsyncT m a -> (a -> FreeAsyncT m b) -> FreeAsyncT m b
>>= :: forall a b.
FreeAsyncT m a -> (a -> FreeAsyncT m b) -> FreeAsyncT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m b
>> :: forall a b. FreeAsyncT m a -> FreeAsyncT m b -> FreeAsyncT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> FreeAsyncT m a
return :: forall a. a -> FreeAsyncT m a
Monad, (forall (m :: * -> *). Monad m => Monad (FreeAsyncT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a)
-> MonadTrans FreeAsyncT
forall (m :: * -> *). Monad m => Monad (FreeAsyncT m)
forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a
MonadTrans)

type FreeAsync = FreeAsyncT IO

-- FIXME MFunctor & MMonad instances pending https://github.com/HeinrichApfelmus/operational/pull/28/

-- | Lifts into 'FreeAsyncT' /without/ concurrency. See 'freeAsync'.
instance (MonadIO m) => MonadIO (FreeAsyncT m) where
  liftIO :: forall a. IO a -> FreeAsyncT m a
liftIO = m a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> FreeAsyncT m a) -> (IO a -> m a) -> IO a -> FreeAsyncT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

{- | Run an 'IO' computation in the background.

This returns a "promise", or "future", which completes the computation when run.
-}
freeAsync :: (MonadIO m) => IO a -> FreeAsyncT m a
freeAsync :: forall (m :: * -> *) a. MonadIO m => IO a -> FreeAsyncT m a
freeAsync IO a
action = ProgramT MVar m a -> FreeAsyncT m a
forall (m :: * -> *) a. ProgramT MVar m a -> FreeAsyncT m a
FreeAsyncT (ProgramT MVar m a -> FreeAsyncT m a)
-> ProgramT MVar m a -> FreeAsyncT m a
forall a b. (a -> b) -> a -> b
$ do
  MVar a
var <- IO (MVar a) -> ProgramT MVar m (MVar a)
forall a. IO a -> ProgramT MVar m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
  IO ThreadId -> ProgramT MVar m ThreadId
forall a. IO a -> ProgramT MVar m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> ProgramT MVar m ThreadId)
-> IO ThreadId -> ProgramT MVar m ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
var (a -> IO ()) -> IO a -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
action
  MVar a -> ProgramT MVar m a
forall (instr :: * -> *) a (m :: * -> *).
instr a -> ProgramT instr m a
singleton MVar a
var

-- | Complete all computations and remove the 'FreeAsyncT' layer.
runFreeAsyncT :: (MonadIO m) => FreeAsyncT m a -> m a
runFreeAsyncT :: forall (m :: * -> *) a. MonadIO m => FreeAsyncT m a -> m a
runFreeAsyncT = (forall x. MVar x -> m x) -> ProgramT MVar m a -> m a
forall (m :: * -> *) (instr :: * -> *) a.
Monad m =>
(forall x. instr x -> m x) -> ProgramT instr m a -> m a
interpretWithMonadT (IO x -> m x
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO x -> m x) -> (MVar x -> IO x) -> MVar x -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar x -> IO x
forall a. MVar a -> IO a
takeMVar) (ProgramT MVar m a -> m a)
-> (FreeAsyncT m a -> ProgramT MVar m a) -> FreeAsyncT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeAsyncT m a -> ProgramT MVar m a
forall (m :: * -> *) a. FreeAsyncT m a -> ProgramT MVar m a
getFreeAsyncT

-- | Like 'runFreeAsyncT', but specialized to 'IO'.
runFreeAsync :: FreeAsync a -> IO a
runFreeAsync :: forall a. FreeAsync a -> IO a
runFreeAsync = FreeAsyncT IO a -> IO a
forall (m :: * -> *) a. MonadIO m => FreeAsyncT m a -> m a
runFreeAsyncT

{- | Asynchronously await an 'MVar'.

@'asyncMVar' var@ will attempt 'takeMVar' in a way that can be 'schedule'd concurrently with other 'asyncMVar's or 'freeAsync's.
-}
asyncMVar :: MVar a -> FreeAsyncT m a
asyncMVar :: forall a (m :: * -> *). MVar a -> FreeAsyncT m a
asyncMVar = ProgramT MVar m a -> FreeAsyncT m a
forall (m :: * -> *) a. ProgramT MVar m a -> FreeAsyncT m a
FreeAsyncT (ProgramT MVar m a -> FreeAsyncT m a)
-> (MVar a -> ProgramT MVar m a) -> MVar a -> FreeAsyncT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> ProgramT MVar m a
forall (instr :: * -> *) a (m :: * -> *).
instr a -> ProgramT instr m a
singleton

data MVarCont m a = forall b.
  MVarCont
  { ()
mvar :: MVar b
  , ()
cont :: b -> ProgramT MVar m a
  }

embedMVarCont :: (Monad m) => MVarCont m a -> FreeAsyncT m a
embedMVarCont :: forall (m :: * -> *) a. Monad m => MVarCont m a -> FreeAsyncT m a
embedMVarCont MVarCont {MVar b
mvar :: ()
mvar :: MVar b
mvar, b -> ProgramT MVar m a
cont :: ()
cont :: b -> ProgramT MVar m a
cont} = ProgramT MVar m a -> FreeAsyncT m a
forall (m :: * -> *) a. ProgramT MVar m a -> FreeAsyncT m a
FreeAsyncT (ProgramT MVar m a -> FreeAsyncT m a)
-> ProgramT MVar m a -> FreeAsyncT m a
forall a b. (a -> b) -> a -> b
$ ProgramViewT MVar m a -> ProgramT MVar m a
forall (m :: * -> *) (instr :: * -> *) a.
Monad m =>
ProgramViewT instr m a -> ProgramT instr m a
unviewT (ProgramViewT MVar m a -> ProgramT MVar m a)
-> ProgramViewT MVar m a -> ProgramT MVar m a
forall a b. (a -> b) -> a -> b
$ MVar b
mvar MVar b -> (b -> ProgramT MVar m a) -> ProgramViewT MVar m a
forall (instr :: * -> *) b (m :: * -> *) a.
instr b -> (b -> ProgramT instr m a) -> ProgramViewT instr m a
:>>= b -> ProgramT MVar m a
cont

{- | Concurrently wait for the completion of 'IO' actions.
Has a slight runtime overhead over the direct @'MonadSchedule' 'IO'@ instance, but better fairness.
-}
instance (MonadIO m) => MonadSchedule (FreeAsyncT m) where
  schedule :: forall a.
NonEmpty (FreeAsyncT m a)
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
schedule NonEmpty (FreeAsyncT m a)
actions = NonEmpty (ProgramT MVar m a)
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
forall (m :: * -> *) a.
MonadIO m =>
NonEmpty (ProgramT MVar m a)
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
retryForever (NonEmpty (ProgramT MVar m a)
 -> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a]))
-> NonEmpty (ProgramT MVar m a)
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
forall a b. (a -> b) -> a -> b
$ FreeAsyncT m a -> ProgramT MVar m a
forall (m :: * -> *) a. FreeAsyncT m a -> ProgramT MVar m a
getFreeAsyncT (FreeAsyncT m a -> ProgramT MVar m a)
-> NonEmpty (FreeAsyncT m a) -> NonEmpty (ProgramT MVar m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (FreeAsyncT m a)
actions
    where
      retryForever :: (MonadIO m) => NonEmpty (ProgramT MVar m a) -> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
      retryForever :: forall (m :: * -> *) a.
MonadIO m =>
NonEmpty (ProgramT MVar m a)
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
retryForever NonEmpty (ProgramT MVar m a)
actions = do
        -- Look at all actions
        NonEmpty (ProgramViewT MVar m a)
views <- m (NonEmpty (ProgramViewT MVar m a))
-> FreeAsyncT m (NonEmpty (ProgramViewT MVar m a))
forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((ProgramT MVar m a -> m (ProgramViewT MVar m a))
-> NonEmpty (ProgramT MVar m a)
-> m (NonEmpty (ProgramViewT MVar m a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM ProgramT MVar m a -> m (ProgramViewT MVar m a)
forall (m :: * -> *) (instr :: * -> *) a.
Monad m =>
ProgramT instr m a -> m (ProgramViewT instr m a)
viewT NonEmpty (ProgramT MVar m a)
actions)
        -- Have some of them finished?
        case NonEmpty (Either a (MVarCont m a))
-> Either (NonEmpty a, [MVarCont m a]) (NonEmpty (MVarCont m a))
forall a b.
NonEmpty (Either a b) -> Either (NonEmpty a, [b]) (NonEmpty b)
partitionNonEmpty (NonEmpty (Either a (MVarCont m a))
 -> Either (NonEmpty a, [MVarCont m a]) (NonEmpty (MVarCont m a)))
-> NonEmpty (Either a (MVarCont m a))
-> Either (NonEmpty a, [MVarCont m a]) (NonEmpty (MVarCont m a))
forall a b. (a -> b) -> a -> b
$ ProgramViewT MVar m a -> Either a (MVarCont m a)
forall (m :: * -> *) a.
ProgramViewT MVar m a -> Either a (MVarCont m a)
viewToEither (ProgramViewT MVar m a -> Either a (MVarCont m a))
-> NonEmpty (ProgramViewT MVar m a)
-> NonEmpty (Either a (MVarCont m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ProgramViewT MVar m a)
views of
          -- All have finished
          Left (NonEmpty a
as, []) -> (NonEmpty a, [FreeAsyncT m a])
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
forall a. a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty a
as, [])
          -- Some have finished, some are waiting for MVars
          Left (NonEmpty a
as, MVarCont m a
cont : [MVarCont m a]
conts) -> do
            -- Peek at the MVars
            Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
progressed <- m (Either
     (NonEmpty (ProgramT MVar m a), [MVarCont m a])
     (NonEmpty (MVarCont m a)))
-> FreeAsyncT
     m
     (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either
      (NonEmpty (ProgramT MVar m a), [MVarCont m a])
      (NonEmpty (MVarCont m a)))
 -> FreeAsyncT
      m
      (Either
         (NonEmpty (ProgramT MVar m a), [MVarCont m a])
         (NonEmpty (MVarCont m a))))
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
-> FreeAsyncT
     m
     (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a b. (a -> b) -> a -> b
$ NonEmpty (MVarCont m a)
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall (m :: * -> *) a.
MonadIO m =>
NonEmpty (MVarCont m a)
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
tryProgresses (NonEmpty (MVarCont m a)
 -> m (Either
         (NonEmpty (ProgramT MVar m a), [MVarCont m a])
         (NonEmpty (MVarCont m a))))
-> NonEmpty (MVarCont m a)
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a b. (a -> b) -> a -> b
$ MVarCont m a
cont MVarCont m a -> [MVarCont m a] -> NonEmpty (MVarCont m a)
forall a. a -> [a] -> NonEmpty a
:| [MVarCont m a]
conts
            -- Are some MVars present already?
            case Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
progressed of
              -- Yes, some were present, step the corresponding actions
              Left (NonEmpty (ProgramT MVar m a)
actions, [MVarCont m a]
conts) -> do
                -- Look at the progressed actions
                NonEmpty (ProgramViewT MVar m a)
views <- m (NonEmpty (ProgramViewT MVar m a))
-> FreeAsyncT m (NonEmpty (ProgramViewT MVar m a))
forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((ProgramT MVar m a -> m (ProgramViewT MVar m a))
-> NonEmpty (ProgramT MVar m a)
-> m (NonEmpty (ProgramViewT MVar m a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM ProgramT MVar m a -> m (ProgramViewT MVar m a)
forall (m :: * -> *) (instr :: * -> *) a.
Monad m =>
ProgramT instr m a -> m (ProgramViewT instr m a)
viewT NonEmpty (ProgramT MVar m a)
actions)
                -- Have some of them returned now?
                case NonEmpty (Either a (MVarCont m a))
-> Either (NonEmpty a, [MVarCont m a]) (NonEmpty (MVarCont m a))
forall a b.
NonEmpty (Either a b) -> Either (NonEmpty a, [b]) (NonEmpty b)
partitionNonEmpty (NonEmpty (Either a (MVarCont m a))
 -> Either (NonEmpty a, [MVarCont m a]) (NonEmpty (MVarCont m a)))
-> NonEmpty (Either a (MVarCont m a))
-> Either (NonEmpty a, [MVarCont m a]) (NonEmpty (MVarCont m a))
forall a b. (a -> b) -> a -> b
$ ProgramViewT MVar m a -> Either a (MVarCont m a)
forall (m :: * -> *) a.
ProgramViewT MVar m a -> Either a (MVarCont m a)
viewToEither (ProgramViewT MVar m a -> Either a (MVarCont m a))
-> NonEmpty (ProgramViewT MVar m a)
-> NonEmpty (Either a (MVarCont m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ProgramViewT MVar m a)
views of
                  -- Yes. Return those as well
                  Left (NonEmpty a
as', [MVarCont m a]
conts') -> (NonEmpty a, [FreeAsyncT m a])
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
forall a. a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty a
as NonEmpty a -> NonEmpty a -> NonEmpty a
forall a. Semigroup a => a -> a -> a
<> NonEmpty a
as', MVarCont m a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => MVarCont m a -> FreeAsyncT m a
embedMVarCont (MVarCont m a -> FreeAsyncT m a)
-> [MVarCont m a] -> [FreeAsyncT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([MVarCont m a]
conts [MVarCont m a] -> [MVarCont m a] -> [MVarCont m a]
forall a. [a] -> [a] -> [a]
++ [MVarCont m a]
conts'))
                  -- No, they are blocked on other MVars now
                  Right NonEmpty (MVarCont m a)
conts' -> (NonEmpty a, [FreeAsyncT m a])
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
forall a. a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty a
as, MVarCont m a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => MVarCont m a -> FreeAsyncT m a
embedMVarCont (MVarCont m a -> FreeAsyncT m a)
-> [MVarCont m a] -> [FreeAsyncT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (MVarCont m a) -> [MVarCont m a]
forall a. NonEmpty a -> [a]
toList NonEmpty (MVarCont m a)
conts' [MVarCont m a] -> [MVarCont m a] -> [MVarCont m a]
forall a. Semigroup a => a -> a -> a
<> [MVarCont m a]
conts)
              -- All MVars are still blocked
              Right NonEmpty (MVarCont m a)
conts -> (NonEmpty a, [FreeAsyncT m a])
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
forall a. a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty a
as, MVarCont m a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => MVarCont m a -> FreeAsyncT m a
embedMVarCont (MVarCont m a -> FreeAsyncT m a)
-> [MVarCont m a] -> [FreeAsyncT m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (MVarCont m a) -> [MVarCont m a]
forall a. NonEmpty a -> [a]
toList NonEmpty (MVarCont m a)
conts)
          -- All actions are waiting for MVars
          Right NonEmpty (MVarCont m a)
conts -> do
            -- Retry until some MVars get unblocked
            (NonEmpty (ProgramT MVar m a)
progressed, [MVarCont m a]
conts) <- m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
-> FreeAsyncT m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
 -> FreeAsyncT m (NonEmpty (ProgramT MVar m a), [MVarCont m a]))
-> m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
-> FreeAsyncT m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
forall a b. (a -> b) -> a -> b
$ NonEmpty (MVarCont m a)
-> m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
forall (m :: * -> *) a.
MonadIO m =>
NonEmpty (MVarCont m a)
-> m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
retryProgresses NonEmpty (MVarCont m a)
conts
            -- Some MVars are unblocked, start over.
            NonEmpty (ProgramT MVar m a)
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
forall (m :: * -> *) a.
MonadIO m =>
NonEmpty (ProgramT MVar m a)
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
retryForever (NonEmpty (ProgramT MVar m a)
 -> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a]))
-> NonEmpty (ProgramT MVar m a)
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
forall a b. (a -> b) -> a -> b
$ NonEmpty (ProgramT MVar m a)
-> [ProgramT MVar m a] -> NonEmpty (ProgramT MVar m a)
forall a. NonEmpty a -> [a] -> NonEmpty a
appendList NonEmpty (ProgramT MVar m a)
progressed ([ProgramT MVar m a] -> NonEmpty (ProgramT MVar m a))
-> [ProgramT MVar m a] -> NonEmpty (ProgramT MVar m a)
forall a b. (a -> b) -> a -> b
$ FreeAsyncT m a -> ProgramT MVar m a
forall (m :: * -> *) a. FreeAsyncT m a -> ProgramT MVar m a
getFreeAsyncT (FreeAsyncT m a -> ProgramT MVar m a)
-> (MVarCont m a -> FreeAsyncT m a)
-> MVarCont m a
-> ProgramT MVar m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVarCont m a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => MVarCont m a -> FreeAsyncT m a
embedMVarCont (MVarCont m a -> ProgramT MVar m a)
-> [MVarCont m a] -> [ProgramT MVar m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MVarCont m a]
conts

      viewToEither :: ProgramViewT MVar m a -> Either a (MVarCont m a)
      viewToEither :: forall (m :: * -> *) a.
ProgramViewT MVar m a -> Either a (MVarCont m a)
viewToEither (Return a
a) = a -> Either a (MVarCont m a)
forall a b. a -> Either a b
Left a
a
      viewToEither (MVar b
mvar :>>= b -> ProgramT MVar m a
cont) = MVarCont m a -> Either a (MVarCont m a)
forall a b. b -> Either a b
Right MVarCont {MVar b
mvar :: MVar b
mvar :: MVar b
mvar, b -> ProgramT MVar m a
cont :: b -> ProgramT MVar m a
cont :: b -> ProgramT MVar m a
cont}

      partitionNonEmpty :: NonEmpty (Either a b) -> Either (NonEmpty a, [b]) (NonEmpty b)
      partitionNonEmpty :: forall a b.
NonEmpty (Either a b) -> Either (NonEmpty a, [b]) (NonEmpty b)
partitionNonEmpty (Left a
a :| [Either a b]
abs) = let ([a]
as, [b]
bs) = [Either a b] -> ([a], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either a b]
abs in (NonEmpty a, [b]) -> Either (NonEmpty a, [b]) (NonEmpty b)
forall a b. a -> Either a b
Left (a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
as, [b]
bs)
      partitionNonEmpty (Right b
b :| [Either a b]
abs) = case [Either a b] -> ([a], [b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either a b]
abs of
        ([], [b]
bs) -> NonEmpty b -> Either (NonEmpty a, [b]) (NonEmpty b)
forall a b. b -> Either a b
Right (NonEmpty b -> Either (NonEmpty a, [b]) (NonEmpty b))
-> NonEmpty b -> Either (NonEmpty a, [b]) (NonEmpty b)
forall a b. (a -> b) -> a -> b
$ b
b b -> [b] -> NonEmpty b
forall a. a -> [a] -> NonEmpty a
:| [b]
bs
        (a
a : [a]
as, [b]
bs) -> (NonEmpty a, [b]) -> Either (NonEmpty a, [b]) (NonEmpty b)
forall a b. a -> Either a b
Left (a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
as, b
b b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
bs)

      tryProgress :: (MonadIO m) => MVarCont m a -> m (Either (ProgramT MVar m a) (MVarCont m a))
      tryProgress :: forall (m :: * -> *) a.
MonadIO m =>
MVarCont m a -> m (Either (ProgramT MVar m a) (MVarCont m a))
tryProgress mvarcont :: MVarCont m a
mvarcont@MVarCont {MVar b
mvar :: ()
mvar :: MVar b
mvar, b -> ProgramT MVar m a
cont :: ()
cont :: b -> ProgramT MVar m a
cont} = do
        Maybe b
result <- IO (Maybe b) -> m (Maybe b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe b) -> m (Maybe b)) -> IO (Maybe b) -> m (Maybe b)
forall a b. (a -> b) -> a -> b
$ MVar b -> IO (Maybe b)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar b
mvar
        Either (ProgramT MVar m a) (MVarCont m a)
-> m (Either (ProgramT MVar m a) (MVarCont m a))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ProgramT MVar m a) (MVarCont m a)
 -> m (Either (ProgramT MVar m a) (MVarCont m a)))
-> Either (ProgramT MVar m a) (MVarCont m a)
-> m (Either (ProgramT MVar m a) (MVarCont m a))
forall a b. (a -> b) -> a -> b
$ Either (ProgramT MVar m a) (MVarCont m a)
-> (b -> Either (ProgramT MVar m a) (MVarCont m a))
-> Maybe b
-> Either (ProgramT MVar m a) (MVarCont m a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MVarCont m a -> Either (ProgramT MVar m a) (MVarCont m a)
forall a b. b -> Either a b
Right MVarCont m a
mvarcont) (ProgramT MVar m a -> Either (ProgramT MVar m a) (MVarCont m a)
forall a b. a -> Either a b
Left (ProgramT MVar m a -> Either (ProgramT MVar m a) (MVarCont m a))
-> (b -> ProgramT MVar m a)
-> b
-> Either (ProgramT MVar m a) (MVarCont m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> ProgramT MVar m a
cont) Maybe b
result

      tryProgresses :: (MonadIO m) => NonEmpty (MVarCont m a) -> m (Either (NonEmpty (ProgramT MVar m a), [MVarCont m a]) (NonEmpty (MVarCont m a)))
      tryProgresses :: forall (m :: * -> *) a.
MonadIO m =>
NonEmpty (MVarCont m a)
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
tryProgresses NonEmpty (MVarCont m a)
conts = do
        Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
result <- NonEmpty (Either (ProgramT MVar m a) (MVarCont m a))
-> Either
     (NonEmpty (ProgramT MVar m a), [MVarCont m a])
     (NonEmpty (MVarCont m a))
forall a b.
NonEmpty (Either a b) -> Either (NonEmpty a, [b]) (NonEmpty b)
partitionNonEmpty (NonEmpty (Either (ProgramT MVar m a) (MVarCont m a))
 -> Either
      (NonEmpty (ProgramT MVar m a), [MVarCont m a])
      (NonEmpty (MVarCont m a)))
-> m (NonEmpty (Either (ProgramT MVar m a) (MVarCont m a)))
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MVarCont m a -> m (Either (ProgramT MVar m a) (MVarCont m a)))
-> NonEmpty (MVarCont m a)
-> m (NonEmpty (Either (ProgramT MVar m a) (MVarCont m a)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM MVarCont m a -> m (Either (ProgramT MVar m a) (MVarCont m a))
forall (m :: * -> *) a.
MonadIO m =>
MVarCont m a -> m (Either (ProgramT MVar m a) (MVarCont m a))
tryProgress NonEmpty (MVarCont m a)
conts
        case Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
result of
          Left (NonEmpty (ProgramT MVar m a)
progressed, []) -> Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (NonEmpty (ProgramT MVar m a), [MVarCont m a])
   (NonEmpty (MVarCont m a))
 -> m (Either
         (NonEmpty (ProgramT MVar m a), [MVarCont m a])
         (NonEmpty (MVarCont m a))))
-> Either
     (NonEmpty (ProgramT MVar m a), [MVarCont m a])
     (NonEmpty (MVarCont m a))
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a b. (a -> b) -> a -> b
$ (NonEmpty (ProgramT MVar m a), [MVarCont m a])
-> Either
     (NonEmpty (ProgramT MVar m a), [MVarCont m a])
     (NonEmpty (MVarCont m a))
forall a b. a -> Either a b
Left (NonEmpty (ProgramT MVar m a)
progressed, [])
          Left (NonEmpty (ProgramT MVar m a)
progressed, MVarCont m a
cont : [MVarCont m a]
conts) -> do
            Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
inner <- NonEmpty (MVarCont m a)
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall (m :: * -> *) a.
MonadIO m =>
NonEmpty (MVarCont m a)
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
tryProgresses (NonEmpty (MVarCont m a)
 -> m (Either
         (NonEmpty (ProgramT MVar m a), [MVarCont m a])
         (NonEmpty (MVarCont m a))))
-> NonEmpty (MVarCont m a)
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a b. (a -> b) -> a -> b
$ MVarCont m a
cont MVarCont m a -> [MVarCont m a] -> NonEmpty (MVarCont m a)
forall a. a -> [a] -> NonEmpty a
:| [MVarCont m a]
conts
            case Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
inner of
              Left (NonEmpty (ProgramT MVar m a)
progressed', [MVarCont m a]
finalConts) -> Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (NonEmpty (ProgramT MVar m a), [MVarCont m a])
   (NonEmpty (MVarCont m a))
 -> m (Either
         (NonEmpty (ProgramT MVar m a), [MVarCont m a])
         (NonEmpty (MVarCont m a))))
-> Either
     (NonEmpty (ProgramT MVar m a), [MVarCont m a])
     (NonEmpty (MVarCont m a))
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a b. (a -> b) -> a -> b
$ (NonEmpty (ProgramT MVar m a), [MVarCont m a])
-> Either
     (NonEmpty (ProgramT MVar m a), [MVarCont m a])
     (NonEmpty (MVarCont m a))
forall a b. a -> Either a b
Left (NonEmpty (ProgramT MVar m a)
progressed NonEmpty (ProgramT MVar m a)
-> NonEmpty (ProgramT MVar m a) -> NonEmpty (ProgramT MVar m a)
forall a. Semigroup a => a -> a -> a
<> NonEmpty (ProgramT MVar m a)
progressed', [MVarCont m a]
finalConts)
              Right NonEmpty (MVarCont m a)
finalConts -> Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (NonEmpty (ProgramT MVar m a), [MVarCont m a])
   (NonEmpty (MVarCont m a))
 -> m (Either
         (NonEmpty (ProgramT MVar m a), [MVarCont m a])
         (NonEmpty (MVarCont m a))))
-> Either
     (NonEmpty (ProgramT MVar m a), [MVarCont m a])
     (NonEmpty (MVarCont m a))
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a b. (a -> b) -> a -> b
$ (NonEmpty (ProgramT MVar m a), [MVarCont m a])
-> Either
     (NonEmpty (ProgramT MVar m a), [MVarCont m a])
     (NonEmpty (MVarCont m a))
forall a b. a -> Either a b
Left (NonEmpty (ProgramT MVar m a)
progressed, NonEmpty (MVarCont m a) -> [MVarCont m a]
forall a. NonEmpty a -> [a]
toList NonEmpty (MVarCont m a)
finalConts)
          Right NonEmpty (MVarCont m a)
conts -> Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (NonEmpty (ProgramT MVar m a), [MVarCont m a])
   (NonEmpty (MVarCont m a))
 -> m (Either
         (NonEmpty (ProgramT MVar m a), [MVarCont m a])
         (NonEmpty (MVarCont m a))))
-> Either
     (NonEmpty (ProgramT MVar m a), [MVarCont m a])
     (NonEmpty (MVarCont m a))
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall a b. (a -> b) -> a -> b
$ NonEmpty (MVarCont m a)
-> Either
     (NonEmpty (ProgramT MVar m a), [MVarCont m a])
     (NonEmpty (MVarCont m a))
forall a b. b -> Either a b
Right NonEmpty (MVarCont m a)
conts

      retryProgresses :: (MonadIO m) => NonEmpty (MVarCont m a) -> m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
      retryProgresses :: forall (m :: * -> *) a.
MonadIO m =>
NonEmpty (MVarCont m a)
-> m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
retryProgresses NonEmpty (MVarCont m a)
conts = do
        Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
result <- NonEmpty (MVarCont m a)
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
forall (m :: * -> *) a.
MonadIO m =>
NonEmpty (MVarCont m a)
-> m (Either
        (NonEmpty (ProgramT MVar m a), [MVarCont m a])
        (NonEmpty (MVarCont m a)))
tryProgresses NonEmpty (MVarCont m a)
conts
        case Either
  (NonEmpty (ProgramT MVar m a), [MVarCont m a])
  (NonEmpty (MVarCont m a))
result of
          Left (NonEmpty (ProgramT MVar m a), [MVarCont m a])
progress -> (NonEmpty (ProgramT MVar m a), [MVarCont m a])
-> m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty (ProgramT MVar m a), [MVarCont m a])
progress
          Right NonEmpty (MVarCont m a)
_ -> do
            IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO ()
yield IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
threadDelay Int
100
            NonEmpty (MVarCont m a)
-> m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
forall (m :: * -> *) a.
MonadIO m =>
NonEmpty (MVarCont m a)
-> m (NonEmpty (ProgramT MVar m a), [MVarCont m a])
retryProgresses NonEmpty (MVarCont m a)
conts

{- | Like 'FreeAsyncT', but leverages concurrency in the 'Applicative' interface.

The central difference to 'FreeAsyncT' is the 'Applicative' instance:
@concurrently a *> concurrently b *> concurrently c@ will launch all three actions immediately
and return when all actions have completed.
On the other hand, @concurrently a >>= f@ has to compute sequentially.

For more readable syntax, it can be useful to switch the @ApplicativeDo@ extension on.

The downside of this 'Applicative' instance is that 'ConcurrentlyT' can't be an instance of 'MonadTrans'.
As a drop-in replacement, the function 'lift'' is supplied.

Caution: To lift an 'IO' action concurrently, you need to use 'concurrently' and not 'liftIO'.
-}
newtype ConcurrentlyT m a = ConcurrentlyT {forall (m :: * -> *) a. ConcurrentlyT m a -> FreeAsyncT m a
getConcurrentlyT :: FreeAsyncT m a}
  deriving newtype ((forall a b. (a -> b) -> ConcurrentlyT m a -> ConcurrentlyT m b)
-> (forall a b. a -> ConcurrentlyT m b -> ConcurrentlyT m a)
-> Functor (ConcurrentlyT m)
forall a b. a -> ConcurrentlyT m b -> ConcurrentlyT m a
forall a b. (a -> b) -> ConcurrentlyT m a -> ConcurrentlyT m b
forall (m :: * -> *) a b.
Monad m =>
a -> ConcurrentlyT m b -> ConcurrentlyT m a
forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> ConcurrentlyT m a -> ConcurrentlyT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Monad m =>
(a -> b) -> ConcurrentlyT m a -> ConcurrentlyT m b
fmap :: forall a b. (a -> b) -> ConcurrentlyT m a -> ConcurrentlyT m b
$c<$ :: forall (m :: * -> *) a b.
Monad m =>
a -> ConcurrentlyT m b -> ConcurrentlyT m a
<$ :: forall a b. a -> ConcurrentlyT m b -> ConcurrentlyT m a
Functor, Applicative (ConcurrentlyT m)
Applicative (ConcurrentlyT m) =>
(forall a b.
 ConcurrentlyT m a -> (a -> ConcurrentlyT m b) -> ConcurrentlyT m b)
-> (forall a b.
    ConcurrentlyT m a -> ConcurrentlyT m b -> ConcurrentlyT m b)
-> (forall a. a -> ConcurrentlyT m a)
-> Monad (ConcurrentlyT m)
forall a. a -> ConcurrentlyT m a
forall a b.
ConcurrentlyT m a -> ConcurrentlyT m b -> ConcurrentlyT m b
forall a b.
ConcurrentlyT m a -> (a -> ConcurrentlyT m b) -> ConcurrentlyT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (m :: * -> *). MonadIO m => Applicative (ConcurrentlyT m)
forall (m :: * -> *) a. MonadIO m => a -> ConcurrentlyT m a
forall (m :: * -> *) a b.
MonadIO m =>
ConcurrentlyT m a -> ConcurrentlyT m b -> ConcurrentlyT m b
forall (m :: * -> *) a b.
MonadIO m =>
ConcurrentlyT m a -> (a -> ConcurrentlyT m b) -> ConcurrentlyT m b
$c>>= :: forall (m :: * -> *) a b.
MonadIO m =>
ConcurrentlyT m a -> (a -> ConcurrentlyT m b) -> ConcurrentlyT m b
>>= :: forall a b.
ConcurrentlyT m a -> (a -> ConcurrentlyT m b) -> ConcurrentlyT m b
$c>> :: forall (m :: * -> *) a b.
MonadIO m =>
ConcurrentlyT m a -> ConcurrentlyT m b -> ConcurrentlyT m b
>> :: forall a b.
ConcurrentlyT m a -> ConcurrentlyT m b -> ConcurrentlyT m b
$creturn :: forall (m :: * -> *) a. MonadIO m => a -> ConcurrentlyT m a
return :: forall a. a -> ConcurrentlyT m a
Monad, Monad (ConcurrentlyT m)
Monad (ConcurrentlyT m) =>
(forall a. IO a -> ConcurrentlyT m a) -> MonadIO (ConcurrentlyT m)
forall a. IO a -> ConcurrentlyT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (ConcurrentlyT m)
forall (m :: * -> *) a. MonadIO m => IO a -> ConcurrentlyT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> ConcurrentlyT m a
liftIO :: forall a. IO a -> ConcurrentlyT m a
MonadIO)

type Concurrently = ConcurrentlyT IO

{- | Lift an 'IO' action such that it can be run concurrently.

See 'freeAsync'.
-}
concurrently :: (MonadIO m) => IO a -> ConcurrentlyT m a
concurrently :: forall (m :: * -> *) a. MonadIO m => IO a -> ConcurrentlyT m a
concurrently = FreeAsyncT m a -> ConcurrentlyT m a
forall (m :: * -> *) a. FreeAsyncT m a -> ConcurrentlyT m a
ConcurrentlyT (FreeAsyncT m a -> ConcurrentlyT m a)
-> (IO a -> FreeAsyncT m a) -> IO a -> ConcurrentlyT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> FreeAsyncT m a
forall (m :: * -> *) a. MonadIO m => IO a -> FreeAsyncT m a
freeAsync

-- | Like 'asyncMVar'
concurrentlyMVar :: MVar a -> ConcurrentlyT m a
concurrentlyMVar :: forall a (m :: * -> *). MVar a -> ConcurrentlyT m a
concurrentlyMVar = FreeAsyncT m a -> ConcurrentlyT m a
forall (m :: * -> *) a. FreeAsyncT m a -> ConcurrentlyT m a
ConcurrentlyT (FreeAsyncT m a -> ConcurrentlyT m a)
-> (MVar a -> FreeAsyncT m a) -> MVar a -> ConcurrentlyT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> FreeAsyncT m a
forall a (m :: * -> *). MVar a -> FreeAsyncT m a
asyncMVar

{- | Lift a computation to 'ConcurrentlyT'.

This replaces the missing 'MonadTrans' instance.

Caution: Computations lifted with this function cannot be scheduled concurrently!
If this is your intention, 'concurrently' needs to be used instead.
-}
lift' :: (Monad m) => m a -> ConcurrentlyT m a
lift' :: forall (m :: * -> *) a. Monad m => m a -> ConcurrentlyT m a
lift' = FreeAsyncT m a -> ConcurrentlyT m a
forall (m :: * -> *) a. FreeAsyncT m a -> ConcurrentlyT m a
ConcurrentlyT (FreeAsyncT m a -> ConcurrentlyT m a)
-> (m a -> FreeAsyncT m a) -> m a -> ConcurrentlyT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> FreeAsyncT m a
forall (m :: * -> *) a. Monad m => m a -> FreeAsyncT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Run a 'ConcurrentlyT' computation to completion, removing the newtype layers.
runConcurrentlyT :: (MonadIO m) => ConcurrentlyT m a -> m a
runConcurrentlyT :: forall (m :: * -> *) a. MonadIO m => ConcurrentlyT m a -> m a
runConcurrentlyT = FreeAsyncT m a -> m a
forall (m :: * -> *) a. MonadIO m => FreeAsyncT m a -> m a
runFreeAsyncT (FreeAsyncT m a -> m a)
-> (ConcurrentlyT m a -> FreeAsyncT m a)
-> ConcurrentlyT m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConcurrentlyT m a -> FreeAsyncT m a
forall (m :: * -> *) a. ConcurrentlyT m a -> FreeAsyncT m a
getConcurrentlyT

-- | Like 'runConcurrently', but specialised to 'IO'.
runConcurrently :: Concurrently a -> IO a
runConcurrently :: forall a. Concurrently a -> IO a
runConcurrently = ConcurrentlyT IO a -> IO a
forall (m :: * -> *) a. MonadIO m => ConcurrentlyT m a -> m a
runConcurrentlyT

instance (MonadIO m) => Applicative (ConcurrentlyT m) where
  pure :: forall a. a -> ConcurrentlyT m a
pure = FreeAsyncT m a -> ConcurrentlyT m a
forall (m :: * -> *) a. FreeAsyncT m a -> ConcurrentlyT m a
ConcurrentlyT (FreeAsyncT m a -> ConcurrentlyT m a)
-> (a -> FreeAsyncT m a) -> a -> ConcurrentlyT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FreeAsyncT m a
forall a. a -> FreeAsyncT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  <*> :: forall a b.
ConcurrentlyT m (a -> b) -> ConcurrentlyT m a -> ConcurrentlyT m b
(<*>) = ConcurrentlyT m (a -> b) -> ConcurrentlyT m a -> ConcurrentlyT m b
forall (m :: * -> *) a b.
(MonadSchedule m, Monad m) =>
m (a -> b) -> m a -> m b
apSchedule

-- | Like 'FreeAsyncT', but executes actions composed via the 'Applicative' interface concurrently.
instance (MonadIO m) => MonadSchedule (ConcurrentlyT m) where
  schedule :: forall a.
NonEmpty (ConcurrentlyT m a)
-> ConcurrentlyT m (NonEmpty a, [ConcurrentlyT m a])
schedule =
    (ConcurrentlyT m a -> FreeAsyncT m a)
-> NonEmpty (ConcurrentlyT m a) -> NonEmpty (FreeAsyncT m a)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConcurrentlyT m a -> FreeAsyncT m a
forall (m :: * -> *) a. ConcurrentlyT m a -> FreeAsyncT m a
getConcurrentlyT
      (NonEmpty (ConcurrentlyT m a) -> NonEmpty (FreeAsyncT m a))
-> (NonEmpty (FreeAsyncT m a)
    -> ConcurrentlyT m (NonEmpty a, [ConcurrentlyT m a]))
-> NonEmpty (ConcurrentlyT m a)
-> ConcurrentlyT m (NonEmpty a, [ConcurrentlyT m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> NonEmpty (FreeAsyncT m a)
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
forall a.
NonEmpty (FreeAsyncT m a)
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule
      (NonEmpty (FreeAsyncT m a)
 -> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a]))
-> (FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
    -> ConcurrentlyT m (NonEmpty a, [ConcurrentlyT m a]))
-> NonEmpty (FreeAsyncT m a)
-> ConcurrentlyT m (NonEmpty a, [ConcurrentlyT m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((NonEmpty a, [FreeAsyncT m a])
 -> (NonEmpty a, [ConcurrentlyT m a]))
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
-> FreeAsyncT m (NonEmpty a, [ConcurrentlyT m a])
forall a b. (a -> b) -> FreeAsyncT m a -> FreeAsyncT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([FreeAsyncT m a] -> [ConcurrentlyT m a])
-> (NonEmpty a, [FreeAsyncT m a])
-> (NonEmpty a, [ConcurrentlyT m a])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((FreeAsyncT m a -> ConcurrentlyT m a)
-> [FreeAsyncT m a] -> [ConcurrentlyT m a]
forall a b. (a -> b) -> [a] -> [b]
map FreeAsyncT m a -> ConcurrentlyT m a
forall (m :: * -> *) a. FreeAsyncT m a -> ConcurrentlyT m a
ConcurrentlyT))
      (FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
 -> FreeAsyncT m (NonEmpty a, [ConcurrentlyT m a]))
-> (FreeAsyncT m (NonEmpty a, [ConcurrentlyT m a])
    -> ConcurrentlyT m (NonEmpty a, [ConcurrentlyT m a]))
-> FreeAsyncT m (NonEmpty a, [FreeAsyncT m a])
-> ConcurrentlyT m (NonEmpty a, [ConcurrentlyT m a])
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> FreeAsyncT m (NonEmpty a, [ConcurrentlyT m a])
-> ConcurrentlyT m (NonEmpty a, [ConcurrentlyT m a])
forall (m :: * -> *) a. FreeAsyncT m a -> ConcurrentlyT m a
ConcurrentlyT