-- SPDX-License-Identifier: MPL-2.0
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# HLINT ignore "Avoid lambda" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{- |
Copyright   :  (c) 2023-2025 Sayo contributors
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp

Effects for holding mutable state values in the context.
-}
module Data.Effect.State (
    module Data.Effect.State,
    State (..),
) where

import Data.Effect (Ask (Ask), Emb, Local (Local), State (Get, Put))
import Data.Functor ((<&>))
import UnliftIO (newIORef, readIORef, writeIORef)

makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''State

-- | Retrieves the current state value from the context and returns the value transformed based on the given function.
gets :: forall s es a ff c. (State s :> es, Functor (Eff ff es), Free c ff) => (s -> a) -> Eff ff es a
gets :: forall s (es :: [Effect]) a (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(State s :> es, Functor (Eff ff es), Free c ff) =>
(s -> a) -> Eff ff es a
gets s -> a
f = s -> a
f (s -> a) -> Eff ff es s -> Eff ff es a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff ff es s
forall s (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, State s :> es) =>
a s
get
{-# INLINE gets #-}

-- | Modifies the current state value in the context based on the given function.
modify :: forall s es ff c. (State s :> es, Monad (Eff ff es), Free c ff) => (s -> s) -> Eff ff es ()
modify :: forall s (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(State s :> es, Monad (Eff ff es), Free c ff) =>
(s -> s) -> Eff ff es ()
modify s -> s
f = s -> Eff ff es ()
forall s (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, State s :> es) =>
s -> a ()
put (s -> Eff ff es ()) -> (s -> s) -> s -> Eff ff es ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
f (s -> Eff ff es ()) -> Eff ff es s -> Eff ff es ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Eff ff es s
forall s (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, State s :> es) =>
a s
get
{-# INLINE modify #-}

-- | Interpret the 'State' effect based on an IO-fused semantics using t'Data.IORef.IORef'.
runStateIORef
    :: forall s es ff a c
     . (Emb IO :> es, Monad (Eff ff es), Free c ff)
    => s
    -> Eff ff (State s ': es) a
    -> Eff ff es (s, a)
runStateIORef :: forall s (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(Emb IO :> es, Monad (Eff ff es), Free c ff) =>
s -> Eff ff (State s : es) a -> Eff ff es (s, a)
runStateIORef s
s0 Eff ff (State s : es) a
m = do
    IORef s
ref <- s -> Eff ff es (IORef s)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef s
s0
    a
a <-
        Eff ff (State s : es) a
m Eff ff (State s : es) a
-> (Eff ff (State s : es) a -> Eff ff es a) -> Eff ff es a
forall a b. a -> (a -> b) -> b
& (State s ~~> Eff ff es) -> Eff ff (State s : es) a -> Eff ff es a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \case
            State s (Eff ff es) x
Get -> IORef x -> Eff ff es x
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef s
IORef x
ref
            Put s
s -> IORef s -> s -> Eff ff es ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef s
ref s
s
    IORef s -> Eff ff es s
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef s
ref Eff ff es s -> (s -> (s, a)) -> Eff ff es (s, a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (,a
a)
{-# INLINE runStateIORef #-}

{- |
Interpret the 'State' effect based on an IO-fused semantics using t'Data.IORef.IORef'.
Do not include the final state in the return value.
-}
evalStateIORef
    :: forall s es ff a c
     . (Emb IO :> es, Monad (Eff ff es), Free c ff)
    => s
    -> Eff ff (State s ': es) a
    -> Eff ff es a
evalStateIORef :: forall s (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(Emb IO :> es, Monad (Eff ff es), Free c ff) =>
s -> Eff ff (State s : es) a -> Eff ff es a
evalStateIORef s
s0 Eff ff (State s : es) a
m = do
    IORef s
ref <- s -> Eff ff es (IORef s)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef s
s0
    Eff ff (State s : es) a
m Eff ff (State s : es) a
-> (Eff ff (State s : es) a -> Eff ff es a) -> Eff ff es a
forall a b. a -> (a -> b) -> b
& (State s ~~> Eff ff es) -> Eff ff (State s : es) a -> Eff ff es a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \case
        State s (Eff ff es) x
Get -> IORef x -> Eff ff es x
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef s
IORef x
ref
        Put s
s -> IORef s -> s -> Eff ff es ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef s
ref s
s
{-# INLINE evalStateIORef #-}

execStateIORef
    :: forall s es ff a c
     . (Emb IO :> es, Monad (Eff ff es), Free c ff)
    => s
    -> Eff ff (State s ': es) a
    -> Eff ff es s
execStateIORef :: forall s (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(Emb IO :> es, Monad (Eff ff es), Free c ff) =>
s -> Eff ff (State s : es) a -> Eff ff es s
execStateIORef s
s0 = ((s, a) -> s) -> Eff ff es (s, a) -> Eff ff es s
forall a b. (a -> b) -> Eff ff es a -> Eff ff es b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s, a) -> s
forall a b. (a, b) -> a
fst (Eff ff es (s, a) -> Eff ff es s)
-> (Eff ff (State s : es) a -> Eff ff es (s, a))
-> Eff ff (State s : es) a
-> Eff ff es s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Eff ff (State s : es) a -> Eff ff es (s, a)
forall s (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(Emb IO :> es, Monad (Eff ff es), Free c ff) =>
s -> Eff ff (State s : es) a -> Eff ff es (s, a)
runStateIORef s
s0
{-# INLINE execStateIORef #-}

localToState
    :: forall r es ff a c
     . (State r `In` es, Monad (Eff ff es), Free c ff)
    => Eff ff (Local r ': es) a
    -> Eff ff es a
localToState :: forall r (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(In (State r) es, Monad (Eff ff es), Free c ff) =>
Eff ff (Local r : es) a -> Eff ff es a
localToState =
    (Local r ~~> Eff ff es) -> Eff ff (Local r : es) a -> Eff ff es a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \(Local r -> r
f Eff ff es x
a) -> do
        r
save <- forall s (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, In (State s) es) =>
a s
get'_ @r
        r -> Eff ff es ()
forall s (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, In (State s) es) =>
s -> a ()
put'_ (r -> Eff ff es ()) -> r -> Eff ff es ()
forall a b. (a -> b) -> a -> b
$ r -> r
f r
save
        Eff ff es x
a Eff ff es x -> Eff ff es () -> Eff ff es x
forall a b. Eff ff es a -> Eff ff es b -> Eff ff es a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* r -> Eff ff es ()
forall s (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, In (State s) es) =>
s -> a ()
put'_ r
save
{-# INLINE localToState #-}

askToGet
    :: forall r es ff a c
     . (State r `In` es, Free c ff)
    => Eff ff (Ask r ': es) a
    -> Eff ff es a
askToGet :: forall r (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(In (State r) es, Free c ff) =>
Eff ff (Ask r : es) a -> Eff ff es a
askToGet = (Ask r ~~> Eff ff es) -> Eff ff (Ask r : es) a -> Eff ff es a
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \Ask r (Eff ff es) x
Ask -> Eff ff es x
forall s (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, In (State s) es) =>
a s
get'_
{-# INLINE askToGet #-}