-- |Description: Interpreters for 'DataLog' that write to 'AtomicState'.
module Polysemy.Log.Atomic where

import Control.Concurrent.STM (newTVarIO)

import Polysemy.Log.Effect.DataLog (DataLog)
import Polysemy.Log.Effect.Log (Log (Log))
import Polysemy.Log.Data.LogMessage (LogMessage)
import Polysemy.Log.Log (interpretDataLog)

-- |Interpret 'DataLog' by prepending each message to a list in an 'AtomicState'.
interpretDataLogAtomic' ::
  ∀ a r .
  Member (AtomicState [a]) r =>
  InterpreterFor (DataLog a) r
interpretDataLogAtomic' :: forall a (r :: EffectRow).
Member (AtomicState [a]) r =>
InterpreterFor (DataLog a) r
interpretDataLogAtomic' =
  (a -> Sem r ()) -> InterpreterFor (DataLog a) r
forall a (r :: EffectRow).
(a -> Sem r ()) -> InterpreterFor (DataLog a) r
interpretDataLog \ a
msg -> forall s (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' @[a] (a
msg a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)
{-# inline interpretDataLogAtomic' #-}

-- |Interpret 'DataLog' by prepending each message to a list in an 'AtomicState', then interpret the 'AtomicState' in a
-- 'Control.Concurrent.STM.TVar'.
interpretDataLogAtomic ::
  ∀ a r .
  Member (Embed IO) r =>
  InterpretersFor [DataLog a, AtomicState [a]] r
interpretDataLogAtomic :: forall a (r :: EffectRow).
Member (Embed IO) r =>
InterpretersFor '[DataLog a, AtomicState [a]] r
interpretDataLogAtomic Sem (Append '[DataLog a, AtomicState [a]] r) a
sem = do
  TVar [a]
tv <- IO (TVar [a]) -> Sem r (TVar [a])
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed ([a] -> IO (TVar [a])
forall a. a -> IO (TVar a)
newTVarIO [])
  TVar [a] -> Sem (AtomicState [a] : 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 [a]
tv (Sem (DataLog a : AtomicState [a] : r) a
-> Sem (AtomicState [a] : r) a
forall a (r :: EffectRow).
Member (AtomicState [a]) r =>
InterpreterFor (DataLog a) r
interpretDataLogAtomic' Sem (DataLog a : AtomicState [a] : r) a
Sem (Append '[DataLog a, AtomicState [a]] r) a
sem)
{-# inline interpretDataLogAtomic #-}

-- |Interpret 'Log' by prepending each message to a list in an 'AtomicState'.
interpretLogAtomic' ::
  Member (AtomicState [LogMessage]) r =>
  InterpreterFor Log r
interpretLogAtomic' :: forall (r :: EffectRow).
Member (AtomicState [LogMessage]) r =>
InterpreterFor Log r
interpretLogAtomic' =
  (forall (rInitial :: EffectRow) x. Log (Sem rInitial) x -> Sem r x)
-> Sem (Log : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Log LogMessage
msg -> ([LogMessage] -> [LogMessage]) -> Sem r ()
forall s (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' (LogMessage
msg LogMessage -> [LogMessage] -> [LogMessage]
forall a. a -> [a] -> [a]
:)
{-# inline interpretLogAtomic' #-}

-- |Interpret 'Log' by prepending each message to a list in an 'AtomicState', then interpret the 'AtomicState' in a
-- 'Control.Concurrent.STM.TVar'.
interpretLogAtomic ::
  Member (Embed IO) r =>
  InterpretersFor [Log, AtomicState [LogMessage]] r
interpretLogAtomic :: forall (r :: EffectRow).
Member (Embed IO) r =>
InterpretersFor '[Log, AtomicState [LogMessage]] r
interpretLogAtomic Sem (Append '[Log, AtomicState [LogMessage]] r) a
sem = do
  TVar [LogMessage]
tv <- IO (TVar [LogMessage]) -> Sem r (TVar [LogMessage])
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed ([LogMessage] -> IO (TVar [LogMessage])
forall a. a -> IO (TVar a)
newTVarIO [])
  TVar [LogMessage]
-> Sem (AtomicState [LogMessage] : 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 [LogMessage]
tv (Sem (Log : AtomicState [LogMessage] : r) a
-> Sem (AtomicState [LogMessage] : r) a
forall (r :: EffectRow).
Member (AtomicState [LogMessage]) r =>
InterpreterFor Log r
interpretLogAtomic' Sem (Log : AtomicState [LogMessage] : r) a
Sem (Append '[Log, AtomicState [LogMessage]] r) a
sem)
{-# inline interpretLogAtomic #-}