{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Effect.Writer.Passthrough where

import Control.Monad.Writer
import Effect
import Effect.Writer

-- | A "passthough" instance for 'MonadWriterEffect's: Modifications are applied
-- in all nested positions of 'Listen' and 'Pass', but don't actually change the
-- semantics of any 'MonadWriterEffect'.
instance (MonadWriter e m) => InterpretEffectStateful x m (MonadWriterEffect e) where
  interpretEffectStateful :: forall (ops :: [Effect]) x a.
(forall b y. x y -> AST ops b -> m (b, x y))
-> x x -> MonadWriterEffect e (AST ops) a -> m (a, x x)
interpretEffectStateful forall b y. x y -> AST ops b -> m (b, x y)
interpret x x
x (Listen AST ops a1
acts) = do
    ((a1
a, x x
x'), e
w) <- m (a1, x x) -> m ((a1, x x), e)
forall a. m a -> m (a, e)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (m (a1, x x) -> m ((a1, x x), e))
-> (AST ops a1 -> m (a1, x x)) -> AST ops a1 -> m ((a1, x x), e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x x -> AST ops a1 -> m (a1, x x)
forall b y. x y -> AST ops b -> m (b, x y)
interpret x x
x (AST ops a1 -> m ((a1, x x), e)) -> AST ops a1 -> m ((a1, x x), e)
forall a b. (a -> b) -> a -> b
$ AST ops a1
acts
    (a, x x) -> m (a, x x)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a1
a, e
w), x x
x')
  interpretEffectStateful forall b y. x y -> AST ops b -> m (b, x y)
interpret x x
x (Pass AST ops (a, e -> e)
acts) =
    m ((a, x x), e -> e) -> m (a, x x)
forall a. m (a, e -> e) -> m a
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (m ((a, x x), e -> e) -> m (a, x x))
-> m ((a, x x), e -> e) -> m (a, x x)
forall a b. (a -> b) -> a -> b
$ do
      ((a
a, e -> e
f), x x
x') <- x x -> AST ops (a, e -> e) -> m ((a, e -> e), x x)
forall b y. x y -> AST ops b -> m (b, x y)
interpret x x
x AST ops (a, e -> e)
acts
      ((a, x x), e -> e) -> m ((a, x x), e -> e)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
a, x x
x'), e -> e
f)
  interpretEffectStateful forall b y. x y -> AST ops b -> m (b, x y)
_ x x
x (Tell e
w) = (,x x
x) (a -> (a, x x)) -> m a -> m (a, x x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell e
w
  interpretEffectStateful forall b y. x y -> AST ops b -> m (b, x y)
_ x x
x (Writer (a
a, e
w)) = (,x x
x) (a -> (a, x x)) -> m a -> m (a, x x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (e -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell e
w m () -> m a -> m a
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)