-- |Description: Sync interpreters
module Polysemy.Conc.Sync where

import Control.Concurrent (isEmptyMVar)

import qualified Polysemy.Conc.Data.Race as Race
import Polysemy.Conc.Data.Race (Race)
import qualified Polysemy.Conc.Data.Sync as Sync
import Polysemy.Conc.Data.Sync (Sync)
import qualified Polysemy.Conc.Race as Race

-- |Interpret 'Sync' with the provided 'MVar'.
interpretSyncWith ::
  ∀ d r .
  Members [Race, Embed IO] r =>
  MVar d ->
  InterpreterFor (Sync d) r
interpretSyncWith :: MVar d -> InterpreterFor (Sync d) r
interpretSyncWith MVar d
var =
  (forall x (rInitial :: EffectRow).
 Sync d (Sem rInitial) x -> Sem r x)
-> Sem (Sync d : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: EffectRow). e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Sync d (Sem rInitial) x
Sync.Block ->
      MVar d -> Sem r d
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar d
var
    Sync.Wait interval ->
      Either () d -> Maybe d
forall l r. Either l r -> Maybe r
rightToMaybe (Either () d -> Maybe d) -> Sem r (Either () d) -> Sem r (Maybe d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> u -> Sem r d -> Sem r (Either () d)
forall a b u (r :: EffectRow).
(TimeUnit u, Member Race r) =>
a -> u -> Sem r b -> Sem r (Either a b)
Race.timeout () u
interval (MVar d -> Sem r d
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar d
var)
    Sync d (Sem rInitial) x
Sync.Try ->
      MVar d -> Sem r (Maybe d)
forall (m :: * -> *) a. MonadIO m => MVar a -> m (Maybe a)
tryReadMVar MVar d
var
    Sync d (Sem rInitial) x
Sync.TakeBlock ->
      MVar d -> Sem r d
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar d
var
    Sync.TakeWait interval ->
      Either () d -> Maybe d
forall l r. Either l r -> Maybe r
rightToMaybe (Either () d -> Maybe d) -> Sem r (Either () d) -> Sem r (Maybe d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> u -> Sem r d -> Sem r (Either () d)
forall a b u (r :: EffectRow).
(TimeUnit u, Member Race r) =>
a -> u -> Sem r b -> Sem r (Either a b)
Race.timeout () u
interval (MVar d -> Sem r d
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar d
var)
    Sync d (Sem rInitial) x
Sync.TakeTry ->
      MVar d -> Sem r (Maybe d)
forall (m :: * -> *) a. MonadIO m => MVar a -> m (Maybe a)
tryTakeMVar MVar d
var
    Sync.PutBlock d ->
      MVar d -> d -> Sem r ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar d
var d
d
    Sync.PutWait interval d ->
      Bool -> u -> Sem r Bool -> Sem r Bool
forall u (r :: EffectRow) a.
(TimeUnit u, Member Race r) =>
a -> u -> Sem r a -> Sem r a
Race.timeout_ Bool
False u
interval (Bool
True Bool -> Sem r () -> Sem r Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MVar d -> d -> Sem r ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar d
var d
d)
    Sync.PutTry d ->
      MVar d -> d -> Sem r Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar MVar d
var d
d
    Sync d (Sem rInitial) x
Sync.Empty ->
      IO Bool -> Sem r Bool
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (MVar d -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar d
var)

-- |Interpret 'Sync' with an empty 'MVar'.
interpretSync ::
  ∀ d r .
  Members [Race, Embed IO] r =>
  InterpreterFor (Sync d) r
interpretSync :: InterpreterFor (Sync d) r
interpretSync Sem (Sync d : r) a
sem = do
  MVar d
var <- Sem r (MVar d)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  MVar d -> Sem (Sync d : r) a -> Sem r a
forall d (r :: EffectRow).
Members '[Race, Embed IO] r =>
MVar d -> InterpreterFor (Sync d) r
interpretSyncWith MVar d
var Sem (Sync d : r) a
sem

-- |Interpret 'Sync' with an 'MVar' containing the specified value.
interpretSyncAs ::
  ∀ d r .
  Members [Race, Embed IO] r =>
  d ->
  InterpreterFor (Sync d) r
interpretSyncAs :: d -> InterpreterFor (Sync d) r
interpretSyncAs d
d Sem (Sync d : r) a
sem = do
  MVar d
var <- d -> Sem r (MVar d)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar d
d
  MVar d -> Sem (Sync d : r) a -> Sem r a
forall d (r :: EffectRow).
Members '[Race, Embed IO] r =>
MVar d -> InterpreterFor (Sync d) r
interpretSyncWith MVar d
var Sem (Sync d : r) a
sem