-- |Description: Pure Queue interpreters
module Polysemy.Conc.Queue where

import Polysemy.AtomicState (atomicState')
import Polysemy.State (State, evalState, get, gets, put)

import qualified Polysemy.Conc.Data.Queue as Queue
import Polysemy.Conc.Data.Queue (Queue)
import qualified Polysemy.Conc.Data.QueueResult as QueueResult
import Polysemy.Conc.Data.QueueResult (QueueResult)

-- |Reinterpret 'Queue' as 'AtomicState' with a list that cannot be written to.
-- Useful for testing.
interpretQueueListReadOnlyAtomicWith ::
  ∀ d r .
  Member (AtomicState [d]) r =>
  InterpreterFor (Queue d) r
interpretQueueListReadOnlyAtomicWith :: InterpreterFor (Queue d) r
interpretQueueListReadOnlyAtomicWith =
  (forall x (rInitial :: EffectRow).
 Queue d (Sem rInitial) x -> Sem r x)
-> Sem (Queue 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
    Queue d (Sem rInitial) x
Queue.Read ->
      Sem r x
Sem r (QueueResult d)
read
    Queue d (Sem rInitial) x
Queue.TryRead ->
      Sem r x
Sem r (QueueResult d)
read
    Queue.ReadTimeout _ ->
      Sem r x
Sem r (QueueResult d)
read
    Queue d (Sem rInitial) x
Queue.Peek ->
      Sem r x
Sem r (QueueResult d)
peek
    Queue d (Sem rInitial) x
Queue.TryPeek ->
      Sem r x
Sem r (QueueResult d)
peek
    Queue.Write _ ->
      Sem r x
forall (f :: * -> *). Applicative f => f ()
pass
    Queue.TryWrite _ ->
      QueueResult () -> Sem r (QueueResult ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueueResult ()
forall d. QueueResult d
QueueResult.NotAvailable
    Queue.WriteTimeout _ _ ->
      QueueResult () -> Sem r (QueueResult ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueueResult ()
forall d. QueueResult d
QueueResult.NotAvailable
    Queue d (Sem rInitial) x
Queue.Closed ->
      ([d] -> Bool) -> Sem r Bool
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets @[d] [d] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
    Queue d (Sem rInitial) x
Queue.Close ->
      [d] -> Sem r ()
forall s (r :: EffectRow).
Member (AtomicState s) r =>
s -> Sem r ()
atomicPut @[d] []
  where
    read :: Sem r (QueueResult d)
    read :: Sem r (QueueResult d)
read =
      ([d] -> ([d], QueueResult d)) -> Sem r (QueueResult d)
forall s a (r :: EffectRow).
Member (AtomicState s) r =>
(s -> (s, a)) -> Sem r a
atomicState' @[d] \case
        [] -> ([], QueueResult d
forall d. QueueResult d
QueueResult.Closed)
        d
h : [d]
t -> ([d]
t, d -> QueueResult d
forall d. d -> QueueResult d
QueueResult.Success d
h)
    peek :: Sem r (QueueResult d)
    peek :: Sem r (QueueResult d)
peek =
      ([d] -> QueueResult d) -> Sem r (QueueResult d)
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets @[d] \case
        [] -> QueueResult d
forall d. QueueResult d
QueueResult.Closed
        d
h : [d]
_ -> d -> QueueResult d
forall d. d -> QueueResult d
QueueResult.Success d
h
{-# INLINE interpretQueueListReadOnlyAtomicWith #-}

-- |Variant of 'interpretQueueListReadOnlyAtomicWith' that interprets the 'AtomicState'.
interpretQueueListReadOnlyAtomic ::
  ∀ d r .
  Member (Embed IO) r =>
  [d] ->
  InterpreterFor (Queue d) r
interpretQueueListReadOnlyAtomic :: [d] -> InterpreterFor (Queue d) r
interpretQueueListReadOnlyAtomic [d]
ds Sem (Queue d : r) a
sem = do
  TVar [d]
tv <- [d] -> Sem r (TVar [d])
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO [d]
ds
  TVar [d] -> Sem (AtomicState [d] : r) a -> Sem r a
forall (r :: EffectRow) s a.
Member (Embed IO) r =>
TVar s -> Sem (AtomicState s : r) a -> Sem r a
runAtomicStateTVar TVar [d]
tv (Sem (Queue d : AtomicState [d] : r) a
-> Sem (AtomicState [d] : r) a
forall d (r :: EffectRow).
Member (AtomicState [d]) r =>
InterpreterFor (Queue d) r
interpretQueueListReadOnlyAtomicWith (Sem (Queue d : r) a -> Sem (Queue d : AtomicState [d] : r) a
forall (e2 :: Effect) (e1 :: Effect) (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder Sem (Queue d : r) a
sem))
{-# INLINE interpretQueueListReadOnlyAtomic #-}

-- |Reinterpret 'Queue' as 'State' with a list that cannot be written to.
-- Useful for testing.
interpretQueueListReadOnlyStateWith ::
  ∀ d r .
  Member (State [d]) r =>
  InterpreterFor (Queue d) r
interpretQueueListReadOnlyStateWith :: InterpreterFor (Queue d) r
interpretQueueListReadOnlyStateWith =
  (forall x (rInitial :: EffectRow).
 Queue d (Sem rInitial) x -> Sem r x)
-> Sem (Queue 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
    Queue d (Sem rInitial) x
Queue.Read ->
      Sem r x
Sem r (QueueResult d)
read
    Queue d (Sem rInitial) x
Queue.TryRead ->
      Sem r x
Sem r (QueueResult d)
read
    Queue.ReadTimeout _ ->
      Sem r x
Sem r (QueueResult d)
read
    Queue d (Sem rInitial) x
Queue.Peek ->
      Sem r x
Sem r (QueueResult d)
peek
    Queue d (Sem rInitial) x
Queue.TryPeek ->
      Sem r x
Sem r (QueueResult d)
peek
    Queue.Write _ ->
      Sem r x
forall (f :: * -> *). Applicative f => f ()
pass
    Queue.TryWrite _ ->
      QueueResult () -> Sem r (QueueResult ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueueResult ()
forall d. QueueResult d
QueueResult.NotAvailable
    Queue.WriteTimeout _ _ ->
      QueueResult () -> Sem r (QueueResult ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueueResult ()
forall d. QueueResult d
QueueResult.NotAvailable
    Queue d (Sem rInitial) x
Queue.Closed ->
      ([d] -> Bool) -> Sem r Bool
forall s a (r :: EffectRow).
Member (State s) r =>
(s -> a) -> Sem r a
gets @[d] [d] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
    Queue d (Sem rInitial) x
Queue.Close ->
      [d] -> Sem r ()
forall s (r :: EffectRow).
MemberWithError (State s) r =>
s -> Sem r ()
put @[d] []
  where
    read :: Sem r (QueueResult d)
    read :: Sem r (QueueResult d)
read =
      forall (r :: EffectRow). MemberWithError (State [d]) r => Sem r [d]
forall s (r :: EffectRow). MemberWithError (State s) r => Sem r s
get @[d] Sem r [d]
-> ([d] -> Sem r (QueueResult d)) -> Sem r (QueueResult d)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> QueueResult d -> Sem r (QueueResult d)
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueueResult d
forall d. QueueResult d
QueueResult.Closed
        d
h : [d]
t -> d -> QueueResult d
forall d. d -> QueueResult d
QueueResult.Success d
h QueueResult d -> Sem r () -> Sem r (QueueResult d)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [d] -> Sem r ()
forall s (r :: EffectRow).
MemberWithError (State s) r =>
s -> Sem r ()
put [d]
t
    peek :: Sem r (QueueResult d)
    peek :: Sem r (QueueResult d)
peek =
      ([d] -> QueueResult d) -> Sem r (QueueResult d)
forall s a (r :: EffectRow).
Member (State s) r =>
(s -> a) -> Sem r a
gets @[d] \case
        [] -> QueueResult d
forall d. QueueResult d
QueueResult.Closed
        d
h : [d]
_ -> d -> QueueResult d
forall d. d -> QueueResult d
QueueResult.Success d
h
{-# INLINE interpretQueueListReadOnlyStateWith #-}

-- |Variant of 'interpretQueueListReadOnlyAtomicWith' that interprets the 'State'.
interpretQueueListReadOnlyState ::
  ∀ d r .
  Member (Embed IO) r =>
  [d] ->
  InterpreterFor (Queue d) r
interpretQueueListReadOnlyState :: [d] -> InterpreterFor (Queue d) r
interpretQueueListReadOnlyState [d]
ds Sem (Queue d : r) a
sem = do
  [d] -> Sem (State [d] : r) a -> Sem r a
forall s (r :: EffectRow) a. s -> Sem (State s : r) a -> Sem r a
evalState [d]
ds (Sem (Queue d : State [d] : r) a -> Sem (State [d] : r) a
forall d (r :: EffectRow).
Member (State [d]) r =>
InterpreterFor (Queue d) r
interpretQueueListReadOnlyStateWith (Sem (Queue d : r) a -> Sem (Queue d : State [d] : r) a
forall (e2 :: Effect) (e1 :: Effect) (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder Sem (Queue d : r) a
sem))
{-# INLINE interpretQueueListReadOnlyState #-}