-- SPDX-License-Identifier: MPL-2.0

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

Interpreters for the [Writer]("Data.Effect.Writer") effects.
-}
module Control.Monad.Hefty.Writer (
    module Control.Monad.Hefty.Writer,
    module Data.Effect.Writer,
)
where

import Control.Monad.Hefty (
    Eff,
    StateInterpreter,
    interpose,
    interposeStateBy,
    interpretH,
    interpretStateBy,
    send,
    type (<|),
    type (~>),
 )
import Data.Effect.Writer

-- | Interpret the [Writer]("Data.Effect.Writer") effects with post-applying censor semantics.
runWriterPost :: (Monoid w) => Eff '[WriterH w] (Tell w ': ef) a -> Eff '[] ef (w, a)
runWriterPost :: forall w (ef :: [* -> *]) a.
Monoid w =>
Eff '[WriterH w] (Tell w : ef) a -> Eff '[] ef (w, a)
runWriterPost = Eff '[] (Tell w : ef) a -> Eff '[] ef (w, a)
forall w (ef :: [* -> *]) a.
Monoid w =>
Eff '[] (Tell w : ef) a -> Eff '[] ef (w, a)
runTell (Eff '[] (Tell w : ef) a -> Eff '[] ef (w, a))
-> (Eff '[WriterH w] (Tell w : ef) a -> Eff '[] (Tell w : ef) a)
-> Eff '[WriterH w] (Tell w : ef) a
-> Eff '[] ef (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff '[WriterH w] (Tell w : ef) a -> Eff '[] (Tell w : ef) a
Eff '[WriterH w] (Tell w : ef) ~> Eff '[] (Tell w : ef)
forall w (ef :: [* -> *]).
(Monoid w, Tell w <| ef) =>
Eff '[WriterH w] ef ~> Eff '[] ef
runWriterHPost

-- | Interpret the [Writer]("Data.Effect.Writer") effects with pre-applying censor semantics.
runWriterPre :: (Monoid w) => Eff '[WriterH w] (Tell w ': ef) a -> Eff '[] ef (w, a)
runWriterPre :: forall w (ef :: [* -> *]) a.
Monoid w =>
Eff '[WriterH w] (Tell w : ef) a -> Eff '[] ef (w, a)
runWriterPre = Eff '[] (Tell w : ef) a -> Eff '[] ef (w, a)
forall w (ef :: [* -> *]) a.
Monoid w =>
Eff '[] (Tell w : ef) a -> Eff '[] ef (w, a)
runTell (Eff '[] (Tell w : ef) a -> Eff '[] ef (w, a))
-> (Eff '[WriterH w] (Tell w : ef) a -> Eff '[] (Tell w : ef) a)
-> Eff '[WriterH w] (Tell w : ef) a
-> Eff '[] ef (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff '[WriterH w] (Tell w : ef) a -> Eff '[] (Tell w : ef) a
Eff '[WriterH w] (Tell w : ef) ~> Eff '[] (Tell w : ef)
forall w (ef :: [* -> *]).
(Monoid w, Tell w <| ef) =>
Eff '[WriterH w] ef ~> Eff '[] ef
runWriterHPre

-- | Interpret the t'Tell' effect.
runTell :: (Monoid w) => Eff '[] (Tell w ': ef) a -> Eff '[] ef (w, a)
runTell :: forall w (ef :: [* -> *]) a.
Monoid w =>
Eff '[] (Tell w : ef) a -> Eff '[] ef (w, a)
runTell = w
-> (w -> a -> Eff '[] ef (w, a))
-> StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
-> Eff '[] (Tell w : ef) a
-> Eff '[] ef (w, a)
forall s (e :: * -> *) (ef :: [* -> *]) ans a.
s
-> (s -> a -> Eff '[] ef ans)
-> StateInterpreter s e (Eff '[] ef) ans
-> Eff '[] (e : ef) a
-> Eff '[] ef ans
interpretStateBy w
forall a. Monoid a => a
mempty (((w, a) -> Eff '[] ef (w, a)) -> w -> a -> Eff '[] ef (w, a)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (w, a) -> Eff '[] ef (w, a)
forall a. a -> Eff '[] ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Tell w x -> w -> (w -> x -> Eff '[] ef (w, a)) -> Eff '[] ef (w, a)
StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
forall w (ef :: [* -> *]) a.
Monoid w =>
StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
handleTell

-- | A handler function for the t'Tell' effect.
handleTell :: (Monoid w) => StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
handleTell :: forall w (ef :: [* -> *]) a.
Monoid w =>
StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
handleTell (Tell w
w') w
w w -> x -> Eff '[] ef (w, a)
k = w -> x -> Eff '[] ef (w, a)
k (w
w w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w') ()
{-# INLINE handleTell #-}

-- | Interpret the 'WriterH' effect with post-applying censor semantics.
runWriterHPost :: (Monoid w, Tell w <| ef) => Eff '[WriterH w] ef ~> Eff '[] ef
runWriterHPost :: forall w (ef :: [* -> *]).
(Monoid w, Tell w <| ef) =>
Eff '[WriterH w] ef ~> Eff '[] ef
runWriterHPost = (WriterH w ~~> Eff '[] ef) -> Eff '[WriterH w] ef ~> Eff '[] ef
forall (e :: (* -> *) -> * -> *) (eh :: [(* -> *) -> * -> *])
       (ef :: [* -> *]).
HFunctor e =>
(e ~~> Eff eh ef) -> Eff (e : eh) ef ~> Eff eh ef
interpretH \case
    Listen Eff '[] ef a1
m -> Eff '[] ef a1 -> Eff '[] ef (w, a1)
forall w (ef :: [* -> *]) a.
(Tell w <| ef, Monoid w) =>
Eff '[] ef a -> Eff '[] ef (w, a)
intercept Eff '[] ef a1
m
    Censor w -> w
f Eff '[] ef x
m -> (w -> w) -> Eff '[] ef ~> Eff '[] ef
forall w (ef :: [* -> *]).
(Tell w <| ef, Monoid w) =>
(w -> w) -> Eff '[] ef ~> Eff '[] ef
censorPost w -> w
f Eff '[] ef x
m

-- | Interpret the 'WriterH' effect with pre-applying censor semantics.
runWriterHPre :: (Monoid w, Tell w <| ef) => Eff '[WriterH w] ef ~> Eff '[] ef
runWriterHPre :: forall w (ef :: [* -> *]).
(Monoid w, Tell w <| ef) =>
Eff '[WriterH w] ef ~> Eff '[] ef
runWriterHPre = (WriterH w ~~> Eff '[] ef) -> Eff '[WriterH w] ef ~> Eff '[] ef
forall (e :: (* -> *) -> * -> *) (eh :: [(* -> *) -> * -> *])
       (ef :: [* -> *]).
HFunctor e =>
(e ~~> Eff eh ef) -> Eff (e : eh) ef ~> Eff eh ef
interpretH \case
    Listen Eff '[] ef a1
m -> Eff '[] ef a1 -> Eff '[] ef (w, a1)
forall w (ef :: [* -> *]) a.
(Tell w <| ef, Monoid w) =>
Eff '[] ef a -> Eff '[] ef (w, a)
intercept Eff '[] ef a1
m
    Censor w -> w
f Eff '[] ef x
m -> (w -> w) -> Eff '[] ef ~> Eff '[] ef
forall w (eh :: [(* -> *) -> * -> *]) (ef :: [* -> *]).
(Tell w <| ef, Monoid w) =>
(w -> w) -> Eff eh ef ~> Eff eh ef
censorPre w -> w
f Eff '[] ef x
m

{- | Retrieves the monoidal value accumulated by v'tell' within the given action.
The v'tell' effect is not consumed and remains intact.
-}
intercept
    :: forall w ef a
     . (Tell w <| ef, Monoid w)
    => Eff '[] ef a
    -> Eff '[] ef (w, a)
intercept :: forall w (ef :: [* -> *]) a.
(Tell w <| ef, Monoid w) =>
Eff '[] ef a -> Eff '[] ef (w, a)
intercept =
    forall s (e :: * -> *) (ef :: [* -> *]) ans a.
(e <| ef) =>
s
-> (s -> a -> Eff '[] ef ans)
-> StateInterpreter s e (Eff '[] ef) ans
-> Eff '[] ef a
-> Eff '[] ef ans
interposeStateBy @_ @(Tell w)
        w
forall a. Monoid a => a
mempty
        (((w, a) -> Eff '[] ef (w, a)) -> w -> a -> Eff '[] ef (w, a)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (w, a) -> Eff '[] ef (w, a)
forall a. a -> Eff '[] ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
        \e :: Tell w x
e@(Tell w
_) w
w w -> x -> Eff '[] ef (w, a)
k -> do
            () <- Tell w x -> Eff '[] ef x
Tell w ~> Eff '[] ef
forall (e :: * -> *) (ef :: [* -> *]) (eh :: [(* -> *) -> * -> *]).
(e <| ef) =>
e ~> Eff eh ef
send Tell w x
e
            Tell w x -> w -> (w -> x -> Eff '[] ef (w, a)) -> Eff '[] ef (w, a)
StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
forall w (ef :: [* -> *]) a.
Monoid w =>
StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
handleTell Tell w x
e w
w w -> x -> Eff '[] ef (w, a)
k

{- | Consumes all the v'tell' effects from the specified @Tell w@ slot within the
given action and returns the accumulated monoidal value along with the result.
-}
confiscate
    :: forall w ef a
     . (Tell w <| ef, Monoid w)
    => Eff '[] ef a
    -> Eff '[] ef (w, a)
confiscate :: forall w (ef :: [* -> *]) a.
(Tell w <| ef, Monoid w) =>
Eff '[] ef a -> Eff '[] ef (w, a)
confiscate = w
-> (w -> a -> Eff '[] ef (w, a))
-> StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
-> Eff '[] ef a
-> Eff '[] ef (w, a)
forall s (e :: * -> *) (ef :: [* -> *]) ans a.
(e <| ef) =>
s
-> (s -> a -> Eff '[] ef ans)
-> StateInterpreter s e (Eff '[] ef) ans
-> Eff '[] ef a
-> Eff '[] ef ans
interposeStateBy w
forall a. Monoid a => a
mempty (((w, a) -> Eff '[] ef (w, a)) -> w -> a -> Eff '[] ef (w, a)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (w, a) -> Eff '[] ef (w, a)
forall a. a -> Eff '[] ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Tell w x -> w -> (w -> x -> Eff '[] ef (w, a)) -> Eff '[] ef (w, a)
StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
forall w (ef :: [* -> *]) a.
Monoid w =>
StateInterpreter w (Tell w) (Eff '[] ef) (w, a)
handleTell

-- | 'censor' with post-applying semantics.
censorPost
    :: forall w ef
     . (Tell w <| ef, Monoid w)
    => (w -> w)
    -> Eff '[] ef ~> Eff '[] ef
censorPost :: forall w (ef :: [* -> *]).
(Tell w <| ef, Monoid w) =>
(w -> w) -> Eff '[] ef ~> Eff '[] ef
censorPost w -> w
f Eff '[] ef x
m = do
    (w
w, x
a) <- Eff '[] ef x -> Eff '[] ef (w, x)
forall w (ef :: [* -> *]) a.
(Tell w <| ef, Monoid w) =>
Eff '[] ef a -> Eff '[] ef (w, a)
confiscate Eff '[] ef x
m
    w -> Eff '[] ef ()
forall w (f :: * -> *). SendFOE (Tell w) f => w -> f ()
tell (w -> Eff '[] ef ()) -> w -> Eff '[] ef ()
forall a b. (a -> b) -> a -> b
$ w -> w
f w
w
    x -> Eff '[] ef x
forall a. a -> Eff '[] ef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
a

-- | 'censor' with pre-applying semantics.
censorPre
    :: forall w eh ef
     . (Tell w <| ef, Monoid w)
    => (w -> w)
    -> Eff eh ef ~> Eff eh ef
censorPre :: forall w (eh :: [(* -> *) -> * -> *]) (ef :: [* -> *]).
(Tell w <| ef, Monoid w) =>
(w -> w) -> Eff eh ef ~> Eff eh ef
censorPre w -> w
f = forall (e :: * -> *) (ef :: [* -> *]) (eh :: [(* -> *) -> * -> *]).
(e <| ef) =>
(e ~> Eff eh ef) -> Eff eh ef ~> Eff eh ef
interpose @(Tell w) \(Tell w
w) -> w -> Eff eh ef ()
forall w (f :: * -> *). SendFOE (Tell w) f => w -> f ()
tell (w -> Eff eh ef ()) -> w -> Eff eh ef ()
forall a b. (a -> b) -> a -> b
$ w -> w
f w
w