{-# options_haddock prune #-}

-- |Description: Sync Combinators
module Polysemy.Conc.Sync (
  module Polysemy.Conc.Sync,
  module Polysemy.Conc.Effect.Sync,
) where

import qualified Polysemy.Time as Time
import Polysemy.Time (Time, TimeUnit)

import Polysemy.Conc.Effect.Mask (Mask, mask, restore)
import Polysemy.Conc.Effect.Scoped (scoped)
import qualified Polysemy.Conc.Effect.Sync as Sync
import Polysemy.Conc.Effect.Sync (
  ScopedSync,
  Sync,
  SyncResources,
  block,
  empty,
  putBlock,
  putTry,
  putWait,
  takeBlock,
  takeTry,
  takeWait,
  try,
  wait,
  )

-- |Run an action repeatedly until the 'Sync' variable is available.
whileEmpty ::
  ∀ a r .
  Member (Sync a) r =>
  Sem r () ->
  Sem r ()
whileEmpty :: forall a (r :: [(* -> *) -> * -> *]).
Member (Sync a) r =>
Sem r () -> Sem r ()
whileEmpty Sem r ()
action =
  Sem r ()
spin
  where
    spin :: Sem r ()
spin = do
      Sem r ()
action
      Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not (Bool -> Bool) -> Sem r Bool -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
Sem r Bool
Sync.empty @a) Sem r ()
spin

-- |Run an action repeatedly until the 'Sync' variable is available, waiting for the specified time between executions.
whileEmptyInterval ::
  ∀ a u t d r .
  TimeUnit u =>
  Members [Time t d, Sync a] r =>
  u ->
  Sem r () ->
  Sem r ()
whileEmptyInterval :: forall a u t d (r :: [(* -> *) -> * -> *]).
(TimeUnit u, Members '[Time t d, Sync a] r) =>
u -> Sem r () -> Sem r ()
whileEmptyInterval u
interval Sem r ()
action =
  Sem r ()
spin
  where
    spin :: Sem r ()
spin = do
      Sem r ()
action
      Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not (Bool -> Bool) -> Sem r Bool -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
Sem r Bool
Sync.empty @a) (forall t d u (r :: [(* -> *) -> * -> *]).
(TimeUnit u, Member (Time t d) r) =>
u -> Sem r ()
Time.sleep @t @d u
interval Sem r () -> Sem r () -> Sem r ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Sem r ()
spin)

-- |Run an action with a locally scoped 'Sync' variable.
-- This avoids a dependency on @'Embed' 'IO'@ in application logic while still allowing the variable to be scoped.
withSync ::
  ∀ d res r .
  Member (ScopedSync res d) r =>
  InterpreterFor (Sync d) r
withSync :: forall d res (r :: [(* -> *) -> * -> *]).
Member (ScopedSync res d) r =>
InterpreterFor (Sync d) r
withSync =
  forall resource (effect :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]).
Member (Scoped resource effect) r =>
InterpreterFor effect r
scoped @(SyncResources res)

-- |Run the action @ma@ with an exclusive lock (mutex).
-- When multiple threads call the action concurrently, only one is allowed to execute it at a time.
-- The value @l@ is used to disambiguate the 'Sync' from other uses of the combinator.
-- You can pass in something like @Proxy @"db-write"@.
--
-- /Note:/ The 'Sync' must be interpreted with an initially full @MVar@, e.g. using 'Polysemy.Conc.interpretSyncAs'.
lock ::
  ∀ l r a .
  Members [Sync l, Resource] r =>
  l ->
  Sem r a ->
  Sem r a
lock :: forall l (r :: [(* -> *) -> * -> *]) a.
Members '[Sync l, Resource] r =>
l -> Sem r a -> Sem r a
lock l
l Sem r a
ma =
  Sem r a -> Sem r Bool -> Sem r a
forall (r :: [(* -> *) -> * -> *]) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
finally (forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
Sem r d
takeBlock @l Sem r l -> Sem r a -> Sem r a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Sem r a
ma) (l -> Sem r Bool
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r Bool
putTry l
l)
{-# inline lock #-}

-- |Remove the content of the 'Sync' variable if it is present.
clear ::
  ∀ a r .
  Member (Sync a) r =>
  Sem r ()
clear :: forall a (r :: [(* -> *) -> * -> *]). Member (Sync a) r => Sem r ()
clear =
  Sem r (Maybe a) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
Sem r (Maybe d)
takeTry @a)
{-# inline clear #-}

-- |Modify a 'Sync' variable with async exceptions masked for the 'Sync' operations, but not the action.
-- Allows a value to be returned.
-- Equivalent to 'Control.Concurrent.MVar.modifyMVar'.
modify ::
  ∀ a b res r .
  Members [Sync a, Mask res, Resource] r =>
  (a -> Sem r (a, b)) ->
  Sem r b
modify :: forall a b res (r :: [(* -> *) -> * -> *]).
Members '[Sync a, Mask res, Resource] r =>
(a -> Sem r (a, b)) -> Sem r b
modify a -> Sem r (a, b)
m =
  forall resource (r :: [(* -> *) -> * -> *]).
Member (Mask resource) r =>
InterpreterFor RestoreMask r
mask @res do
    a
a <- Sem (RestoreMask : r) a
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
Sem r d
takeBlock
    (a
a', b
b) <- Sem (RestoreMask : r) (a, b)
-> Sem (RestoreMask : r) () -> Sem (RestoreMask : r) (a, b)
forall (r :: [(* -> *) -> * -> *]) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
onException (Sem (RestoreMask : r) (a, b) -> Sem (RestoreMask : r) (a, b)
forall (r :: [(* -> *) -> * -> *]) a.
Member RestoreMask r =>
Sem r a -> Sem r a
restore (Sem r (a, b) -> Sem (RestoreMask : r) (a, b)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (a -> Sem r (a, b)
m a
a))) (a -> Sem (RestoreMask : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
putBlock a
a)
    b
b b -> Sem (RestoreMask : r) () -> Sem (RestoreMask : r) b
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> Sem (RestoreMask : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
putBlock a
a'
{-# inline modify #-}

-- |Modify a 'Sync' variable with async exceptions masked for the 'Sync' operations, but not the action.
-- Does not allow a value to be returned.
-- Equivalent to 'Control.Concurrent.MVar.modifyMVar_'.
modify_ ::
  ∀ a res r .
  Members [Sync a, Mask res, Resource] r =>
  (a -> Sem r a) ->
  Sem r ()
modify_ :: forall a res (r :: [(* -> *) -> * -> *]).
Members '[Sync a, Mask res, Resource] r =>
(a -> Sem r a) -> Sem r ()
modify_ a -> Sem r a
m =
  forall resource (r :: [(* -> *) -> * -> *]).
Member (Mask resource) r =>
InterpreterFor RestoreMask r
mask @res do
    a
a <- Sem (RestoreMask : r) a
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
Sem r d
takeBlock
    a
a' <- Sem (RestoreMask : r) a
-> Sem (RestoreMask : r) () -> Sem (RestoreMask : r) a
forall (r :: [(* -> *) -> * -> *]) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
onException (Sem (RestoreMask : r) a -> Sem (RestoreMask : r) a
forall (r :: [(* -> *) -> * -> *]) a.
Member RestoreMask r =>
Sem r a -> Sem r a
restore (Sem r a -> Sem (RestoreMask : r) a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (a -> Sem r a
m a
a))) (a -> Sem (RestoreMask : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
putBlock a
a)
    a -> Sem (RestoreMask : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
putBlock a
a'
{-# inline modify_ #-}

-- |Modify a 'Sync' variable with async exceptions masked for the entire procedure.
-- Allows a value to be returned.
-- Equivalent to 'Control.Concurrent.MVar.modifyMVarMasked'.
modifyMasked ::
  ∀ a b res r .
  Members [Sync a, Mask res, Resource] r =>
  (a -> Sem r (a, b)) ->
  Sem r b
modifyMasked :: forall a b res (r :: [(* -> *) -> * -> *]).
Members '[Sync a, Mask res, Resource] r =>
(a -> Sem r (a, b)) -> Sem r b
modifyMasked a -> Sem r (a, b)
m =
  forall resource (r :: [(* -> *) -> * -> *]).
Member (Mask resource) r =>
InterpreterFor RestoreMask r
mask @res do
    a
a <- Sem (RestoreMask : r) a
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
Sem r d
takeBlock
    (a
a', b
b) <- Sem (RestoreMask : r) (a, b)
-> Sem (RestoreMask : r) () -> Sem (RestoreMask : r) (a, b)
forall (r :: [(* -> *) -> * -> *]) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
onException (Sem r (a, b) -> Sem (RestoreMask : r) (a, b)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (a -> Sem r (a, b)
m a
a)) (a -> Sem (RestoreMask : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
putBlock a
a)
    b
b b -> Sem (RestoreMask : r) () -> Sem (RestoreMask : r) b
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> Sem (RestoreMask : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
putBlock a
a'
{-# inline modifyMasked #-}

-- |Modify a 'Sync' variable with async exceptions masked for the entire procedure.
-- Does not allow a value to be returned.
-- Equivalent to 'Control.Concurrent.MVar.modifyMVarMasked_'.
modifyMasked_ ::
  ∀ a res r .
  Members [Sync a, Mask res, Resource] r =>
  (a -> Sem r a) ->
  Sem r ()
modifyMasked_ :: forall a res (r :: [(* -> *) -> * -> *]).
Members '[Sync a, Mask res, Resource] r =>
(a -> Sem r a) -> Sem r ()
modifyMasked_ a -> Sem r a
m =
  forall resource (r :: [(* -> *) -> * -> *]).
Member (Mask resource) r =>
InterpreterFor RestoreMask r
mask @res do
    a
a <- Sem (RestoreMask : r) a
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
Sem r d
takeBlock
    a
a' <- Sem (RestoreMask : r) a
-> Sem (RestoreMask : r) () -> Sem (RestoreMask : r) a
forall (r :: [(* -> *) -> * -> *]) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
onException (Sem r a -> Sem (RestoreMask : r) a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (a -> Sem r a
m a
a)) (a -> Sem (RestoreMask : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
putBlock a
a)
    a -> Sem (RestoreMask : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
putBlock a
a'
{-# inline modifyMasked_ #-}

-- |Run an action with the current value of the 'Sync' variable with async exceptions masked for the 'Sync' operations,
-- but not the action.
-- Equivalent to 'Control.Concurrent.MVar.withMVar'.
use ::
  ∀ a b res r .
  Members [Sync a, Mask res, Resource] r =>
  (a -> Sem r b) ->
  Sem r b
use :: forall a b res (r :: [(* -> *) -> * -> *]).
Members '[Sync a, Mask res, Resource] r =>
(a -> Sem r b) -> Sem r b
use a -> Sem r b
m =
  forall resource (r :: [(* -> *) -> * -> *]).
Member (Mask resource) r =>
InterpreterFor RestoreMask r
mask @res do
    a
a <- Sem (RestoreMask : r) a
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
Sem r d
takeBlock
    Sem (RestoreMask : r) b
-> Sem (RestoreMask : r) () -> Sem (RestoreMask : r) b
forall (r :: [(* -> *) -> * -> *]) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
finally (Sem (RestoreMask : r) b -> Sem (RestoreMask : r) b
forall (r :: [(* -> *) -> * -> *]) a.
Member RestoreMask r =>
Sem r a -> Sem r a
restore (Sem r b -> Sem (RestoreMask : r) b
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (a -> Sem r b
m a
a))) (a -> Sem (RestoreMask : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
putBlock a
a)
{-# inline use #-}

-- |Run an action with the current value of the 'Sync' variable with async exceptions masked for the entire procedure.
-- Equivalent to 'Control.Concurrent.MVar.withMVarMasked'.
useMasked ::
  ∀ a b res r .
  Members [Sync a, Mask res, Resource] r =>
  (a -> Sem r b) ->
  Sem r b
useMasked :: forall a b res (r :: [(* -> *) -> * -> *]).
Members '[Sync a, Mask res, Resource] r =>
(a -> Sem r b) -> Sem r b
useMasked a -> Sem r b
m =
  forall resource (r :: [(* -> *) -> * -> *]).
Member (Mask resource) r =>
InterpreterFor RestoreMask r
mask @res do
    a
a <- Sem (RestoreMask : r) a
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
Sem r d
takeBlock
    Sem (RestoreMask : r) b
-> Sem (RestoreMask : r) () -> Sem (RestoreMask : r) b
forall (r :: [(* -> *) -> * -> *]) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
finally (Sem r b -> Sem (RestoreMask : r) b
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (a -> Sem r b
m a
a)) (a -> Sem (RestoreMask : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
putBlock a
a)
{-# inline useMasked #-}