WriterT.hs

{-# LANGUAGE TupleSections #-}

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

  -- * Operations
  tell,
) where

import Control.Applicative (
  Alternative,
  empty,
  (<|>),
 )
import Control.Monad (
  ap,
  liftM,
 )
import Control.Monad.IO.Class (
  MonadIO,
  liftIO,
 )
import Mini.Transformers.Class (
  MonadTrans,
  lift,
 )
import Prelude (
  Applicative,
  Functor,
  Monad,
  MonadFail,
  Monoid,
  fail,
  fmap,
  mempty,
  pure,
  ($),
  (.),
  (<*>),
  (<>),
  (>>=),
 )

-- Type

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

instance (Monad m, Monoid w) => Functor (WriterT w m) where
  fmap = liftM

instance (Monad m, Monoid w) => Applicative (WriterT w m) where
  pure = WriterT . pure . (,mempty)
  (<*>) = ap

instance (Monad m, Alternative m, Monoid w) => Alternative (WriterT w m) where
  empty = WriterT empty
  m <|> n = WriterT $ runWriterT m <|> runWriterT n

instance (Monad m, Monoid w) => Monad (WriterT w m) where
  m >>= k = WriterT $ do
    (a, w) <- runWriterT m
    (b, w') <- runWriterT (k a)
    pure (b, w <> w')

instance (Monoid w) => MonadTrans (WriterT w) where
  lift = WriterT . fmap (,mempty)

instance (MonadFail m, Monoid w) => MonadFail (WriterT w m) where
  fail = WriterT . fail

instance (MonadIO m, Monoid w) => MonadIO (WriterT w m) where
  liftIO = lift . liftIO

-- Operations

-- | Append a value to the write-only environment
tell :: (Monad m) => w -> WriterT w m ()
tell = WriterT . pure . ((),)