{-# language Safe #-}

module LazyAsync.Actions.Spawn
  ( lazyAsync, withLazyAsyncIO
  , manyLazyAsyncs, withLazyAsyncListIO
  , acquire, acquireIO
  ) where

import LazyAsync.Libraries.Async (Async, async, cancel, pollSTM, withAsync)

import LazyAsync.Types (LazyAsync (A1), Outcome (..), Resource (..),
                        StartPoll (..), Status (..))

import LazyAsync.Prelude (Applicative ((*>)), Bool (..), ContT (..),
                          Either (..), Functor (fmap), IO, Maybe (..),
                          MonadBase (..), MonadBaseControl (StM), MonadIO (..),
                          SomeException, TVar, Traversable, atomically, check,
                          lift, newTVarIO, readTVar, return, traverse,
                          writeTVar, (<&>), (>>=))

startPoll :: MonadBaseControl IO m =>
    m a -- ^ Action
    -> ContT b m (StartPoll (StM m a))
startPoll :: m a -> ContT b m (StartPoll (StM m a))
startPoll m a
action =
  do
    TVar Bool
s <- m (TVar Bool) -> ContT b m (TVar Bool)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Bool -> m (TVar Bool)
forall (base :: * -> *) (m :: * -> *) a.
(MonadBase base m, MonadIO base) =>
a -> m (TVar a)
newTVar Bool
False)
    Async (StM m a)
a <- ((Async (StM m a) -> m b) -> m b) -> ContT b m (Async (StM m a))
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (m a -> (Async (StM m a) -> m b) -> m b
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> (Async (StM m a) -> m b) -> m b
withAsync (TVar Bool -> m ()
forall (base :: * -> *) (m :: * -> *).
(MonadBase base m, MonadIO base) =>
TVar Bool -> m ()
waitForTrue TVar Bool
s m () -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
action))
    StartPoll (StM m a) -> ContT b m (StartPoll (StM m a))
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Bool -> Async (StM m a) -> StartPoll (StM m a)
forall a. TVar Bool -> Async a -> StartPoll a
makeStartPoll TVar Bool
s Async (StM m a)
a)

acquireStartPoll :: MonadBaseControl IO m =>
    m a -- ^ Action
    -> m (Resource m (StartPoll (StM m a)))
acquireStartPoll :: m a -> m (Resource m (StartPoll (StM m a)))
acquireStartPoll m a
action =
  do
    TVar Bool
s <- Bool -> m (TVar Bool)
forall (base :: * -> *) (m :: * -> *) a.
(MonadBase base m, MonadIO base) =>
a -> m (TVar a)
newTVar Bool
False
    Async (StM m a)
a <- m a -> m (Async (StM m a))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async (TVar Bool -> m ()
forall (base :: * -> *) (m :: * -> *).
(MonadBase base m, MonadIO base) =>
TVar Bool -> m ()
waitForTrue TVar Bool
s m () -> m a -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m a
action)
    Resource m (StartPoll (StM m a))
-> m (Resource m (StartPoll (StM m a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Resource :: forall (m :: * -> *) a. m () -> a -> Resource m a
Resource{ release :: m ()
release = Async (StM m a) -> m ()
forall (m :: * -> *) a. MonadBase IO m => Async a -> m ()
cancel Async (StM m a)
a, resource :: StartPoll (StM m a)
resource = TVar Bool -> Async (StM m a) -> StartPoll (StM m a)
forall a. TVar Bool -> Async a -> StartPoll a
makeStartPoll TVar Bool
s Async (StM m a)
a})

makeStartPoll :: TVar Bool -> Async a -> StartPoll a
makeStartPoll :: TVar Bool -> Async a -> StartPoll a
makeStartPoll TVar Bool
s Async a
a = STM () -> STM (Status a) -> StartPoll a
forall a. STM () -> STM (Status a) -> StartPoll a
StartPoll (TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
s Bool
True) (Async a -> STM (Maybe (Either SomeException a))
forall a. Async a -> STM (Maybe (Either SomeException a))
pollSTM Async a
a STM (Maybe (Either SomeException a))
-> (Maybe (Either SomeException a) -> Status a) -> STM (Status a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Maybe (Either SomeException a) -> Status a
forall a. Maybe (Either SomeException a) -> Status a
maybeEitherStatus)

{- | Creates a situation wherein:

  * The action shall begin running only once it is needed (that is, until prompted by 'LazyAsync.start')
  * The action shall run asynchronously (other than where it is 'LazyAsync.wait'ed upon)
  * The action shall run at most once
  * The action shall run only within the continuation (when the continuation ends, the action is stopped)
-}
lazyAsync :: MonadBaseControl IO m =>
    m a -- ^ Action
    -> ContT r m (LazyAsync (StM m a))
lazyAsync :: m a -> ContT r m (LazyAsync (StM m a))
lazyAsync m a
action = (StartPoll (StM m a) -> LazyAsync (StM m a))
-> ContT r m (StartPoll (StM m a))
-> ContT r m (LazyAsync (StM m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StartPoll (StM m a) -> LazyAsync (StM m a)
forall a. StartPoll a -> LazyAsync a
A1 (m a -> ContT r m (StartPoll (StM m a))
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> ContT b m (StartPoll (StM m a))
startPoll m a
action)

-- | 🌈 'manyLazyAsyncs' is equivalent to @('traverse' 'lazyAsync')@
manyLazyAsyncs :: (MonadBaseControl IO m, Traversable t) =>
    t (m a) -> ContT r m (t (LazyAsync (StM m a)))
manyLazyAsyncs :: t (m a) -> ContT r m (t (LazyAsync (StM m a)))
manyLazyAsyncs = (m a -> ContT r m (LazyAsync (StM m a)))
-> t (m a) -> ContT r m (t (LazyAsync (StM m a)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse m a -> ContT r m (LazyAsync (StM m a))
forall (m :: * -> *) a r.
MonadBaseControl IO m =>
m a -> ContT r m (LazyAsync (StM m a))
lazyAsync

-- | Akin to 'manyLazyAsyncs'
withLazyAsyncListIO :: [IO a] -> ([LazyAsync a] -> IO b) -> IO b
withLazyAsyncListIO :: [IO a] -> ([LazyAsync a] -> IO b) -> IO b
withLazyAsyncListIO [IO a]
actions = ContT b IO [LazyAsync a] -> ([LazyAsync a] -> IO b) -> IO b
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT ([IO a] -> ContT b IO [LazyAsync (StM IO a)]
forall (m :: * -> *) (t :: * -> *) a r.
(MonadBaseControl IO m, Traversable t) =>
t (m a) -> ContT r m (t (LazyAsync (StM m a)))
manyLazyAsyncs [IO a]
actions)

{- | Like 'lazyAsync', but does not automatically stop the action

The returned 'Resource' includes the desired 'LazyAsync' (the 'resource'), as
well as a 'release' action that brings it to a halt. If the action is not yet
started, 'release' prevents it from ever starting. If the action is in progress,
'release' throws an async exception to stop it. If the action is completed,
'release' has no effect.

A 'LazyAsync.LazyAsync' represents a background thread which may be utilizing
time and space. A running thread is not automatically reaped by the garbage
collector, so one should take care to eventually 'release' every 'LazyAsync'
resource to avoid accidentally leaving unwanted 'LazyAsync's running.

-}
acquire :: MonadBaseControl IO m =>
    m a -- ^ Action
    -> m (Resource m (LazyAsync (StM m a)))
acquire :: m a -> m (Resource m (LazyAsync (StM m a)))
acquire m a
action = (Resource m (StartPoll (StM m a))
 -> Resource m (LazyAsync (StM m a)))
-> m (Resource m (StartPoll (StM m a)))
-> m (Resource m (LazyAsync (StM m a)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((StartPoll (StM m a) -> LazyAsync (StM m a))
-> Resource m (StartPoll (StM m a))
-> Resource m (LazyAsync (StM m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StartPoll (StM m a) -> LazyAsync (StM m a)
forall a. StartPoll a -> LazyAsync a
A1) (m a -> m (Resource m (StartPoll (StM m a)))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Resource m (StartPoll (StM m a)))
acquireStartPoll m a
action)

-- | Akin to 'acquire'
acquireIO :: IO a -> IO (Resource IO (LazyAsync a))
acquireIO :: IO a -> IO (Resource IO (LazyAsync a))
acquireIO = IO a -> IO (Resource IO (LazyAsync a))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Resource m (LazyAsync (StM m a)))
acquire

-- | Akin to 'lazyAsync'
withLazyAsyncIO :: IO a -> (LazyAsync a -> IO b) -> IO b
withLazyAsyncIO :: IO a -> (LazyAsync a -> IO b) -> IO b
withLazyAsyncIO IO a
action = ContT b IO (LazyAsync a) -> (LazyAsync a -> IO b) -> IO b
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT (IO a -> ContT b IO (LazyAsync (StM IO a))
forall (m :: * -> *) a r.
MonadBaseControl IO m =>
m a -> ContT r m (LazyAsync (StM m a))
lazyAsync IO a
action)

waitForTrue :: (MonadBase base m, MonadIO base) => TVar Bool -> m ()
waitForTrue :: TVar Bool -> m ()
waitForTrue TVar Bool
x = base () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> base ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
x STM Bool -> (Bool -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM ()
check)))

newTVar :: (MonadBase base m, MonadIO base) => a -> m (TVar a)
newTVar :: a -> m (TVar a)
newTVar a
x = base (TVar a) -> m (TVar a)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (TVar a) -> base (TVar a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (a -> IO (TVar a)
forall a. a -> IO (TVar a)
newTVarIO a
x))

maybeEitherStatus :: Maybe (Either SomeException a) -> Status a
maybeEitherStatus :: Maybe (Either SomeException a) -> Status a
maybeEitherStatus Maybe (Either SomeException a)
Nothing  = Status a
forall a. Status a
Incomplete
maybeEitherStatus (Just Either SomeException a
x) = Outcome a -> Status a
forall a. Outcome a -> Status a
Done (Either SomeException a -> Outcome a
forall a. Either SomeException a -> Outcome a
eitherDone Either SomeException a
x)

eitherDone :: Either SomeException a -> Outcome a
eitherDone :: Either SomeException a -> Outcome a
eitherDone (Left SomeException
e)  = SomeException -> Outcome a
forall a. SomeException -> Outcome a
Failure SomeException
e
eitherDone (Right a
x) = a -> Outcome a
forall a. a -> Outcome a
Success a
x