{-# options_haddock prune #-}
-- |Description: Race Interpreters
module Polysemy.Conc.Interpreter.Race where

import qualified Control.Concurrent.Async as Async
import Polysemy.Final (interpretFinal, runS)
import qualified Polysemy.Time as Time
import Polysemy.Time (MicroSeconds (MicroSeconds))
import qualified System.Timeout as System

import qualified Polysemy.Conc.Effect.Race as Race
import Polysemy.Conc.Effect.Race (Race)

biseqEither ::
  Functor f =>
  Either (f a) (f b) ->
  f (Either a b)
biseqEither :: Either (f a) (f b) -> f (Either a b)
biseqEither =
  (f a -> f (Either a b))
-> (f b -> f (Either a b)) -> Either (f a) (f b) -> f (Either a b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((a -> Either a b) -> f a -> f (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a b
forall a b. a -> Either a b
Left) ((b -> Either a b) -> f b -> f (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either a b
forall a b. b -> Either a b
Right)
{-# inline biseqEither #-}

-- |Interpret 'Race' in terms of 'Async.race' and 'System.timeout'.
-- Since this has to pass higher-order thunks as 'IO' arguments, it is interpreted in terms of 'Final IO'.
interpretRace ::
  Member (Final IO) r =>
  InterpreterFor Race r
interpretRace :: InterpreterFor Race r
interpretRace =
  (forall x (rInitial :: EffectRow).
 Race (Sem rInitial) x -> Strategic IO (Sem rInitial) x)
-> Sem (Race : r) a -> Sem r a
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 \case
    Race.Race left right ->
      (IO (Either (f a) (f b)) -> IO (f (Either a b)))
-> (IO (f b) -> IO (Either (f a) (f b)))
-> IO (f b)
-> IO (f (Either a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either (f a) (f b) -> f (Either a b))
-> IO (Either (f a) (f b)) -> IO (f (Either a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (f a) (f b) -> f (Either a b)
forall (f :: * -> *) a b.
Functor f =>
Either (f a) (f b) -> f (Either a b)
biseqEither) ((IO (f b) -> IO (Either (f a) (f b)))
 -> IO (f b) -> IO (f (Either a b)))
-> (IO (f a) -> IO (f b) -> IO (Either (f a) (f b)))
-> IO (f a)
-> IO (f b)
-> IO (f (Either a b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (f a) -> IO (f b) -> IO (Either (f a) (f b))
forall a b. IO a -> IO b -> IO (Either a b)
Async.race (IO (f a) -> IO (f b) -> IO (f (Either a b)))
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f a))
-> Sem
     (WithStrategy IO f (Sem rInitial))
     (IO (f b) -> IO (f (Either a b)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem rInitial a -> Sem (WithStrategy IO f (Sem rInitial)) (IO (f a))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial a
left Sem (WithStrategy IO f (Sem rInitial)) (IO (f b) -> IO (f x))
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f b))
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Sem rInitial b -> Sem (WithStrategy IO f (Sem rInitial)) (IO (f b))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial b
right
    Race.Timeout ma (Time.convert -> MicroSeconds timeout) mb -> do
      IO (f a)
maT <- Sem rInitial a -> Sem (WithStrategy IO f (Sem rInitial)) (IO (f a))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial a
ma
      IO (f b)
mbT <- Sem rInitial b -> Sem (WithStrategy IO f (Sem rInitial)) (IO (f b))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial b
mb
      pure (IO (f (Either a b))
-> (f b -> IO (f (Either a b)))
-> Maybe (f b)
-> IO (f (Either a b))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((a -> Either a b) -> f a -> f (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a b
forall a b. a -> Either a b
Left (f a -> f (Either a b)) -> IO (f a) -> IO (f (Either a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (f a)
maT) (f (Either a b) -> IO (f (Either a b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f (Either a b) -> IO (f (Either a b)))
-> (f b -> f (Either a b)) -> f b -> IO (f (Either a b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Either a b) -> f b -> f (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either a b
forall a b. b -> Either a b
Right) (Maybe (f b) -> IO (f (Either a b)))
-> IO (Maybe (f b)) -> IO (f (Either a b))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO (f b) -> IO (Maybe (f b))
forall a. Int -> IO a -> IO (Maybe a)
System.timeout (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
timeout) IO (f b)
mbT)
{-# inline interpretRace #-}