{-# LANGUAGE AllowAmbiguousTypes #-}

-- SPDX-License-Identifier: MPL-2.0

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

Interpreter for the t'Data.Effect.State.State' effect.
-}
module Control.Monad.Hefty.State (
    module Control.Monad.Hefty.State,
    module Data.Effect.State,
)
where

import Control.Monad.Hefty (
    Eff,
    FOEs,
    StateHandler,
    interposeStateBy,
    interpretBy,
    interpretStateBy,
    (&),
    (:>),
 )
import Data.Effect.State

-- | Interpret the 'State' effect.
runState :: forall s es a. (FOEs es) => s -> Eff (State s ': es) a -> Eff es (s, a)
runState :: forall s (es :: [Effect]) a.
FOEs es =>
s -> Eff (State s : es) a -> Eff es (s, a)
runState s
s0 = s
-> (s -> a -> Eff es (s, a))
-> StateHandler
     s (State s) (Eff (State s : es)) (Eff Freer es) (s, a)
-> Eff (State s : es) a
-> Eff es (s, a)
forall s (e :: Effect) (es :: [Effect]) ans a.
(KnownOrder e, FOEs es) =>
s
-> (s -> a -> Eff es ans)
-> StateHandler s e (Eff (e : es)) (Eff es) ans
-> Eff (e : es) a
-> Eff es ans
interpretStateBy s
s0 (((s, a) -> Eff es (s, a)) -> s -> a -> Eff es (s, a)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (s, a) -> Eff es (s, a)
forall a. a -> Eff Freer es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) State s (Eff (State s : es)) x
-> s -> (s -> x -> Eff es (s, a)) -> Eff es (s, a)
StateHandler s (State s) (Eff (State s : es)) (Eff Freer es) (s, a)
forall s (f :: * -> *) (g :: * -> *) ans x.
State s f x -> s -> (s -> x -> g ans) -> g ans
handleState
{-# INLINE runState #-}

-- | Interpret the 'State' effect. Do not include the final state in the return value.
evalState :: forall s es a. s -> (FOEs es) => Eff (State s ': es) a -> Eff es a
evalState :: forall s (es :: [Effect]) a.
s -> FOEs es => Eff (State s : es) a -> Eff es a
evalState s
s0 = s
-> (s -> a -> Eff es a)
-> StateHandler s (State s) (Eff (State s : es)) (Eff Freer es) a
-> Eff (State s : es) a
-> Eff es a
forall s (e :: Effect) (es :: [Effect]) ans a.
(KnownOrder e, FOEs es) =>
s
-> (s -> a -> Eff es ans)
-> StateHandler s e (Eff (e : es)) (Eff es) ans
-> Eff (e : es) a
-> Eff es ans
interpretStateBy s
s0 ((a -> Eff es a) -> s -> a -> Eff es a
forall a b. a -> b -> a
const a -> Eff es a
forall a. a -> Eff Freer es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) State s (Eff (State s : es)) x
-> s -> (s -> x -> Eff es a) -> Eff es a
StateHandler s (State s) (Eff (State s : es)) (Eff Freer es) a
forall s (f :: * -> *) (g :: * -> *) ans x.
State s f x -> s -> (s -> x -> g ans) -> g ans
handleState
{-# INLINE evalState #-}

-- | Interpret the 'State' effect. Do not include the final result in the return value.
execState :: forall s es a. (FOEs es) => s -> Eff (State s ': es) a -> Eff es s
execState :: forall s (es :: [Effect]) a.
FOEs es =>
s -> Eff (State s : es) a -> Eff es s
execState s
s0 = s
-> (s -> a -> Eff es s)
-> StateHandler s (State s) (Eff (State s : es)) (Eff Freer es) s
-> Eff (State s : es) a
-> Eff es s
forall s (e :: Effect) (es :: [Effect]) ans a.
(KnownOrder e, FOEs es) =>
s
-> (s -> a -> Eff es ans)
-> StateHandler s e (Eff (e : es)) (Eff es) ans
-> Eff (e : es) a
-> Eff es ans
interpretStateBy s
s0 (\s
s a
_ -> s -> Eff es s
forall a. a -> Eff Freer es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure s
s) State s (Eff (State s : es)) x
-> s -> (s -> x -> Eff es s) -> Eff es s
StateHandler s (State s) (Eff (State s : es)) (Eff Freer es) s
forall s (f :: * -> *) (g :: * -> *) ans x.
State s f x -> s -> (s -> x -> g ans) -> g ans
handleState
{-# INLINE execState #-}

-- | A handler function for the 'State' effect.
handleState :: StateHandler s (State s) f g ans
handleState :: forall s (f :: * -> *) (g :: * -> *) ans x.
State s f x -> s -> (s -> x -> g ans) -> g ans
handleState = \case
    Put s
s -> \s
_ s -> x -> g ans
k -> s -> x -> g ans
k s
s ()
    State s f x
Get -> \s
s s -> x -> g ans
k -> s -> x -> g ans
k s
s s
x
s
{-# INLINE handleState #-}

-- | Within the given scope, make the state roll back to the beginning of the scope in case of exceptions, etc.
transactState :: forall s es a. (State s :> es, FOEs es) => Eff es a -> Eff es a
transactState :: forall s (es :: [Effect]) a.
(State s :> es, FOEs es) =>
Eff es a -> Eff es a
transactState Eff es a
m = do
    s
pre <- forall s (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, State s :> es) =>
a s
get @s
    (s
post, a
a) <- s
-> (s -> a -> Eff es (s, a))
-> StateHandler s (State s) (Eff Freer es) (Eff Freer es) (s, a)
-> Eff es a
-> Eff es (s, a)
forall s (e :: Effect) (es :: [Effect]) ans a.
(e :> es, FOEs es) =>
s
-> (s -> a -> Eff es ans)
-> StateHandler s e (Eff es) (Eff es) ans
-> Eff es a
-> Eff es ans
interposeStateBy s
pre (((s, a) -> Eff es (s, a)) -> s -> a -> Eff es (s, a)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (s, a) -> Eff es (s, a)
forall a. a -> Eff Freer es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) State s (Eff Freer es) x
-> s -> (s -> x -> Eff es (s, a)) -> Eff es (s, a)
StateHandler s (State s) (Eff Freer es) (Eff Freer es) (s, a)
forall s (f :: * -> *) (g :: * -> *) ans x.
State s f x -> s -> (s -> x -> g ans) -> g ans
handleState Eff es a
m
    s -> Eff Freer es ()
forall s (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, State s :> es) =>
s -> a ()
put s
post
    a -> Eff es a
forall a. a -> Eff Freer es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
{-# INLINE transactState #-}

-- | A naive but somewhat slower version of 'runState' that does not use ad-hoc optimizations.
runStateNaive :: forall s es a. (FOEs es) => s -> Eff (State s ': es) a -> Eff es (s, a)
runStateNaive :: forall s (es :: [Effect]) a.
FOEs es =>
s -> Eff (State s : es) a -> Eff es (s, a)
runStateNaive s
s0 Eff (State s : es) a
m = do
    s -> Eff es (s, a)
f <-
        Eff (State s : es) a
m Eff (State s : es) a
-> (Eff (State s : es) a -> Eff Freer es (s -> Eff es (s, a)))
-> Eff Freer es (s -> Eff es (s, a))
forall a b. a -> (a -> b) -> b
& (a -> Eff Freer es (s -> Eff es (s, a)))
-> AlgHandler
     (State s) (Eff (State s : es)) (Eff Freer es) (s -> Eff es (s, a))
-> Eff (State s : es) a
-> Eff Freer es (s -> Eff es (s, a))
forall (e :: Effect) (es :: [Effect]) ans a.
(KnownOrder e, FOEs es) =>
(a -> Eff es ans)
-> AlgHandler e (Eff (e : es)) (Eff es) ans
-> Eff (e : es) a
-> Eff es ans
interpretBy (\a
a -> (s -> Eff es (s, a)) -> Eff Freer es (s -> Eff es (s, a))
forall a. a -> Eff Freer es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure \s
s -> (s, a) -> Eff es (s, a)
forall a. a -> Eff Freer es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s
s, a
a)) \case
            State s (Eff (State s : es)) x
Get -> \x -> Eff Freer es (s -> Eff es (s, a))
k -> (s -> Eff es (s, a)) -> Eff Freer es (s -> Eff es (s, a))
forall a. a -> Eff Freer es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure \s
s -> x -> Eff Freer es (s -> Eff es (s, a))
k s
x
s Eff Freer es (s -> Eff es (s, a))
-> ((s -> Eff es (s, a)) -> Eff es (s, a)) -> Eff es (s, a)
forall a b.
Eff Freer es a -> (a -> Eff Freer es b) -> Eff Freer es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((s -> Eff es (s, a)) -> s -> Eff es (s, a)
forall a b. (a -> b) -> a -> b
$ s
s)
            Put s
s -> \x -> Eff Freer es (s -> Eff es (s, a))
k -> (s -> Eff es (s, a)) -> Eff Freer es (s -> Eff es (s, a))
forall a. a -> Eff Freer es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure \s
_ -> x -> Eff Freer es (s -> Eff es (s, a))
k () Eff Freer es (s -> Eff es (s, a))
-> ((s -> Eff es (s, a)) -> Eff es (s, a)) -> Eff es (s, a)
forall a b.
Eff Freer es a -> (a -> Eff Freer es b) -> Eff Freer es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((s -> Eff es (s, a)) -> s -> Eff es (s, a)
forall a b. (a -> b) -> a -> b
$ s
s)
    s -> Eff es (s, a)
f s
s0
{-# INLINE runStateNaive #-}