{-# LANGUAGE TemplateHaskell #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Effect.Writer
-- Copyright   :  (c) Michael Szvetits, 2020
-- License     :  BSD3 (see the file LICENSE)
-- Maintainer  :  typedbyte@qualified.name
-- Stability   :  stable
-- Portability :  portable
--
-- The writer effect, similar to the @MonadWriter@ type class from the @mtl@
-- library.
--
-- Lazy and strict interpretations of the effect are available here:
-- "Control.Effect.Writer.Lazy" and "Control.Effect.Writer.Strict".
-----------------------------------------------------------------------------
module Control.Effect.Writer
  ( -- * Tagged Writer Effect
    Writer'(..)
    -- * Convenience Functions
  , listens'
    -- * Untagged Writer Effect
    -- | If you don't require disambiguation of multiple writer effects
    -- (i.e., you only have one writer effect in your monadic context),
    -- it is recommended to always use the untagged writer effect.
  , Writer
  , tell
  , listen
  , censor
  , listens
    -- * Tagging and Untagging
    -- | Conversion functions between the tagged and untagged writer effect,
    -- usually used in combination with type applications, like:
    --
    -- @
    --     'tagWriter'' \@\"newTag\" program
    --     'retagWriter'' \@\"oldTag\" \@\"newTag\" program
    --     'untagWriter'' \@\"erasedTag\" program
    -- @
    -- 
  , tagWriter'
  , retagWriter'
  , untagWriter'
  ) where

-- base
import Data.Tuple (swap)

-- transformers
import qualified Control.Monad.Trans.RWS.CPS     as Strict
import qualified Control.Monad.Trans.RWS.Lazy    as Lazy
import qualified Control.Monad.Trans.Writer.Lazy as L
import qualified Control.Monad.Trans.Writer.CPS  as S

import Control.Effect.Machinery

-- | An effect that adds a write-only, accumulated output to a given computation.
class (Monad m, Monoid w) => Writer' tag w m | tag m -> w where
  -- | Produces the output @w@. In other words, @w@ is appended to the accumulated output.
  tell' :: w -> m ()
  -- | Executes a sub-computation and appends @w@ to the accumulated output.
  listen' :: m a -> m (w, a)
  -- | Executes a sub-computation and applies the function to its output.
  censor' :: (w -> w) -- ^ The function which is applied to the output.
          -> m a      -- ^ The sub-computation which produces the modified output.
          -> m a      -- ^ The result of the sub-computation.

makeTaggedEffect ''Writer'

instance (Monad m, Monoid w) => Writer' tag w (L.WriterT w m) where
  tell' :: w -> WriterT w m ()
tell' = w -> WriterT w m ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
L.tell
  {-# INLINE tell' #-}
  listen' :: WriterT w m a -> WriterT w m (w, a)
listen' = ((a, w) -> (w, a)) -> WriterT w m (a, w) -> WriterT w m (w, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> (w, a)
forall a b. (a, b) -> (b, a)
swap (WriterT w m (a, w) -> WriterT w m (w, a))
-> (WriterT w m a -> WriterT w m (a, w))
-> WriterT w m a
-> WriterT w m (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT w m a -> WriterT w m (a, w)
forall (m :: * -> *) w a.
Monad m =>
WriterT w m a -> WriterT w m (a, w)
L.listen
  {-# INLINE listen' #-}
  censor' :: (w -> w) -> WriterT w m a -> WriterT w m a
censor' = (w -> w) -> WriterT w m a -> WriterT w m a
forall (m :: * -> *) w a.
Monad m =>
(w -> w) -> WriterT w m a -> WriterT w m a
L.censor
  {-# INLINE censor' #-}

instance (Monad m, Monoid w) => Writer' tag w (S.WriterT w m) where
  tell' :: w -> WriterT w m ()
tell' = w -> WriterT w m ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
S.tell
  {-# INLINE tell' #-}
  listen' :: WriterT w m a -> WriterT w m (w, a)
listen' = ((a, w) -> (w, a)) -> WriterT w m (a, w) -> WriterT w m (w, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> (w, a)
forall a b. (a, b) -> (b, a)
swap (WriterT w m (a, w) -> WriterT w m (w, a))
-> (WriterT w m a -> WriterT w m (a, w))
-> WriterT w m a
-> WriterT w m (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT w m a -> WriterT w m (a, w)
forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
WriterT w m a -> WriterT w m (a, w)
S.listen
  {-# INLINE listen' #-}
  censor' :: (w -> w) -> WriterT w m a -> WriterT w m a
censor' = (w -> w) -> WriterT w m a -> WriterT w m a
forall w (m :: * -> *) a.
(Monoid w, Monad m) =>
(w -> w) -> WriterT w m a -> WriterT w m a
S.censor
  {-# INLINE censor' #-}

instance (Monad m, Monoid w) => Writer' tag w (Lazy.RWST r w s m) where
  tell' :: w -> RWST r w s m ()
tell' = w -> RWST r w s m ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
Lazy.tell
  {-# INLINE tell' #-}
  listen' :: RWST r w s m a -> RWST r w s m (w, a)
listen' = ((a, w) -> (w, a)) -> RWST r w s m (a, w) -> RWST r w s m (w, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> (w, a)
forall a b. (a, b) -> (b, a)
swap (RWST r w s m (a, w) -> RWST r w s m (w, a))
-> (RWST r w s m a -> RWST r w s m (a, w))
-> RWST r w s m a
-> RWST r w s m (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWST r w s m a -> RWST r w s m (a, w)
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> RWST r w s m (a, w)
Lazy.listen
  {-# INLINE listen' #-}
  censor' :: (w -> w) -> RWST r w s m a -> RWST r w s m a
censor' = (w -> w) -> RWST r w s m a -> RWST r w s m a
forall (m :: * -> *) w r s a.
Monad m =>
(w -> w) -> RWST r w s m a -> RWST r w s m a
Lazy.censor
  {-# INLINE censor' #-}

instance (Monad m, Monoid w) => Writer' tag w (Strict.RWST r w s m) where
  tell' :: w -> RWST r w s m ()
tell' = w -> RWST r w s m ()
forall w (m :: * -> *) r s.
(Monoid w, Monad m) =>
w -> RWST r w s m ()
Strict.tell
  {-# INLINE tell' #-}
  listen' :: RWST r w s m a -> RWST r w s m (w, a)
listen' = ((a, w) -> (w, a)) -> RWST r w s m (a, w) -> RWST r w s m (w, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, w) -> (w, a)
forall a b. (a, b) -> (b, a)
swap (RWST r w s m (a, w) -> RWST r w s m (w, a))
-> (RWST r w s m a -> RWST r w s m (a, w))
-> RWST r w s m a
-> RWST r w s m (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWST r w s m a -> RWST r w s m (a, w)
forall w (m :: * -> *) r s a.
(Monoid w, Monad m) =>
RWST r w s m a -> RWST r w s m (a, w)
Strict.listen
  {-# INLINE listen' #-}
  censor' :: (w -> w) -> RWST r w s m a -> RWST r w s m a
censor' = (w -> w) -> RWST r w s m a -> RWST r w s m a
forall w (m :: * -> *) r s a.
(Monoid w, Monad m) =>
(w -> w) -> RWST r w s m a -> RWST r w s m a
Strict.censor
  {-# INLINE censor' #-}

-- | Executes a sub-computation and applies the function to its output, thus adding
-- an additional value to the result of the sub-computation.
listens' :: forall tag w b m a. Writer' tag w m
         => (w -> b) -- ^ The function which is applied to the output.
         -> m a      -- ^ The sub-computation which produces the modified output.
         -> m (b, a) -- ^ The result of the sub-computation, including the modified output.
listens' :: (w -> b) -> m a -> m (b, a)
listens' w -> b
f m a
action = do
  ~(w
w, a
a) <- m a -> m (w, a)
forall k (tag :: k) w (m :: * -> *) a.
Writer' tag w m =>
m a -> m (w, a)
listen' @tag m a
action
  (b, a) -> m (b, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (w -> b
f w
w, a
a)
{-# INLINE listens' #-}

makeUntagged ['listens']