-- | Support for access to a shared, mutable value of a particular type.
--
-- The value is shared between multiple threads. If you want each thead to
-- manage its own version of the value, use "Effectful.State.Static.Local".
--
-- /Note:/ unlike the 'Control.Monad.Trans.State.StateT' monad transformer from
-- the @transformers@ library, the 'State' effect doesn't discard state updates
-- when an exception is received:
--
-- >>> import Control.Monad.Trans.State.Strict qualified as S
--
-- >>> :{
--   (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do
--     S.modify (++ " there!")
--     error "oops"
-- :}
-- "Hi"
--
-- >>> :{
--   runEff . execState "Hi" . handle (\(_::ErrorCall) -> pure ()) $ do
--     modify (++ " there!")
--     error "oops"
-- :}
-- "Hi there!"
module Effectful.State.Static.Shared
  ( -- * Effect
    State

    -- ** Handlers
  , runState
  , evalState
  , execState

  , runStateMVar
  , evalStateMVar
  , execStateMVar

    -- ** Operations
  , get
  , gets
  , put
  , state
  , modify
  , stateM
  , modifyM
  ) where

import Control.Concurrent.MVar.Strict
import Data.Kind

import Effectful
import Effectful.Dispatch.Static
import Effectful.Dispatch.Static.Primitive

-- | Provide access to a strict (WHNF), shared, mutable value of type @s@.
data State (s :: Type) :: Effect

type instance DispatchOf (State s) = Static NoSideEffects
newtype instance StaticRep (State s) = State (MVar' s)

-- | Run the 'State' effect with the given initial state and return the final
-- value along with the final state.
runState :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s)
runState :: forall s (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es (a, s)
runState s
s Eff (State s : es) a
m = do
  MVar' s
v <- IO (MVar' s) -> Eff es (MVar' s)
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (IO (MVar' s) -> Eff es (MVar' s))
-> IO (MVar' s) -> Eff es (MVar' s)
forall a b. (a -> b) -> a -> b
$ s -> IO (MVar' s)
forall a. a -> IO (MVar' a)
newMVar' s
s
  a
a <- StaticRep (State s) -> Eff (State s : es) a -> Eff es a
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (MVar' s -> StaticRep (State s)
forall s. MVar' s -> StaticRep (State s)
State MVar' s
v) Eff (State s : es) a
m
  (a
a, ) (s -> (a, s)) -> Eff es s -> Eff es (a, s)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO s -> Eff es s
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (MVar' s -> IO s
forall a. MVar' a -> IO a
readMVar' MVar' s
v)

-- | Run the 'State' effect with the given initial state and return the final
-- value, discarding the final state.
evalState :: HasCallStack => s -> Eff (State s : es) a -> Eff es a
evalState :: forall s (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es a
evalState s
s Eff (State s : es) a
m = do
  MVar' s
v <- IO (MVar' s) -> Eff es (MVar' s)
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (IO (MVar' s) -> Eff es (MVar' s))
-> IO (MVar' s) -> Eff es (MVar' s)
forall a b. (a -> b) -> a -> b
$ s -> IO (MVar' s)
forall a. a -> IO (MVar' a)
newMVar' s
s
  StaticRep (State s) -> Eff (State s : es) a -> Eff es a
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (MVar' s -> StaticRep (State s)
forall s. MVar' s -> StaticRep (State s)
State MVar' s
v) Eff (State s : es) a
m

-- | Run the 'State' effect with the given initial state and return the final
-- state, discarding the final value.
execState :: HasCallStack => s -> Eff (State s : es) a -> Eff es s
execState :: forall s (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
s -> Eff (State s : es) a -> Eff es s
execState s
s Eff (State s : es) a
m = do
  MVar' s
v <- IO (MVar' s) -> Eff es (MVar' s)
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (IO (MVar' s) -> Eff es (MVar' s))
-> IO (MVar' s) -> Eff es (MVar' s)
forall a b. (a -> b) -> a -> b
$ s -> IO (MVar' s)
forall a. a -> IO (MVar' a)
newMVar' s
s
  a
_ <- StaticRep (State s) -> Eff (State s : es) a -> Eff es a
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (MVar' s -> StaticRep (State s)
forall s. MVar' s -> StaticRep (State s)
State MVar' s
v) Eff (State s : es) a
m
  IO s -> Eff es s
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (IO s -> Eff es s) -> IO s -> Eff es s
forall a b. (a -> b) -> a -> b
$ MVar' s -> IO s
forall a. MVar' a -> IO a
readMVar' MVar' s
v

-- | Run the 'State' effect with the given initial state 'MVar'' and return the
-- final value along with the final state.
runStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es (a, s)
runStateMVar :: forall s (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
MVar' s -> Eff (State s : es) a -> Eff es (a, s)
runStateMVar MVar' s
v Eff (State s : es) a
m = do
  a
a <- StaticRep (State s) -> Eff (State s : es) a -> Eff es a
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (MVar' s -> StaticRep (State s)
forall s. MVar' s -> StaticRep (State s)
State MVar' s
v) Eff (State s : es) a
m
  (a
a, ) (s -> (a, s)) -> Eff es s -> Eff es (a, s)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO s -> Eff es s
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (MVar' s -> IO s
forall a. MVar' a -> IO a
readMVar' MVar' s
v)

-- | Run the 'State' effect with the given initial state 'MVar'' and return the
-- final value, discarding the final state.
evalStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es a
evalStateMVar :: forall s (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
MVar' s -> Eff (State s : es) a -> Eff es a
evalStateMVar MVar' s
v = StaticRep (State s) -> Eff (State s : es) a -> Eff es a
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (MVar' s -> StaticRep (State s)
forall s. MVar' s -> StaticRep (State s)
State MVar' s
v)

-- | Run the 'State' effect with the given initial state 'MVar'' and return the
-- final state, discarding the final value.
execStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es s
execStateMVar :: forall s (es :: [(Type -> Type) -> Type -> Type]) a.
HasCallStack =>
MVar' s -> Eff (State s : es) a -> Eff es s
execStateMVar MVar' s
v Eff (State s : es) a
m = do
  a
_ <- StaticRep (State s) -> Eff (State s : es) a -> Eff es a
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (MVar' s -> StaticRep (State s)
forall s. MVar' s -> StaticRep (State s)
State MVar' s
v) Eff (State s : es) a
m
  IO s -> Eff es s
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (IO s -> Eff es s) -> IO s -> Eff es s
forall a b. (a -> b) -> a -> b
$ MVar' s -> IO s
forall a. MVar' a -> IO a
readMVar' MVar' s
v

-- | Fetch the current value of the state.
get :: (HasCallStack, State s :> es) => Eff es s
get :: forall s (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, State s :> es) =>
Eff es s
get = (Env es -> IO s) -> Eff es s
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO s) -> Eff es s) -> (Env es -> IO s) -> Eff es s
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  State MVar' s
v <- Env es -> IO (EffectRep (DispatchOf (State s)) (State s))
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env es
es
  MVar' s -> IO s
forall a. MVar' a -> IO a
readMVar' MVar' s
v

-- | Get a function of the current state.
--
-- @'gets' f ≡ f '<$>' 'get'@
gets :: (HasCallStack, State s :> es) => (s -> a) -> Eff es a
gets :: forall s (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, State s :> es) =>
(s -> a) -> Eff es a
gets s -> a
f = s -> a
f (s -> a) -> Eff es s -> Eff es a
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff es s
forall s (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, State s :> es) =>
Eff es s
get

-- | Set the current state to the given value.
put :: (HasCallStack, State s :> es) => s -> Eff es ()
put :: forall s (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, State s :> es) =>
s -> Eff es ()
put s
s = (Env es -> IO ()) -> Eff es ()
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO ()) -> Eff es ()) -> (Env es -> IO ()) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  State MVar' s
v <- Env es -> IO (EffectRep (DispatchOf (State s)) (State s))
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env es
es
  MVar' s -> (s -> IO s) -> IO ()
forall a. MVar' a -> (a -> IO a) -> IO ()
modifyMVar'_ MVar' s
v ((s -> IO s) -> IO ()) -> (s -> IO s) -> IO ()
forall a b. (a -> b) -> a -> b
$ \s
_ -> s -> IO s
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure s
s

-- | Apply the function to the current state and return a value.
--
-- /Note:/ this function gets an exclusive access to the state for its duration.
state :: (HasCallStack, State s :> es) => (s -> (a, s)) -> Eff es a
state :: forall s (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, State s :> es) =>
(s -> (a, s)) -> Eff es a
state s -> (a, s)
f = (Env es -> IO a) -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO a) -> Eff es a) -> (Env es -> IO a) -> Eff es a
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  State MVar' s
v <- Env es -> IO (EffectRep (DispatchOf (State s)) (State s))
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env es
es
  MVar' s -> (s -> IO (s, a)) -> IO a
forall a b. MVar' a -> (a -> IO (a, b)) -> IO b
modifyMVar' MVar' s
v ((s -> IO (s, a)) -> IO a) -> (s -> IO (s, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \s
s0 -> let (a
a, s
s) = s -> (a, s)
f s
s0 in (s, a) -> IO (s, a)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (s
s, a
a)

-- | Apply the function to the current state.
--
-- @'modify' f ≡ 'state' (\\s -> ((), f s))@
--
-- /Note:/ this function gets an exclusive access to the state for its duration.
modify :: (HasCallStack, State s :> es) => (s -> s) -> Eff es ()
modify :: forall s (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, State s :> es) =>
(s -> s) -> Eff es ()
modify s -> s
f = (s -> ((), s)) -> Eff es ()
forall s (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, State s :> es) =>
(s -> (a, s)) -> Eff es a
state (\s
s -> ((), s -> s
f s
s))

-- | Apply the monadic function to the current state and return a value.
--
-- /Note:/ this function gets an exclusive access to the state for its duration.
stateM :: (HasCallStack, State s :> es) => (s -> Eff es (a, s)) -> Eff es a
stateM :: forall s (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, State s :> es) =>
(s -> Eff es (a, s)) -> Eff es a
stateM s -> Eff es (a, s)
f = (Env es -> IO a) -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO a) -> Eff es a) -> (Env es -> IO a) -> Eff es a
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  State MVar' s
v <- Env es -> IO (EffectRep (DispatchOf (State s)) (State s))
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env es
es
  MVar' s -> (s -> IO (s, a)) -> IO a
forall a b. MVar' a -> (a -> IO (a, b)) -> IO b
modifyMVar' MVar' s
v ((s -> IO (s, a)) -> IO a) -> (s -> IO (s, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \s
s0 -> do
    (a
a, s
s) <- Eff es (a, s) -> Env es -> IO (a, s)
forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff es a -> Env es -> IO a
unEff (s -> Eff es (a, s)
f s
s0) Env es
es
    (s, a) -> IO (s, a)
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (s
s, a
a)

-- | Apply the monadic function to the current state.
--
-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@
--
-- /Note:/ this function gets an exclusive access to the state for its duration.
modifyM :: (HasCallStack, State s :> es) => (s -> Eff es s) -> Eff es ()
modifyM :: forall s (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, State s :> es) =>
(s -> Eff es s) -> Eff es ()
modifyM s -> Eff es s
f = (s -> Eff es ((), s)) -> Eff es ()
forall s (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, State s :> es) =>
(s -> Eff es (a, s)) -> Eff es a
stateM (\s
s -> ((), ) (s -> ((), s)) -> Eff es s -> Eff es ((), s)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> Eff es s
f s
s)

-- $setup
-- >>> import Effectful.Exception