-- SPDX-License-Identifier: MPL-2.0 AND BSD-3-Clause

{- |
Copyright   :  (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King; 2024 Sayo contributors
License     :  MPL-2.0 AND BSD-3-Clause (see the LICENSE and LICENSE.BSD3 files)
Maintainer  :  ymdfield@outlook.jp

This module provides an ad-hoc specialized version of
 "Control.Monad.Hefty.Interpret" to accelerate interpretations that have a
single state type @s@, especially for effects like t'Data.Effect.State.State' or
 [@Writer@]("Data.Effect.Writer").
-}
module Control.Monad.Hefty.Interpret.State where

import Control.Effect (unEff)
import Control.Effect qualified as D
import Control.Monad.Hefty.Types (Eff, Freer (Op, Val), qApp)
import Data.Effect.OpenUnion (
    FOEs,
    In,
    KnownOrder,
    Membership,
    Suffix,
    coerceFOEs,
    identityMembership,
    labelMembership,
    project,
    weakens,
    (!:),
    (:>),
 )
import Data.FTCQueue (tsingleton)
import Data.Function ((&))
import Data.Kind (Type)

-- | An ad-hoc stateful version of t'Control.Monad.Hefty.Types.Handler' for performance.
type StateHandler s e m n (ans :: Type) = forall x. e m x -> s -> (s -> x -> n ans) -> n ans

-- * Interpretation functions

interpretStateBy
    :: forall s e es 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 :: 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
-> (s -> a -> Eff es ans)
-> StateHandler s e (Eff (e : es)) (Eff es) ans
-> Eff (e : es) a
-> Eff es ans
forall s (e :: Effect) (es' :: [Effect]) (es :: [Effect]) ans a.
(Suffix es es', 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
reinterpretStateBy
{-# INLINE interpretStateBy #-}

reinterpretStateBy
    :: forall s e es' es ans a
     . (Suffix es es', 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
reinterpretStateBy :: forall s (e :: Effect) (es' :: [Effect]) (es :: [Effect]) ans a.
(Suffix es es', 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
reinterpretStateBy s
s0 s -> a -> Eff es' ans
ret StateHandler s e (Eff (e : es)) (Eff es') ans
hdl = s -> Eff Freer (e : es) a -> Eff es' ans
loop s
s0
  where
    loop :: s -> Eff Freer (e : es) a -> Eff es' ans
loop s
s (D.Eff Freer (Union (e : es) (Eff (e : es))) a
m) = case Freer (Union (e : es) (Eff (e : es))) a
m of
        Val a
x -> s -> a -> Eff es' ans
ret s
s a
x
        Op Union (e : es) (Eff (e : es)) x
u FTCQueue (Freer (Union (e : es) (Eff (e : es)))) x a
q ->
            let k :: s -> x -> Eff es' ans
k s
s' = s -> Eff Freer (e : es) a -> Eff es' ans
loop s
s' (Eff Freer (e : es) a -> Eff es' ans)
-> (x -> Eff Freer (e : es) a) -> x -> Eff es' ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Freer (Union (e : es) (Eff (e : es))) a -> Eff Freer (e : es) a
forall (ff :: Effect) (es :: [Effect]) a.
ff (Union es (Eff ff es)) a -> Eff ff es a
D.Eff (Freer (Union (e : es) (Eff (e : es))) a -> Eff Freer (e : es) a)
-> (x -> Freer (Union (e : es) (Eff (e : es))) a)
-> x
-> Eff Freer (e : es) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FTCQueue (Freer (Union (e : es) (Eff (e : es)))) x a
-> x -> Freer (Union (e : es) (Eff (e : es))) a
forall (f :: * -> *) a b. FTCQueue (Freer f) a b -> a -> Freer f b
qApp FTCQueue (Freer (Union (e : es) (Eff (e : es)))) x a
q
             in Union (e : es) (Eff (e : es)) x
u Union (e : es) (Eff (e : es)) x
-> (Union (e : es) (Eff (e : es)) x -> Eff es' ans) -> Eff es' ans
forall a b. a -> (a -> b) -> b
& (\e (Eff (e : es)) x
e -> e (Eff (e : es)) x -> s -> (s -> x -> Eff es' ans) -> Eff es' ans
StateHandler s e (Eff (e : es)) (Eff es') ans
hdl e (Eff (e : es)) x
e s
s s -> x -> Eff es' ans
k) (e (Eff (e : es)) x -> Eff es' ans)
-> (Union es (Eff (e : es)) x -> Eff es' ans)
-> Union (e : es) (Eff (e : es)) x
-> Eff es' ans
forall (f :: * -> *) a r (es :: [Effect]).
(e f a -> r) -> (Union es f a -> r) -> Union (e : es) f a -> r
forall (e :: Effect) (order :: EffectOrder) (f :: * -> *) a r
       (es :: [Effect]).
Elem e order =>
(e f a -> r) -> (Union es f a -> r) -> Union (e : es) f a -> r
!: Freer (Union es' (Eff es')) ans -> Eff es' ans
forall (ff :: Effect) (es :: [Effect]) a.
ff (Union es (Eff ff es)) a -> Eff ff es a
D.Eff (Freer (Union es' (Eff es')) ans -> Eff es' ans)
-> (Union es (Eff (e : es)) x -> Freer (Union es' (Eff es')) ans)
-> Union es (Eff (e : es)) x
-> Eff es' ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Union es' (Eff es') x
-> FTCQueue (Freer (Union es' (Eff es'))) x ans
-> Freer (Union es' (Eff es')) ans
forall (f :: * -> *) a x.
f x -> FTCQueue (Freer f) x a -> Freer f a
`Op` ((x -> Freer (Union es' (Eff es')) ans)
-> FTCQueue (Freer (Union es' (Eff es'))) x ans
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton ((x -> Freer (Union es' (Eff es')) ans)
 -> FTCQueue (Freer (Union es' (Eff es'))) x ans)
-> (x -> Freer (Union es' (Eff es')) ans)
-> FTCQueue (Freer (Union es' (Eff es'))) x ans
forall a b. (a -> b) -> a -> b
$ Eff es' ans -> Freer (Union es' (Eff es')) ans
forall (ff :: Effect) (es :: [Effect]) a.
Eff ff es a -> ff (Union es (Eff ff es)) a
unEff (Eff es' ans -> Freer (Union es' (Eff es')) ans)
-> (x -> Eff es' ans) -> x -> Freer (Union es' (Eff es')) ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> x -> Eff es' ans
k s
s)) (Union es' (Eff es') x -> Freer (Union es' (Eff es')) ans)
-> (Union es (Eff (e : es)) x -> Union es' (Eff es') x)
-> Union es (Eff (e : es)) x
-> Freer (Union es' (Eff es')) ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Union es (Eff es') x -> Union es' (Eff es') x
forall (es :: [Effect]) (es' :: [Effect]) (f :: * -> *) a.
Suffix es es' =>
Union es f a -> Union es' f a
weakens (Union es (Eff es') x -> Union es' (Eff es') x)
-> (Union es (Eff (e : es)) x -> Union es (Eff es') x)
-> Union es (Eff (e : es)) x
-> Union es' (Eff es') x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Union es (Eff (e : es)) x -> Union es (Eff es') x
forall (es :: [Effect]) (f :: * -> *) a (g :: * -> *).
FOEs es =>
Union es f a -> Union es g a
coerceFOEs
{-# INLINE reinterpretStateBy #-}

-- * Interposition functions

interposeStateBy
    :: forall s e es 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 :: 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 = Membership e es
-> s
-> (s -> a -> Eff Freer es ans)
-> (forall {x}.
    e (Eff Freer es) x
    -> s -> (s -> x -> Eff Freer es ans) -> Eff Freer es ans)
-> Eff Freer es a
-> Eff Freer es ans
forall s (e :: Effect) (es :: [Effect]) ans a.
(KnownOrder e, FOEs es) =>
Membership e es
-> s
-> (s -> a -> Eff es ans)
-> StateHandler s e (Eff es) (Eff es) ans
-> Eff es a
-> Eff es ans
interposeStateForBy Membership e es
forall (e :: Effect) (es :: [Effect]).
FindBy LabelResolver (LabelOf e) (LabelOf (HeadOf es)) e es =>
Membership e es
labelMembership
{-# INLINE interposeStateBy #-}

interposeStateInBy
    :: forall s e es ans a
     . (e `In` es, FOEs es)
    => s
    -> (s -> a -> Eff es ans)
    -> StateHandler s e (Eff es) (Eff es) ans
    -> Eff es a
    -> Eff es ans
interposeStateInBy :: forall s (e :: Effect) (es :: [Effect]) ans a.
(In e es, FOEs es) =>
s
-> (s -> a -> Eff es ans)
-> StateHandler s e (Eff es) (Eff es) ans
-> Eff es a
-> Eff es ans
interposeStateInBy = Membership e es
-> s
-> (s -> a -> Eff Freer es ans)
-> (forall {x}.
    e (Eff Freer es) x
    -> s -> (s -> x -> Eff Freer es ans) -> Eff Freer es ans)
-> Eff Freer es a
-> Eff Freer es ans
forall s (e :: Effect) (es :: [Effect]) ans a.
(KnownOrder e, FOEs es) =>
Membership e es
-> s
-> (s -> a -> Eff es ans)
-> StateHandler s e (Eff es) (Eff es) ans
-> Eff es a
-> Eff es ans
interposeStateForBy Membership e es
forall (e :: Effect) (es :: [Effect]).
FindBy
  IdentityResolver
  (IdentityDiscriminator e)
  (IdentityDiscriminator (HeadOf es))
  e
  es =>
Membership e es
identityMembership
{-# INLINE interposeStateInBy #-}

interposeStateForBy
    :: forall s e es ans a
     . (KnownOrder e, FOEs es)
    => Membership e es
    -> s
    -> (s -> a -> Eff es ans)
    -> StateHandler s e (Eff es) (Eff es) ans
    -> Eff es a
    -> Eff es ans
interposeStateForBy :: forall s (e :: Effect) (es :: [Effect]) ans a.
(KnownOrder e, FOEs es) =>
Membership e es
-> s
-> (s -> a -> Eff es ans)
-> StateHandler s e (Eff es) (Eff es) ans
-> Eff es a
-> Eff es ans
interposeStateForBy Membership e es
i s
s0 s -> a -> Eff es ans
ret StateHandler s e (Eff es) (Eff es) ans
hdl = s -> Eff Freer es a -> Eff es ans
loop s
s0
  where
    loop :: s -> Eff Freer es a -> Eff es ans
loop s
s (D.Eff Freer (Union es (Eff es)) a
m) = case Freer (Union es (Eff es)) a
m of
        Val a
x -> s -> a -> Eff es ans
ret s
s a
x
        Op Union es (Eff es) x
u FTCQueue (Freer (Union es (Eff es))) x a
q ->
            let k :: s -> x -> Eff es ans
k s
s' = s -> Eff Freer es a -> Eff es ans
loop s
s' (Eff Freer es a -> Eff es ans)
-> (x -> Eff Freer es a) -> x -> Eff es ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Freer (Union es (Eff es)) a -> Eff Freer es a
forall (ff :: Effect) (es :: [Effect]) a.
ff (Union es (Eff ff es)) a -> Eff ff es a
D.Eff (Freer (Union es (Eff es)) a -> Eff Freer es a)
-> (x -> Freer (Union es (Eff es)) a) -> x -> Eff Freer es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FTCQueue (Freer (Union es (Eff es))) x a
-> x -> Freer (Union es (Eff es)) a
forall (f :: * -> *) a b. FTCQueue (Freer f) a b -> a -> Freer f b
qApp FTCQueue (Freer (Union es (Eff es))) x a
q
             in case Membership e es -> Union es (Eff es) x -> Maybe (e (Eff es) x)
forall (es :: [Effect]) (f :: * -> *) a.
Membership e es -> Union es f a -> Maybe (e f a)
forall (e :: Effect) (order :: EffectOrder) (es :: [Effect])
       (f :: * -> *) a.
Elem e order =>
Membership e es -> Union es f a -> Maybe (e f a)
project Membership e es
i Union es (Eff es) x
u of
                    Just e (Eff es) x
e -> e (Eff es) x -> s -> (s -> x -> Eff es ans) -> Eff es ans
StateHandler s e (Eff es) (Eff es) ans
hdl e (Eff es) x
e s
s s -> x -> Eff es ans
k
                    Maybe (e (Eff es) x)
Nothing -> Freer (Union es (Eff es)) ans -> Eff es ans
forall (ff :: Effect) (es :: [Effect]) a.
ff (Union es (Eff ff es)) a -> Eff ff es a
D.Eff (Freer (Union es (Eff es)) ans -> Eff es ans)
-> Freer (Union es (Eff es)) ans -> Eff es ans
forall a b. (a -> b) -> a -> b
$ Union es (Eff es) x
-> FTCQueue (Freer (Union es (Eff es))) x ans
-> Freer (Union es (Eff es)) ans
forall (f :: * -> *) a x.
f x -> FTCQueue (Freer f) x a -> Freer f a
Op Union es (Eff es) x
u ((x -> Freer (Union es (Eff es)) ans)
-> FTCQueue (Freer (Union es (Eff es))) x ans
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton ((x -> Freer (Union es (Eff es)) ans)
 -> FTCQueue (Freer (Union es (Eff es))) x ans)
-> (x -> Freer (Union es (Eff es)) ans)
-> FTCQueue (Freer (Union es (Eff es))) x ans
forall a b. (a -> b) -> a -> b
$ Eff es ans -> Freer (Union es (Eff es)) ans
forall (ff :: Effect) (es :: [Effect]) a.
Eff ff es a -> ff (Union es (Eff ff es)) a
unEff (Eff es ans -> Freer (Union es (Eff es)) ans)
-> (x -> Eff es ans) -> x -> Freer (Union es (Eff es)) ans
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> x -> Eff es ans
k s
s)
{-# INLINE interposeStateForBy #-}

-- TODO: add other pattern functions.