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

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

import qualified Polysemy.Conc.Data.Race as Race
import Polysemy.Conc.Data.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 err (Time.convert -> MicroSeconds timeout) mb -> do
      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
      f ()
s <- Sem (WithStrategy IO f (Sem rInitial)) (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
      pure (f (Either a b)
-> (f b -> f (Either a b)) -> Maybe (f b) -> f (Either a b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Either a b
forall a b. a -> Either a b
Left a
err Either a b -> f () -> f (Either a b)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) ((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) -> f (Either a b))
-> IO (Maybe (f b)) -> IO (f (Either a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 #-}

-- |Specialization of 'Race.race' for the case where both thunks return the same type, obviating the need for 'Either'.
race_ ::
  Member Race r =>
  Sem r a ->
  Sem r a ->
  Sem r a
race_ :: Sem r a -> Sem r a -> Sem r a
race_ Sem r a
ma Sem r a
mb =
  Either a a -> a
forall a. Either a a -> a
unify (Either a a -> a) -> Sem r (Either a a) -> Sem r a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r a -> Sem r a -> Sem r (Either a a)
forall a b (r :: EffectRow).
Member Race r =>
Sem r a -> Sem r b -> Sem r (Either a b)
Race.race Sem r a
ma Sem r a
mb
{-# INLINE race_ #-}

-- |Specialization of 'Race.timeout' for the case where the thunk return the same type as the fallback, obviating the
-- need for 'Either'.
timeout_ ::
  TimeUnit u =>
  Member Race r =>
  a ->
  u ->
  Sem r a ->
  Sem r a
timeout_ :: a -> u -> Sem r a -> Sem r a
timeout_ a
err u
interval Sem r a
mb =
  Either a a -> a
forall a. Either a a -> a
unify (Either a a -> a) -> Sem r (Either a a) -> Sem r a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> u -> Sem r a -> Sem r (Either a a)
forall a b u (r :: EffectRow).
(TimeUnit u, Member Race r) =>
a -> u -> Sem r b -> Sem r (Either a b)
Race.timeout a
err u
interval Sem r a
mb
{-# INLINE timeout_ #-}