{-# options_haddock prune #-}

-- |Lock interpreters, Internal
module Polysemy.Conc.Interpreter.Lock where

import Control.Concurrent (ThreadId, myThreadId)

import Polysemy.Conc.Effect.Lock (Lock (Lock, LockOr))
import Polysemy.Conc.Effect.Mask (Mask, mask, restore)
import Polysemy.Conc.Effect.Race (Race)
import qualified Polysemy.Conc.Effect.Sync as Sync (putTry, takeBlock, takeTry)
import Polysemy.Conc.Effect.Sync (Sync)
import Polysemy.Conc.Interpreter.Sync (interpretSyncAs)

currentThread ::
  Member (Embed IO) r =>
  Sem r ThreadId
currentThread :: forall (r :: EffectRow). Member (Embed IO) r => Sem r ThreadId
currentThread =
  IO ThreadId -> Sem r ThreadId
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO ThreadId
myThreadId

-- |Interpret 'Lock' by executing all actions unconditionally.
interpretLockPermissive ::
  InterpreterFor Lock r
interpretLockPermissive :: forall (r :: EffectRow). InterpreterFor Lock r
interpretLockPermissive =
  (forall (rInitial :: EffectRow) x.
 Lock (Sem rInitial) x -> Tactical Lock (Sem rInitial) r x)
-> Sem (Lock : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Lock Sem rInitial x
ma ->
      Sem rInitial x -> Tactical Lock (Sem rInitial) r x
forall (m :: * -> *) a (e :: Effect) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple Sem rInitial x
ma
    LockOr Sem rInitial x
_ Sem rInitial x
ma ->
      Sem rInitial x -> Tactical Lock (Sem rInitial) r x
forall (m :: * -> *) a (e :: Effect) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple Sem rInitial x
ma
{-# inline interpretLockPermissive #-}

lockOnDifferentThread ::
  ∀ f m r a .
  Members [Sync (), Resource, Race, Mask, Embed IO] r =>
  ThreadId ->
  m a ->
  (Sem (Lock : r) (f a) -> Sem (Lock : r) (f a)) ->
  Sem (WithTactics Lock f m r) (f a)
lockOnDifferentThread :: forall (f :: * -> *) (m :: * -> *) (r :: EffectRow) a.
Members '[Sync (), Resource, Race, Mask, Embed IO] r =>
ThreadId
-> m a
-> (Sem (Lock : r) (f a) -> Sem (Lock : r) (f a))
-> Sem (WithTactics Lock f m r) (f a)
lockOnDifferentThread ThreadId
lockThread m a
maI Sem (Lock : r) (f a) -> Sem (Lock : r) (f a)
f = do
  ThreadId
thread <- Sem (WithTactics Lock f m r) ThreadId
forall (r :: EffectRow). Member (Embed IO) r => Sem r ThreadId
currentThread
  Sem (Lock : r) (f a)
ma <- m a -> Sem (WithTactics Lock f m r) (Sem (Lock : r) (f a))
forall (m :: * -> *) a (e :: Effect) (f :: * -> *)
       (r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT m a
maI
  Sem r (f a) -> Sem (WithTactics Lock f m r) (f a)
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise (Sem r (f a) -> Sem (WithTactics Lock f m r) (f a))
-> Sem r (f a) -> Sem (WithTactics Lock f m r) (f a)
forall a b. (a -> b) -> a -> b
$ ThreadId -> InterpreterFor Lock r
forall (r :: EffectRow).
Members '[Sync (), Resource, Race, Mask, Embed IO] r =>
ThreadId -> InterpreterFor Lock r
interpretLockReentrantEntered ThreadId
thread do
    if ThreadId
thread ThreadId -> ThreadId -> Bool
forall a. Eq a => a -> a -> Bool
== ThreadId
lockThread
    then Sem (Lock : r) (f a)
ma
    else Sem (Lock : r) (f a) -> Sem (Lock : r) (f a)
f Sem (Lock : r) (f a)
ma
{-# inline lockOnDifferentThread #-}

enter ::
  ∀ f m r a .
  Members [Sync (), Resource, Race, Mask, Embed IO] r =>
  m a ->
  (Sem (Lock : r) (f a) -> Sem (Lock : r) (f a)) ->
  Sem (WithTactics Lock f m r) (f a)
enter :: forall (f :: * -> *) (m :: * -> *) (r :: EffectRow) a.
Members '[Sync (), Resource, Race, Mask, Embed IO] r =>
m a
-> (Sem (Lock : r) (f a) -> Sem (Lock : r) (f a))
-> Sem (WithTactics Lock f m r) (f a)
enter m a
maI Sem (Lock : r) (f a) -> Sem (Lock : r) (f a)
f = do
  ThreadId
thread <- Sem (WithTactics Lock f m r) ThreadId
forall (r :: EffectRow). Member (Embed IO) r => Sem r ThreadId
currentThread
  Sem (Lock : r) (f a)
ma <- m a -> Sem (WithTactics Lock f m r) (Sem (Lock : r) (f a))
forall (m :: * -> *) a (e :: Effect) (f :: * -> *)
       (r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT m a
maI
  Sem r (f a) -> Sem (WithTactics Lock f m r) (f a)
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise (Sem r (f a) -> Sem (WithTactics Lock f m r) (f a))
-> Sem r (f a) -> Sem (WithTactics Lock f m r) (f a)
forall a b. (a -> b) -> a -> b
$ ThreadId -> InterpreterFor Lock r
forall (r :: EffectRow).
Members '[Sync (), Resource, Race, Mask, Embed IO] r =>
ThreadId -> InterpreterFor Lock r
interpretLockReentrantEntered ThreadId
thread do
    Sem (Lock : r) (f a) -> Sem (Lock : r) (f a)
f Sem (Lock : r) (f a)
ma
{-# inline enter #-}

lockWait ::
  ∀ r a .
  Members [Sync (), Resource, Mask] r =>
  Sem r a ->
  Sem r a
lockWait :: forall (r :: EffectRow) a.
Members '[Sync (), Resource, Mask] r =>
Sem r a -> Sem r a
lockWait Sem r a
ma =
  Sem (RestoreMask : r) a -> Sem r a
forall (r :: EffectRow).
Member Mask r =>
InterpreterFor RestoreMask r
mask do
    forall d (r :: EffectRow). Member (Sync d) r => Sem r d
Sync.takeBlock @()
    Sem (RestoreMask : r) a
-> Sem (RestoreMask : r) Bool -> Sem (RestoreMask : r) a
forall (r :: EffectRow) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
finally (Sem (RestoreMask : r) a -> Sem (RestoreMask : r) a
forall (r :: EffectRow) a.
Member RestoreMask r =>
Sem r a -> Sem r a
restore (Sem r a -> Sem (RestoreMask : r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise Sem r a
ma)) (() -> Sem (RestoreMask : r) Bool
forall d (r :: EffectRow). Member (Sync d) r => d -> Sem r Bool
Sync.putTry ())
{-# inline lockWait #-}

lockAlt ::
  ∀ r a .
  Members [Sync (), Resource, Mask] r =>
  Sem r a ->
  Sem r a ->
  Sem r a
lockAlt :: forall (r :: EffectRow) a.
Members '[Sync (), Resource, Mask] r =>
Sem r a -> Sem r a -> Sem r a
lockAlt Sem r a
alt Sem r a
ma =
  Sem (RestoreMask : r) a -> Sem r a
forall (r :: EffectRow).
Member Mask r =>
InterpreterFor RestoreMask r
mask do
    Sem (RestoreMask : r) (Maybe ())
forall d (r :: EffectRow). Member (Sync d) r => Sem r (Maybe d)
Sync.takeTry Sem (RestoreMask : r) (Maybe ())
-> (Maybe () -> Sem (RestoreMask : r) a) -> Sem (RestoreMask : r) a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just () ->
        Sem (RestoreMask : r) a
-> Sem (RestoreMask : r) Bool -> Sem (RestoreMask : r) a
forall (r :: EffectRow) a b.
Member Resource r =>
Sem r a -> Sem r b -> Sem r a
finally (Sem (RestoreMask : r) a -> Sem (RestoreMask : r) a
forall (r :: EffectRow) a.
Member RestoreMask r =>
Sem r a -> Sem r a
restore (Sem r a -> Sem (RestoreMask : r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise Sem r a
ma)) (() -> Sem (RestoreMask : r) Bool
forall d (r :: EffectRow). Member (Sync d) r => d -> Sem r Bool
Sync.putTry ())
      Maybe ()
Nothing ->
        Sem (RestoreMask : r) a -> Sem (RestoreMask : r) a
forall (r :: EffectRow) a.
Member RestoreMask r =>
Sem r a -> Sem r a
restore (Sem r a -> Sem (RestoreMask : r) a
forall (e :: Effect) (r :: EffectRow) a. Sem r a -> Sem (e : r) a
raise Sem r a
alt)
{-# inline lockAlt #-}

-- |Subinterpreter for 'interpretLockReentrant' that checks whether the current thread is equal to the lock-acquiring
-- thread to allow reentry into the lock.
interpretLockReentrantEntered ::
  Members [Sync (), Resource, Race, Mask, Embed IO] r =>
  ThreadId ->
  InterpreterFor Lock r
interpretLockReentrantEntered :: forall (r :: EffectRow).
Members '[Sync (), Resource, Race, Mask, Embed IO] r =>
ThreadId -> InterpreterFor Lock r
interpretLockReentrantEntered ThreadId
lockThread =
  (forall (rInitial :: EffectRow) x.
 Lock (Sem rInitial) x -> Tactical Lock (Sem rInitial) r x)
-> Sem (Lock : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Lock Sem rInitial x
maI ->
      ThreadId
-> Sem rInitial x
-> (Sem (Lock : r) (f x) -> Sem (Lock : r) (f x))
-> Sem (WithTactics Lock f (Sem rInitial) r) (f x)
forall (f :: * -> *) (m :: * -> *) (r :: EffectRow) a.
Members '[Sync (), Resource, Race, Mask, Embed IO] r =>
ThreadId
-> m a
-> (Sem (Lock : r) (f a) -> Sem (Lock : r) (f a))
-> Sem (WithTactics Lock f m r) (f a)
lockOnDifferentThread ThreadId
lockThread Sem rInitial x
maI (Sem (Lock : r) (f x) -> Sem (Lock : r) (f x)
forall (r :: EffectRow) a.
Members '[Sync (), Resource, Mask] r =>
Sem r a -> Sem r a
lockWait)
    LockOr Sem rInitial x
altI Sem rInitial x
maI -> do
      Sem (Lock : r) (f x)
alt <- Sem rInitial x
-> Sem (WithTactics Lock f (Sem rInitial) r) (Sem (Lock : r) (f x))
forall (m :: * -> *) a (e :: Effect) (f :: * -> *)
       (r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial x
altI
      ThreadId
-> Sem rInitial x
-> (Sem (Lock : r) (f x) -> Sem (Lock : r) (f x))
-> Sem (WithTactics Lock f (Sem rInitial) r) (f x)
forall (f :: * -> *) (m :: * -> *) (r :: EffectRow) a.
Members '[Sync (), Resource, Race, Mask, Embed IO] r =>
ThreadId
-> m a
-> (Sem (Lock : r) (f a) -> Sem (Lock : r) (f a))
-> Sem (WithTactics Lock f m r) (f a)
lockOnDifferentThread ThreadId
lockThread Sem rInitial x
maI (Sem (Lock : r) (f x)
-> Sem (Lock : r) (f x) -> Sem (Lock : r) (f x)
forall (r :: EffectRow) a.
Members '[Sync (), Resource, Mask] r =>
Sem r a -> Sem r a -> Sem r a
lockAlt Sem (Lock : r) (f x)
alt)
{-# inline interpretLockReentrantEntered #-}

-- |Interpret 'Lock' as a reentrant lock, allowing nested calls to 'Polysemy.Conc.lock' unless called from a different
-- thread (as in, @async@ was called in a higher-order action passed to 'Polysemy.Conc.lock'.)
interpretLockReentrant ::
  Members [Resource, Race, Mask, Embed IO] r =>
  InterpreterFor Lock r
interpretLockReentrant :: forall (r :: EffectRow).
Members '[Resource, Race, Mask, Embed IO] r =>
InterpreterFor Lock r
interpretLockReentrant =
  () -> InterpreterFor (Sync ()) r
forall d (r :: EffectRow).
Members '[Race, Embed IO] r =>
d -> InterpreterFor (Sync d) r
interpretSyncAs () (Sem (Sync () : r) a -> Sem r a)
-> (Sem (Lock : r) a -> Sem (Sync () : r) a)
-> Sem (Lock : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (forall (rInitial :: EffectRow) x.
 Lock (Sem rInitial) x
 -> Tactical Lock (Sem rInitial) (Sync () : r) x)
-> Sem (Lock : r) a -> Sem (Sync () : r) a
forall (e1 :: Effect) (e2 :: Effect) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e1 (Sem rInitial) x -> Tactical e1 (Sem rInitial) (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpretH \case
    Lock Sem rInitial x
maI ->
      Sem rInitial x
-> (Sem (Lock : Sync () : r) (f x)
    -> Sem (Lock : Sync () : r) (f x))
-> Sem (WithTactics Lock f (Sem rInitial) (Sync () : r)) (f x)
forall (f :: * -> *) (m :: * -> *) (r :: EffectRow) a.
Members '[Sync (), Resource, Race, Mask, Embed IO] r =>
m a
-> (Sem (Lock : r) (f a) -> Sem (Lock : r) (f a))
-> Sem (WithTactics Lock f m r) (f a)
enter Sem rInitial x
maI (Sem (Lock : Sync () : r) (f x) -> Sem (Lock : Sync () : r) (f x)
forall (r :: EffectRow) a.
Members '[Sync (), Resource, Mask] r =>
Sem r a -> Sem r a
lockWait)
    LockOr Sem rInitial x
altI Sem rInitial x
maI -> do
      Sem (Lock : Sync () : r) (f x)
alt <- Sem rInitial x
-> Sem
     (WithTactics Lock f (Sem rInitial) (Sync () : r))
     (Sem (Lock : Sync () : r) (f x))
forall (m :: * -> *) a (e :: Effect) (f :: * -> *)
       (r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial x
altI
      Sem rInitial x
-> (Sem (Lock : Sync () : r) (f x)
    -> Sem (Lock : Sync () : r) (f x))
-> Sem (WithTactics Lock f (Sem rInitial) (Sync () : r)) (f x)
forall (f :: * -> *) (m :: * -> *) (r :: EffectRow) a.
Members '[Sync (), Resource, Race, Mask, Embed IO] r =>
m a
-> (Sem (Lock : r) (f a) -> Sem (Lock : r) (f a))
-> Sem (WithTactics Lock f m r) (f a)
enter Sem rInitial x
maI (Sem (Lock : Sync () : r) (f x)
-> Sem (Lock : Sync () : r) (f x) -> Sem (Lock : Sync () : r) (f x)
forall (r :: EffectRow) a.
Members '[Sync (), Resource, Mask] r =>
Sem r a -> Sem r a -> Sem r a
lockAlt Sem (Lock : Sync () : r) (f x)
alt)
{-# inline interpretLockReentrant #-}