{-# 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 Yamada Ryo
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
Portability :  portable

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

import Control.Effect.Class (type (~>))
import Control.Effect.Class.Writer (Tell (tell), TellI (Tell), WriterS (Censor, Listen))
import Control.Effect.Freer (Fre, intercept, interposeT, interpretK, interpretT, type (<|))
import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT)
import Control.Monad.Trans.Writer.CPS qualified as T
import Data.Function ((&))
import Data.Tuple (swap)

elaborateWriterT ::
    forall w m es.
    (Monad m, Monoid w, TellI w <| es) =>
    WriterS w (Fre es m) ~> Fre es m
elaborateWriterT :: forall w (m :: * -> *) (es :: [* -> *]).
(Monad m, Monoid w, TellI w <| es) =>
WriterS w (Fre es m) ~> Fre es m
elaborateWriterT = \case
    Listen Fre es m a1
m -> forall w (m :: * -> *) (es :: [* -> *]) a.
(Monoid w, Monad m, TellI w <| es) =>
Fre es m a -> Fre es m (a, w)
listenT Fre es m a1
m
    Censor w -> w
f Fre es m x
m -> Fre es m x
m forall a b. a -> (a -> b) -> b
& forall (e :: * -> *) (fr :: (* -> *) -> (* -> *) -> * -> *)
       (u :: [* -> *] -> * -> *) (es :: [* -> *]) (f :: * -> *)
       (c :: (* -> *) -> Constraint).
(TransFreer c fr, Union u, Member u e es, c f) =>
(e ~> e) -> FreerEffects fr u es f ~> FreerEffects fr u es f
intercept @(TellI w) \(Tell w
w) -> forall w. w -> TellI w ()
Tell forall a b. (a -> b) -> a -> b
$ w -> w
f w
w

elaborateWriterTransactionalT ::
    forall w m es.
    (Monad m, Monoid w, TellI w <| es) =>
    WriterS w (Fre es m) ~> Fre es m
elaborateWriterTransactionalT :: forall w (m :: * -> *) (es :: [* -> *]).
(Monad m, Monoid w, TellI w <| es) =>
WriterS w (Fre es m) ~> Fre es m
elaborateWriterTransactionalT = \case
    Listen Fre es m a1
m -> forall w (m :: * -> *) (es :: [* -> *]) a.
(Monoid w, Monad m, TellI w <| es) =>
Fre es m a -> Fre es m (a, w)
listenT Fre es m a1
m
    Censor w -> w
f Fre es m x
m -> do
        (x
a, w
w) <- forall w (m :: * -> *) (es :: [* -> *]) a.
(Monoid w, Monad m, TellI w <| es) =>
Fre es m a -> Fre es m (a, w)
confiscateT Fre es m x
m
        forall w (f :: * -> *). Tell w f => w -> f ()
tell forall a b. (a -> b) -> a -> b
$ w -> w
f w
w
        forall (f :: * -> *) a. Applicative f => a -> f a
pure x
a

listenT ::
    (Monoid w, Monad m, TellI w <| es) =>
    Fre es m a ->
    Fre es m (a, w)
listenT :: forall w (m :: * -> *) (es :: [* -> *]) a.
(Monoid w, Monad m, TellI w <| es) =>
Fre es m a -> Fre es m (a, w)
listenT Fre es m a
m = do
    (a
a, w
w) <- forall w (m :: * -> *) (es :: [* -> *]) a.
(Monoid w, Monad m, TellI w <| es) =>
Fre es m a -> Fre es m (a, w)
confiscateT Fre es m a
m
    forall w (f :: * -> *). Tell w f => w -> f ()
tell w
w
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, w
w)
{-# INLINE listenT #-}

confiscateT ::
    forall w m es a.
    (Monoid w, Monad m, TellI w <| es) =>
    Fre es m a ->
    Fre es m (a, w)
confiscateT :: forall w (m :: * -> *) (es :: [* -> *]) a.
(Monoid w, Monad m, TellI w <| es) =>
Fre es m a -> Fre es m (a, w)
confiscateT = forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e :: * -> *) (t :: (* -> *) -> * -> *)
       (fr :: (* -> *) -> (* -> *) -> * -> *) (u :: [* -> *] -> * -> *)
       (es :: [* -> *]) (m :: * -> *).
(MonadTransFreer fr, Union u, Member u e es, Monad m, MonadTrans t,
 forall (m1 :: * -> *) (m2 :: * -> *) x.
 Coercible m1 m2 =>
 Coercible (t m1 x) (t m2 x),
 Monad (t (fr (u es) m))) =>
(e ~> t (FreerEffects fr u es m))
-> FreerEffects fr u es m ~> t (FreerEffects fr u es m)
interposeT @(TellI w) \(Tell w
w) -> forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
T.tell w
w
{-# INLINE confiscateT #-}

interpretTell :: (Monad m, Monoid w) => Fre (TellI w ': es) m a -> Fre es m (w, a)
interpretTell :: forall (m :: * -> *) w (es :: [* -> *]) a.
(Monad m, Monoid w) =>
Fre (TellI w : es) m a -> Fre es m (w, a)
interpretTell = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w (es :: [* -> *]) a.
(Monad m, Monoid w) =>
Fre (TellI w : es) m a -> WriterT w (Fre es m) a
interpretTellT
{-# INLINE interpretTell #-}

interpretTellT :: (Monad m, Monoid w) => Fre (TellI w ': es) m a -> WriterT w (Fre es m) a
interpretTellT :: forall (m :: * -> *) w (es :: [* -> *]) a.
(Monad m, Monoid w) =>
Fre (TellI w : es) m a -> WriterT w (Fre es m) a
interpretTellT = forall (t :: (* -> *) -> * -> *)
       (fr :: (* -> *) -> (* -> *) -> * -> *) (u :: [* -> *] -> * -> *)
       (e :: * -> *) (es :: [* -> *]) (f :: * -> *).
(MonadTransFreer fr, Union u, MonadTrans t, Monad f,
 Monad (t (FreerEffects fr u es f))) =>
(e ~> t (FreerEffects fr u es f))
-> FreerEffects fr u (e : es) f ~> t (FreerEffects fr u es f)
interpretT \(Tell w
w) -> forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
T.tell w
w
{-# INLINE interpretTellT #-}

interpretTellK :: (Monad m, Monoid w) => Fre (TellI w ': es) m a -> Fre es m (w, a)
interpretTellK :: forall (m :: * -> *) w (es :: [* -> *]) a.
(Monad m, Monoid w) =>
Fre (TellI w : es) m a -> Fre es m (w, a)
interpretTellK =
    forall (fr :: (* -> *) -> (* -> *) -> * -> *)
       (u :: [* -> *] -> * -> *) (f :: * -> *) a (es :: [* -> *]) r
       (e :: * -> *).
(MonadTransFreer fr, Union u, Monad f) =>
(a -> FreerEffects fr u es f r)
-> (forall x.
    (x -> FreerEffects fr u es f r) -> e x -> FreerEffects fr u es f r)
-> FreerEffects fr u (e : es) f a
-> FreerEffects fr u es f r
interpretK (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Monoid a => a
mempty,)) \x -> FreerEffects FreerChurchT ExtensibleUnion es m (w, a)
k (Tell w
w) -> do
        (w
w', a
r) <- x -> FreerEffects FreerChurchT ExtensibleUnion es m (w, a)
k ()
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (w
w forall a. Semigroup a => a -> a -> a
<> w
w', a
r)