{-# LANGUAGE CPP #-}
module Control.Effect.AtomicState
(
AtomicState(..)
, atomicState
, atomicState'
, atomicGet
, atomicGets
, atomicModify
, atomicModify'
, atomicPut
, atomicStateToIO
, runAtomicStateIORef
, runAtomicStateTVar
, atomicStateToState
, atomicStateToIOSimple
, runAtomicStateIORefSimple
, runAtomicStateTVarSimple
, AtomicStateToStateC
) where
import Data.IORef
import Control.Concurrent.STM
import Control.Effect
import Control.Effect.State
#if MIN_VERSION_base(4,13,0)
import GHC.IORef (atomicModifyIORefP)
#else
data Box a = Box a
atomicModifyIORefP :: IORef s -> (s -> (s, a)) -> IO a
atomicModifyIORefP ref f = do
Box a <- atomicModifyIORef ref $ \s -> let !(s', a) = f s in (s', Box a)
return a
{-# INLINE atomicModifyIORefP #-}
#endif
data AtomicState s :: Effect where
AtomicState :: (s -> (s, a)) -> AtomicState s m a
AtomicGet :: AtomicState s m s
atomicState :: Eff (AtomicState s) m => (s -> (s, a)) -> m a
atomicState :: (s -> (s, a)) -> m a
atomicState = AtomicState s m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (AtomicState s m a -> m a)
-> ((s -> (s, a)) -> AtomicState s m a) -> (s -> (s, a)) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> (s, a)) -> AtomicState s m a
forall s a (m :: * -> *). (s -> (s, a)) -> AtomicState s m a
AtomicState
{-# INLINE atomicState #-}
atomicState' :: Eff (AtomicState s) m => (s -> (s, a)) -> m a
atomicState' :: (s -> (s, a)) -> m a
atomicState' s -> (s, a)
f = (s -> (s, a)) -> m a
forall s (m :: * -> *) a.
Eff (AtomicState s) m =>
(s -> (s, a)) -> m a
atomicState ((s -> (s, a)) -> m a) -> (s -> (s, a)) -> m a
forall a b. (a -> b) -> a -> b
$ \s
s -> let (!s
s', a
a) = s -> (s, a)
f s
s in (s
s', a
a)
{-# INLINE atomicState' #-}
atomicGet :: Eff (AtomicState s) m => m s
atomicGet :: m s
atomicGet = AtomicState s m s -> m s
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send AtomicState s m s
forall s (m :: * -> *). AtomicState s m s
AtomicGet
{-# INLINE atomicGet #-}
atomicGets :: Eff (AtomicState s) m => (s -> a) -> m a
atomicGets :: (s -> a) -> m a
atomicGets = ((s -> a) -> m s -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s
forall s (m :: * -> *). Eff (AtomicState s) m => m s
atomicGet)
{-# INLINE atomicGets #-}
atomicModify :: Eff (AtomicState s) m => (s -> s) -> m ()
atomicModify :: (s -> s) -> m ()
atomicModify s -> s
f = (s -> (s, ())) -> m ()
forall s (m :: * -> *) a.
Eff (AtomicState s) m =>
(s -> (s, a)) -> m a
atomicState ((s -> (s, ())) -> m ()) -> (s -> (s, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \s
s -> (s -> s
f s
s, ())
{-# INLINE atomicModify #-}
atomicModify' :: Eff (AtomicState s) m => (s -> s) -> m ()
atomicModify' :: (s -> s) -> m ()
atomicModify' s -> s
f = (s -> (s, ())) -> m ()
forall s (m :: * -> *) a.
Eff (AtomicState s) m =>
(s -> (s, a)) -> m a
atomicState ((s -> (s, ())) -> m ()) -> (s -> (s, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \s
s -> let !s' :: s
s' = s -> s
f s
s in (s
s', ())
{-# INLINE atomicModify' #-}
atomicPut :: Eff (AtomicState s) m => s -> m ()
atomicPut :: s -> m ()
atomicPut s
s = (s -> (s, ())) -> m ()
forall s (m :: * -> *) a.
Eff (AtomicState s) m =>
(s -> (s, a)) -> m a
atomicState ((s -> (s, ())) -> m ()) -> (s -> (s, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \s
_ -> (s
s, ())
{-# INLINE atomicPut #-}
atomicStateToIO :: forall s m a
. Eff (Embed IO) m
=> s
-> InterpretReifiedC (AtomicState s) m a
-> m (s, a)
atomicStateToIO :: s -> InterpretReifiedC (AtomicState s) m a -> m (s, a)
atomicStateToIO s
sInit InterpretReifiedC (AtomicState s) m a
main = do
IORef s
ref <- IO (IORef s) -> m (IORef s)
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO (IORef s) -> m (IORef s)) -> IO (IORef s) -> m (IORef s)
forall a b. (a -> b) -> a -> b
$ s -> IO (IORef s)
forall a. a -> IO (IORef a)
newIORef s
sInit
a
a <- IORef s -> InterpretReifiedC (AtomicState s) m a -> m a
forall s (m :: * -> *) a.
Eff (Embed IO) m =>
IORef s -> InterpretReifiedC (AtomicState s) m a -> m a
runAtomicStateIORef IORef s
ref InterpretReifiedC (AtomicState s) m a
main
s
sEnd <- IO s -> m s
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO s -> m s) -> IO s -> m s
forall a b. (a -> b) -> a -> b
$ IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref
(s, a) -> m (s, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
sEnd, a
a)
{-# INLINE atomicStateToIO #-}
atomicStateToIOSimple :: forall s m a p
. ( Eff (Embed IO) m
, Threaders '[ReaderThreads] m p
)
=> s
-> InterpretSimpleC (AtomicState s) m a
-> m (s, a)
atomicStateToIOSimple :: s -> InterpretSimpleC (AtomicState s) m a -> m (s, a)
atomicStateToIOSimple s
sInit InterpretSimpleC (AtomicState s) m a
main = do
IORef s
ref <- IO (IORef s) -> m (IORef s)
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO (IORef s) -> m (IORef s)) -> IO (IORef s) -> m (IORef s)
forall a b. (a -> b) -> a -> b
$ s -> IO (IORef s)
forall a. a -> IO (IORef a)
newIORef s
sInit
a
a <- IORef s -> InterpretSimpleC (AtomicState s) m a -> m a
forall s (m :: * -> *) a (p :: [Effect]).
(Eff (Embed IO) m, Threaders '[ReaderThreads] m p) =>
IORef s -> InterpretSimpleC (AtomicState s) m a -> m a
runAtomicStateIORefSimple IORef s
ref InterpretSimpleC (AtomicState s) m a
main
s
sEnd <- IO s -> m s
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO s -> m s) -> IO s -> m s
forall a b. (a -> b) -> a -> b
$ IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref
(s, a) -> m (s, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
sEnd, a
a)
{-# INLINE atomicStateToIOSimple #-}
runAtomicStateIORef :: forall s m a
. Eff (Embed IO) m
=> IORef s
-> InterpretReifiedC (AtomicState s) m a
-> m a
runAtomicStateIORef :: IORef s -> InterpretReifiedC (AtomicState s) m a -> m a
runAtomicStateIORef IORef s
ref = EffHandler (AtomicState s) m
-> InterpretReifiedC (AtomicState s) m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret (EffHandler (AtomicState s) m
-> InterpretReifiedC (AtomicState s) m a -> m a)
-> EffHandler (AtomicState s) m
-> InterpretReifiedC (AtomicState s) m a
-> m a
forall a b. (a -> b) -> a -> b
$ \case
AtomicState f -> IO x -> Effly z x
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IORef s -> (s -> (s, x)) -> IO x
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORefP IORef s
ref s -> (s, x)
f)
AtomicState s (Effly z) x
AtomicGet -> IO s -> Effly z s
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref)
{-# INLINE runAtomicStateIORef #-}
runAtomicStateIORefSimple :: forall s m a p
. ( Eff (Embed IO) m
, Threaders '[ReaderThreads] m p
)
=> IORef s
-> InterpretSimpleC (AtomicState s) m a
-> m a
runAtomicStateIORefSimple :: IORef s -> InterpretSimpleC (AtomicState s) m a -> m a
runAtomicStateIORefSimple IORef s
ref = EffHandler (AtomicState s) m
-> InterpretSimpleC (AtomicState s) m a -> m a
forall (e :: Effect) (m :: * -> *) a (p :: [Effect]).
(RepresentationalEff e, Threaders '[ReaderThreads] m p,
Carrier m) =>
EffHandler e m -> InterpretSimpleC e m a -> m a
interpretSimple (EffHandler (AtomicState s) m
-> InterpretSimpleC (AtomicState s) m a -> m a)
-> EffHandler (AtomicState s) m
-> InterpretSimpleC (AtomicState s) m a
-> m a
forall a b. (a -> b) -> a -> b
$ \case
AtomicState f -> IO x -> Effly z x
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IORef s -> (s -> (s, x)) -> IO x
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORefP IORef s
ref s -> (s, x)
f)
AtomicState s (Effly z) x
AtomicGet -> IO s -> Effly z s
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref)
{-# INLINE runAtomicStateIORefSimple #-}
runAtomicStateTVar :: forall s m a
. Eff (Embed IO) m
=> TVar s
-> InterpretReifiedC (AtomicState s) m a
-> m a
runAtomicStateTVar :: TVar s -> InterpretReifiedC (AtomicState s) m a -> m a
runAtomicStateTVar TVar s
tvar = EffHandler (AtomicState s) m
-> InterpretReifiedC (AtomicState s) m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret (EffHandler (AtomicState s) m
-> InterpretReifiedC (AtomicState s) m a -> m a)
-> EffHandler (AtomicState s) m
-> InterpretReifiedC (AtomicState s) m a
-> m a
forall a b. (a -> b) -> a -> b
$ \case
AtomicState f -> IO x -> Effly z x
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO x -> Effly z x) -> IO x -> Effly z x
forall a b. (a -> b) -> a -> b
$ STM x -> IO x
forall a. STM a -> IO a
atomically (STM x -> IO x) -> STM x -> IO x
forall a b. (a -> b) -> a -> b
$ do
(s
s, x
a) <- s -> (s, x)
f (s -> (s, x)) -> STM s -> STM (s, x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar s -> STM s
forall a. TVar a -> STM a
readTVar TVar s
tvar
TVar s -> s -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar s
tvar s
s
x -> STM x
forall (m :: * -> *) a. Monad m => a -> m a
return x
a
AtomicState s (Effly z) x
AtomicGet -> IO s -> Effly z s
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (TVar s -> IO s
forall a. TVar a -> IO a
readTVarIO TVar s
tvar)
{-# INLINE runAtomicStateTVar #-}
runAtomicStateTVarSimple :: forall s m a p
. ( Eff (Embed IO) m
, Threaders '[ReaderThreads] m p
)
=> TVar s
-> InterpretSimpleC (AtomicState s) m a
-> m a
runAtomicStateTVarSimple :: TVar s -> InterpretSimpleC (AtomicState s) m a -> m a
runAtomicStateTVarSimple TVar s
tvar = EffHandler (AtomicState s) m
-> InterpretSimpleC (AtomicState s) m a -> m a
forall (e :: Effect) (m :: * -> *) a (p :: [Effect]).
(RepresentationalEff e, Threaders '[ReaderThreads] m p,
Carrier m) =>
EffHandler e m -> InterpretSimpleC e m a -> m a
interpretSimple (EffHandler (AtomicState s) m
-> InterpretSimpleC (AtomicState s) m a -> m a)
-> EffHandler (AtomicState s) m
-> InterpretSimpleC (AtomicState s) m a
-> m a
forall a b. (a -> b) -> a -> b
$ \case
AtomicState f -> IO x -> Effly z x
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (IO x -> Effly z x) -> IO x -> Effly z x
forall a b. (a -> b) -> a -> b
$ STM x -> IO x
forall a. STM a -> IO a
atomically (STM x -> IO x) -> STM x -> IO x
forall a b. (a -> b) -> a -> b
$ do
(s
s, x
a) <- s -> (s, x)
f (s -> (s, x)) -> STM s -> STM (s, x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar s -> STM s
forall a. TVar a -> STM a
readTVar TVar s
tvar
TVar s -> s -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar s
tvar s
s
x -> STM x
forall (m :: * -> *) a. Monad m => a -> m a
return x
a
AtomicState s (Effly z) x
AtomicGet -> IO s -> Effly z s
forall (b :: * -> *) (m :: * -> *) a. Eff (Embed b) m => b a -> m a
embed (TVar s -> IO s
forall a. TVar a -> IO a
readTVarIO TVar s
tvar)
{-# INLINE runAtomicStateTVarSimple #-}
data AtomicStateToStateH
type AtomicStateToStateC s = InterpretC AtomicStateToStateH (AtomicState s)
instance Eff (State s) m
=> Handler AtomicStateToStateH (AtomicState s) m where
effHandler :: AtomicState s (Effly z) x -> Effly z x
effHandler = \case
AtomicState s -> (s, x)
f -> (s -> (s, x)) -> Effly z x
forall s (m :: * -> *) a. Eff (State s) m => (s -> (s, a)) -> m a
state s -> (s, x)
f
AtomicState s (Effly z) x
AtomicGet -> Effly z x
forall s (m :: * -> *). Eff (State s) m => m s
get
{-# INLINEABLE effHandler #-}
atomicStateToState :: Eff (State s) m
=> AtomicStateToStateC s m a
-> m a
atomicStateToState :: AtomicStateToStateC s m a -> m a
atomicStateToState = AtomicStateToStateC s m a -> m a
forall h (e :: Effect) (m :: * -> *) a.
Handler h e m =>
InterpretC h e m a -> m a
interpretViaHandler
{-# INLINE atomicStateToState #-}