{-# 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'(..)
    -- * 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
    -- * Convenience Functions

    -- | 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 functions.

  , listens'
  , 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 => 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad).
(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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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 :: SomeMonad) 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' f :: w -> b
f action :: m a
action = do
  ~(w :: w
w, a :: a
a) <- m a -> m (w, a)
forall k (tag :: k) w (m :: SomeMonad) a.
Writer' tag w m =>
m a -> m (w, a)
listen' @tag m a
action
  (b, a) -> m (b, a)
forall (f :: SomeMonad) a. Applicative f => a -> f a
pure (w -> b
f w
w, a
a)
{-# INLINE listens' #-}

-- | The untagged version of 'listens''.

listens :: Writer w m => (w -> b) -> m a -> m (b, a)
listens :: (w -> b) -> m a -> m (b, a)
listens = forall k (tag :: k) w b (m :: SomeMonad) a.
Writer' tag w m =>
(w -> b) -> m a -> m (b, a)
forall w b (m :: SomeMonad) a.
Writer' G w m =>
(w -> b) -> m a -> m (b, a)
listens' @G
{-# INLINE listens #-}