{-# LANGUAGE TupleSections #-}

-- | Extend a monad with an accumulative write-only environment
module Mini.Transformers.WriterT (
  -- * Type
  WriterT (
    WriterT
  ),

  -- * Runner
  runWriterT,

  -- * Operations
  tell,
) where

import Control.Applicative (
  Alternative (
    empty,
    (<|>)
  ),
 )
import Control.Monad (
  ap,
  liftM,
 )
import Mini.Transformers.Class (
  MonadTrans (
    lift
  ),
 )

{-
 - Type
 -}

-- | A transformer with monoidal write-only /w/, inner monad /m/, return /a/
newtype WriterT w m a = WriterT
  { forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT :: m (a, w)
  -- ^ Unwrap a 'WriterT' computation
  }

instance (Monad m, Monoid w) => Functor (WriterT w m) where
  fmap :: forall a b. (a -> b) -> WriterT w m a -> WriterT w m b
fmap = (a -> b) -> WriterT w m a -> WriterT w m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance (Monad m, Monoid w) => Applicative (WriterT w m) where
  pure :: forall a. a -> WriterT w m a
pure = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (a, w) -> WriterT w m a)
-> (a -> m (a, w)) -> a -> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, w) -> m (a, w)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, w) -> m (a, w)) -> (a -> (a, w)) -> a -> m (a, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,w
forall a. Monoid a => a
mempty)
  <*> :: forall a b. WriterT w m (a -> b) -> WriterT w m a -> WriterT w m b
(<*>) = WriterT w m (a -> b) -> WriterT w m a -> WriterT w m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (Monad m, Alternative m, Monoid w) => Alternative (WriterT w m) where
  empty :: forall a. WriterT w m a
empty = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT m (a, w)
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty
  WriterT w m a
m <|> :: forall a. WriterT w m a -> WriterT w m a -> WriterT w m a
<|> WriterT w m a
n = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (a, w) -> WriterT w m a) -> m (a, w) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT w m a
m m (a, w) -> m (a, w) -> m (a, w)
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT w m a
n

instance (Monad m, Monoid w) => Monad (WriterT w m) where
  WriterT w m a
m >>= :: forall a b. WriterT w m a -> (a -> WriterT w m b) -> WriterT w m b
>>= a -> WriterT w m b
k = m (b, w) -> WriterT w m b
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (b, w) -> WriterT w m b) -> m (b, w) -> WriterT w m b
forall a b. (a -> b) -> a -> b
$ do
    (a
a, w
w) <- WriterT w m a -> m (a, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT w m a
m
    (b
b, w
w') <- WriterT w m b -> m (b, w)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (a -> WriterT w m b
k a
a)
    (b, w) -> m (b, w)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b
b, w
w w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w')

instance (Monoid w) => MonadTrans (WriterT w) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
lift = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (a, w) -> WriterT w m a)
-> (m a -> m (a, w)) -> m a -> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (a, w)) -> m a -> m (a, w)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,w
forall a. Monoid a => a
mempty)

{-
 - Operations
 -}

-- | Append a value to the write-only environment
tell :: (Monad m) => w -> WriterT w m ()
tell :: forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell = m ((), w) -> WriterT w m ()
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m ((), w) -> WriterT w m ())
-> (w -> m ((), w)) -> w -> WriterT w m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), w) -> m ((), w)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((), w) -> m ((), w)) -> (w -> ((), w)) -> w -> m ((), w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((),)