{-# LANGUAGE TemplateHaskell #-}
module Galley.Effects.FireAndForget
( FireAndForget,
fireAndForget,
spawnMany,
interpretFireAndForget,
)
where
import Imports
import Polysemy
import Polysemy.Final
import UnliftIO.Async (pooledMapConcurrentlyN_)
data FireAndForget m a where
FireAndForgetOne :: m () -> FireAndForget m ()
SpawnMany :: [m ()] -> FireAndForget m ()
makeSem ''FireAndForget
fireAndForget :: (Member FireAndForget r) => Sem r () -> Sem r ()
fireAndForget :: forall (r :: EffectRow).
Member FireAndForget r =>
Sem r () -> Sem r ()
fireAndForget = Sem r () -> Sem r ()
forall (r :: EffectRow).
Member FireAndForget r =>
Sem r () -> Sem r ()
fireAndForgetOne
interpretFireAndForget :: (Member (Final IO) r) => Sem (FireAndForget ': r) a -> Sem r a
interpretFireAndForget :: forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (FireAndForget : r) a -> Sem r a
interpretFireAndForget = forall (m :: * -> *) (e :: Effect) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal @IO ((forall x (rInitial :: EffectRow).
FireAndForget (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
-> Sem (FireAndForget : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
FireAndForget (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
-> Sem (FireAndForget : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
FireAndForgetOne Sem rInitial ()
action -> do
IO (f ())
action' <- Sem rInitial ()
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f ()))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial ()
action
IO x
-> forall {f :: * -> *}.
Functor f =>
Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (IO x
-> forall {f :: * -> *}.
Functor f =>
Sem (WithStrategy IO f (Sem rInitial)) (IO (f x)))
-> IO x
-> forall {f :: * -> *}.
Functor f =>
Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> IO x
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO x)
-> (IO (f ()) -> IO ThreadId) -> IO (f ()) -> IO x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO (IO () -> IO ThreadId)
-> (IO (f ()) -> IO ()) -> IO (f ()) -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (f ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (f ()) -> IO x) -> IO (f ()) -> IO x
forall a b. (a -> b) -> a -> b
$ IO (f ())
action'
SpawnMany [Sem rInitial ()]
actions -> do
[IO (f ())]
actions' <- (Sem rInitial ()
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f ())))
-> [Sem rInitial ()]
-> Sem (WithStrategy IO f (Sem rInitial)) [IO (f ())]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Sem rInitial ()
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f ()))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS [Sem rInitial ()]
actions
IO x
-> forall {f :: * -> *}.
Functor f =>
Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (IO x
-> forall {f :: * -> *}.
Functor f =>
Sem (WithStrategy IO f (Sem rInitial)) (IO (f x)))
-> IO x
-> forall {f :: * -> *}.
Functor f =>
Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall a b. (a -> b) -> a -> b
$ Int -> (IO (f ()) -> IO ()) -> [IO (f ())] -> IO ()
forall (m :: * -> *) (f :: * -> *) a b.
(MonadUnliftIO m, Foldable f) =>
Int -> (a -> m b) -> f a -> m ()
pooledMapConcurrentlyN_ Int
8 IO (f ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void [IO (f ())]
actions'