{-# LANGUAGE AllowAmbiguousTypes #-}

-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

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

Interpreter and elaborator for the t'Data.Effect.Writer.Writer' effect class.
See [README.md](https://github.com/sayo-hs/heftia/blob/master/README.md).
-}
module Control.Monad.Hefty.Writer where

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

-- | 'Writer' effect handler 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

-- | 'Writer' effect handler 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

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

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 #-}

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)
listen 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

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)
listen 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.
-}
listen
    :: forall w ef a
     . (Tell w <| ef, Monoid w)
    => Eff '[] ef a
    -> Eff '[] ef (w, a)
listen :: forall w (ef :: [* -> *]) a.
(Tell w <| ef, Monoid w) =>
Eff '[] ef a -> Eff '[] ef (w, a)
listen =
    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

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

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