{-# LANGUAGE UndecidableInstances #-}
module Effectful.Class.Writer where

import Control.Monad.Trans.Class
import Control.Monad.Trans.Control

import Effectful.Internal.Has
import Effectful.Internal.Monad
import qualified Effectful.Writer as W

-- | Compatiblity layer for a transition period from MTL-style effect handling
-- to 'Effective.Eff'.
class Monad m => MonadWriter w m where
  {-# MINIMAL (writer | tell), listen #-}

  writer :: (a, w) -> m a
  writer (a
a, w
w) = do
    w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell w
w
    a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

  tell :: w -> m ()
  tell w
w = ((), w) -> m ()
forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer ((), w
w)

  listen :: m a -> m (a, w)

-- | Generic, overlappable instance.
instance {-# OVERLAPPABLE #-}
  ( MonadWriter w m
  , MonadTransControl t
  , Monad (t m)
  ) => MonadWriter w (t m) where
  writer :: (a, w) -> t m a
writer   = m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> t m a) -> ((a, w) -> m a) -> (a, w) -> t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> m a
forall w (m :: * -> *) a. MonadWriter w m => (a, w) -> m a
writer
  tell :: w -> t m ()
tell     = m () -> t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> (w -> m ()) -> w -> t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  listen :: t m a -> t m (a, w)
listen t m a
m = do
    (StT t a
stT, w
w) <- (Run t -> m (StT t a, w)) -> t m (StT t a, w)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run t -> m (StT t a, w)) -> t m (StT t a, w))
-> (Run t -> m (StT t a, w)) -> t m (StT t a, w)
forall a b. (a -> b) -> a -> b
$ \Run t
run -> m (StT t a) -> m (StT t a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (t m a -> m (StT t a)
Run t
run t m a
m)
    (, w
w) (a -> (a, w)) -> t m a -> t m (a, w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (StT t a) -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (StT t a -> m (StT t a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure StT t a
stT)

instance (W.Writer w :> es, Monoid w) => MonadWriter w (Eff es) where
  writer :: (a, w) -> Eff es a
writer = (a, w) -> Eff es a
forall w (es :: [*]) a.
(Writer w :> es, Monoid w) =>
(a, w) -> Eff es a
W.writer
  tell :: w -> Eff es ()
tell   = w -> Eff es ()
forall w (es :: [*]). (Writer w :> es, Monoid w) => w -> Eff es ()
W.tell
  listen :: Eff es a -> Eff es (a, w)
listen = Eff es a -> Eff es (a, w)
forall w (es :: [*]) a.
(Writer w :> es, Monoid w) =>
Eff es a -> Eff es (a, w)
W.listen

listens :: MonadWriter w m => (w -> b) -> m a -> m (a, b)
listens :: (w -> b) -> m a -> m (a, b)
listens w -> b
f m a
m = do
  (a
a, w
w) <- m a -> m (a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen m a
m
  (a, b) -> m (a, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, w -> b
f w
w)