{-# 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 :: forall (f :: * -> *) a b.
Functor f =>
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 :: forall (r :: [(* -> *) -> * -> *]).
Member (Final IO) r =>
InterpreterFor Race r
interpretRace =
  forall (m :: * -> *) (e :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
Member (Final m) r =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal @IO \case
    Race.Race Sem rInitial a1
left Sem rInitial b1
right ->
      (IO (Either (f a1) (f b1)) -> IO (f (Either a1 b1)))
-> (IO (f b1) -> IO (Either (f a1) (f b1)))
-> IO (f b1)
-> IO (f (Either a1 b1))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either (f a1) (f b1) -> f (Either a1 b1))
-> IO (Either (f a1) (f b1)) -> IO (f (Either a1 b1))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either (f a1) (f b1) -> f (Either a1 b1)
forall (f :: * -> *) a b.
Functor f =>
Either (f a) (f b) -> f (Either a b)
biseqEither) ((IO (f b1) -> IO (Either (f a1) (f b1)))
 -> IO (f b1) -> IO (f (Either a1 b1)))
-> (IO (f a1) -> IO (f b1) -> IO (Either (f a1) (f b1)))
-> IO (f a1)
-> IO (f b1)
-> IO (f (Either a1 b1))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (f a1) -> IO (f b1) -> IO (Either (f a1) (f b1))
forall a b. IO a -> IO b -> IO (Either a b)
Async.race (IO (f a1) -> IO (f b1) -> IO (f (Either a1 b1)))
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f a1))
-> Sem
     (WithStrategy IO f (Sem rInitial))
     (IO (f b1) -> IO (f (Either a1 b1)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem rInitial a1
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f a1))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial a1
left Sem (WithStrategy IO f (Sem rInitial)) (IO (f b1) -> IO (f x))
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f b1))
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f x))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Sem rInitial b1
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f b1))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial b1
right
    Race.Timeout Sem rInitial a1
ma (u -> MicroSeconds
forall a b. (TimeUnit a, TimeUnit b) => a -> b
Time.convert -> MicroSeconds Int64
timeout) Sem rInitial b1
mb -> do
      IO (f a1)
maT <- Sem rInitial a1
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f a1))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial a1
ma
      IO (f b1)
mbT <- Sem rInitial b1
-> Sem (WithStrategy IO f (Sem rInitial)) (IO (f b1))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial b1
mb
      pure (IO (f (Either a1 b1))
-> (f b1 -> IO (f (Either a1 b1)))
-> Maybe (f b1)
-> IO (f (Either a1 b1))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((a1 -> Either a1 b1) -> f a1 -> f (Either a1 b1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a1 -> Either a1 b1
forall a b. a -> Either a b
Left (f a1 -> f (Either a1 b1)) -> IO (f a1) -> IO (f (Either a1 b1))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (f a1)
maT) (f (Either a1 b1) -> IO (f (Either a1 b1))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f (Either a1 b1) -> IO (f (Either a1 b1)))
-> (f b1 -> f (Either a1 b1)) -> f b1 -> IO (f (Either a1 b1))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b1 -> Either a1 b1) -> f b1 -> f (Either a1 b1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b1 -> Either a1 b1
forall a b. b -> Either a b
Right) (Maybe (f b1) -> IO (f (Either a1 b1)))
-> IO (Maybe (f b1)) -> IO (f (Either a1 b1))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO (f b1) -> IO (Maybe (f b1))
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 b1)
mbT)
{-# inline interpretRace #-}