module Wire.Sem.Concurrency.IO where

import Imports
import Polysemy
import Polysemy.Final
import UnliftIO (pooledMapConcurrentlyN, pooledMapConcurrentlyN_)
import Wire.Sem.Concurrency (Concurrency (..), ConcurrencySafety (Safe))

------------------------------------------------------------------------------

-- | Safely perform concurrency that wraps only IO effects.
performConcurrency ::
  (Member (Final IO) r) =>
  Sem (Concurrency 'Safe ': r) a ->
  Sem r a
performConcurrency :: forall (r :: EffectRow) a.
Member (Final IO) r =>
Sem (Concurrency 'Safe : r) a -> Sem r a
performConcurrency = Sem (Concurrency 'Safe : r) a -> Sem r a
forall (r :: EffectRow) (safe :: ConcurrencySafety) a.
Member (Final IO) r =>
Sem (Concurrency safe : r) a -> Sem r a
unsafelyPerformConcurrency

------------------------------------------------------------------------------

-- | VERY UNSAFELY perform concurrency in Polysemy. This is likely to lead to
-- obscure bugs. See the notes on 'Concurrency' to get a better understanding
-- of what can go wrong here.
unsafelyPerformConcurrency ::
  (Member (Final IO) r) =>
  Sem (Concurrency safe ': r) a ->
  Sem r a
unsafelyPerformConcurrency :: forall (r :: EffectRow) (safe :: ConcurrencySafety) a.
Member (Final IO) r =>
Sem (Concurrency safe : r) a -> Sem r a
unsafelyPerformConcurrency = forall (m :: * -> *) (e :: (* -> *) -> * -> *) (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).
  Concurrency safe (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
 -> Sem (Concurrency safe : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Concurrency safe (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
-> Sem (Concurrency safe : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  UnsafePooledMapConcurrentlyN Int
n a1 -> Sem rInitial b
f t a1
t -> do
    f ()
st <- Sem (WithStrategy IO f (Sem rInitial)) (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    f a1 -> IO (f b)
faction <- (a1 -> Sem rInitial b)
-> Sem (WithStrategy IO f (Sem rInitial)) (f a1 -> IO (f b))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS a1 -> Sem rInitial b
f
    let action :: a1 -> IO (f b)
action a1
a = f a1 -> IO (f b)
faction (f a1 -> IO (f b)) -> f a1 -> IO (f b)
forall a b. (a -> b) -> a -> b
$ a1
a a1 -> f () -> f a1
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
st
    IO (f [f b])
z <- IO [f b] -> Strategic IO (Sem rInitial) [f b]
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (IO [f b] -> Strategic IO (Sem rInitial) [f b])
-> IO [f b] -> Strategic IO (Sem rInitial) [f b]
forall a b. (a -> b) -> a -> b
$ Int -> (a1 -> IO (f b)) -> [a1] -> IO [f b]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
Int -> (a -> m b) -> t a -> m (t b)
pooledMapConcurrentlyN Int
n a1 -> IO (f b)
action ([a1] -> IO [f b]) -> [a1] -> IO [f b]
forall a b. (a -> b) -> a -> b
$ t a1 -> [a1]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a1
t
    Inspector forall x. f x -> Maybe x
ins <- Sem (WithStrategy IO f (Sem rInitial)) (Inspector f)
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
getInspectorS
    IO (f x) -> Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall a. a -> Sem (WithStrategy IO f (Sem rInitial)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO (f x) -> Sem (WithStrategy IO f (Sem rInitial)) (IO (f x)))
-> IO (f x) -> Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall a b. (a -> b) -> a -> b
$ (f [f b] -> f x) -> IO (f [f b]) -> IO (f x)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([f b] -> x) -> f [f b] -> f x
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f b -> Maybe b) -> [f b] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe f b -> Maybe b
forall x. f x -> Maybe x
ins)) IO (f [f b])
z
  UnsafePooledMapConcurrentlyN_ Int
n a1 -> Sem rInitial b
f t a1
t -> do
    f ()
st <- Sem (WithStrategy IO f (Sem rInitial)) (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    f a1 -> IO (f b)
faction <- (a1 -> Sem rInitial b)
-> Sem (WithStrategy IO f (Sem rInitial)) (f a1 -> IO (f b))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS a1 -> Sem rInitial b
f
    let action :: a1 -> IO (f b)
action a1
a = f a1 -> IO (f b)
faction (f a1 -> IO (f b)) -> f a1 -> IO (f b)
forall a b. (a -> b) -> a -> b
$ a1
a a1 -> f () -> f a1
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
st
    IO x -> Strategic IO (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (IO x -> Strategic IO (Sem rInitial) x)
-> IO x -> Strategic IO (Sem rInitial) x
forall a b. (a -> b) -> a -> b
$ Int -> (a1 -> IO (f b)) -> [a1] -> IO ()
forall (m :: * -> *) (f :: * -> *) a b.
(MonadUnliftIO m, Foldable f) =>
Int -> (a -> m b) -> f a -> m ()
pooledMapConcurrentlyN_ Int
n a1 -> IO (f b)
action ([a1] -> IO ()) -> [a1] -> IO ()
forall a b. (a -> b) -> a -> b
$ t a1 -> [a1]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a1
t