{-# LANGUAGE TupleSections #-}

-- | Description: Interpreters for 'Writer'
module Polysemy.Writer
  ( -- * Effect
    Writer (..)

    -- * Actions
  , tell
  , listen
  , pass
  , censor

    -- * Interpretations
  , runWriter
  , runLazyWriter
  , runWriterAssocR
  , runLazyWriterAssocR
  , runWriterTVar
  , writerToIOFinal
  , writerToIOAssocRFinal
  , writerToEndoWriter

    -- * Interpretations for Other Effects
  , outputToWriter
  ) where

import Control.Concurrent.STM
import qualified Control.Monad.Trans.Writer.Lazy as Lazy

import Data.Bifunctor (first)
import Data.Semigroup

import Polysemy
import Polysemy.Output
import Polysemy.State

import Polysemy.Internal.Union
import Polysemy.Internal.Writer



------------------------------------------------------------------------------
-- | @since 0.7.0.0
censor :: Member (Writer o) r
       => (o -> o)
       -> Sem r a
       -> Sem r a
censor :: forall o (r :: EffectRow) a.
Member (Writer o) r =>
(o -> o) -> Sem r a -> Sem r a
censor o -> o
f Sem r a
m = forall o (r :: EffectRow) a.
Member (Writer o) r =>
Sem r (o -> o, a) -> Sem r a
pass forall a b. (a -> b) -> a -> b
$ (o -> o
f ,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r a
m
{-# INLINE censor #-}

------------------------------------------------------------------------------
-- | Transform an 'Output' effect into a 'Writer' effect.
--
-- @since 1.0.0.0
outputToWriter :: Member (Writer o) r => Sem (Output o ': r) a -> Sem r a
outputToWriter :: forall o (r :: EffectRow) a.
Member (Writer o) r =>
Sem (Output o : r) a -> Sem r a
outputToWriter = forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret forall a b. (a -> b) -> a -> b
$ \case
  Output o
o -> forall o (r :: EffectRow). Member (Writer o) r => o -> Sem r ()
tell o
o
{-# INLINE outputToWriter #-}


------------------------------------------------------------------------------
-- | Run a 'Writer' effect in the style of
-- 'Control.Monad.Trans.Writer.Strict.WriterT'
-- (but without the nasty space leak!)
runWriter
    :: Monoid o
    => Sem (Writer o ': r) a
    -> Sem r (o, a)
runWriter :: forall o (r :: EffectRow) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
runWriter = forall s (r :: EffectRow) a.
s -> Sem (State s : r) a -> Sem r (s, a)
runState forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e1 (Sem rInitial) x -> Tactical e1 (Sem rInitial) (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpretH
  (\case
      Tell o
o -> do
        forall s (r :: EffectRow).
Member (State s) r =>
(s -> s) -> Sem r ()
modify' (forall a. Semigroup a => a -> a -> a
<> o
o) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT
      Listen Sem rInitial a1
m -> do
        Sem (Writer o : State o : r) (f a1)
mm <- forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial a1
m
        -- TODO(sandy): this is stupid
        (o
o, f a1
fa) <- forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise forall a b. (a -> b) -> a -> b
$ forall o (r :: EffectRow) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
runWriter Sem (Writer o : State o : r) (f a1)
mm
        forall s (r :: EffectRow).
Member (State s) r =>
(s -> s) -> Sem r ()
modify' (forall a. Semigroup a => a -> a -> a
<> o
o)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (o
o, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a1
fa
      Pass Sem rInitial (o -> o, x)
m -> do
        Sem (Writer o : State o : r) (f (o -> o, x))
mm <- forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: EffectRow).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial (o -> o, x)
m
        (o
o, f (o -> o, x)
t) <- forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise forall a b. (a -> b) -> a -> b
$ forall o (r :: EffectRow) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
runWriter Sem (Writer o : State o : r) (f (o -> o, x))
mm
        Inspector f
ins <- forall (e :: (* -> *) -> * -> *) (f :: * -> *) (m :: * -> *)
       (r :: EffectRow).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT
        let f :: o -> o
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a b. (a, b) -> a
fst (forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins f (o -> o, x)
t)
        forall s (r :: EffectRow).
Member (State s) r =>
(s -> s) -> Sem r ()
modify' (forall a. Semigroup a => a -> a -> a
<> o -> o
f o
o)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (o -> o, x)
t
  )
{-# INLINE runWriter #-}


------------------------------------------------------------------------------
-- | Run a 'Writer' effect in the style of 'Control.Monad.Trans.Writer.WriterT'
-- lazily.
--
-- __Warning: This inherits the nasty space leak issue of__
-- __'Lazy.WriterT'! Don't use this if you don't have to.__
--
-- @since 1.3.0.0
runLazyWriter
    :: forall o r a
     . Monoid o
    => Sem (Writer o ': r) a
    -> Sem r (o, a)
runLazyWriter :: forall o (r :: EffectRow) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
runLazyWriter = forall o (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Monoid o =>
(forall (m :: * -> *) x.
 Monad m =>
 Weaving e (WriterT o m) x -> WriterT o m x)
-> Sem (e : r) a -> Sem r (o, a)
interpretViaLazyWriter forall a b. (a -> b) -> a -> b
$ \(Weaving Writer o (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> WriterT o m (f x)
wv f a -> x
ex forall x. f x -> Maybe x
ins) ->
  case Writer o (Sem rInitial) a
e of
    Tell o
o   -> f a -> x
ex f ()
s forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Lazy.tell o
o
    Listen Sem rInitial a1
m -> do
      let m' :: WriterT o m (f a1)
m' = forall x. f (Sem rInitial x) -> WriterT o m (f x)
wv (Sem rInitial a1
m forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
      ~(f a1
fa, o
o) <- forall (m :: * -> *) w a.
Monad m =>
WriterT w m a -> WriterT w m (a, w)
Lazy.listen WriterT o m (f a1)
m'
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ f a -> x
ex forall a b. (a -> b) -> a -> b
$ (,) o
o forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a1
fa
    Pass Sem rInitial (o -> o, a)
m -> do
      let m' :: WriterT o m (f (o -> o, a))
m' = forall x. f (Sem rInitial x) -> WriterT o m (f x)
wv (Sem rInitial (o -> o, a)
m forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
      forall (m :: * -> *) w a.
Monad m =>
WriterT w m (a, w -> w) -> WriterT w m a
Lazy.pass forall a b. (a -> b) -> a -> b
$ do
        f (o -> o, a)
ft <- WriterT o m (f (o -> o, a))
m'
        let f :: o -> o
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a b. (a, b) -> a
fst (forall x. f x -> Maybe x
ins f (o -> o, a)
ft)
        forall (m :: * -> *) a. Monad m => a -> m a
return (f a -> x
ex forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (o -> o, a)
ft, o -> o
f)
{-# INLINE runLazyWriter #-}

-----------------------------------------------------------------------------
-- | Like 'runWriter', but right-associates uses of '<>'.
--
-- This asymptotically improves performance if the time complexity of '<>'
-- for the 'Monoid' depends only on the size of the first argument.
--
-- You should always use this instead of 'runWriter' if the monoid
-- is a list, such as 'String'.
--
-- @since 1.1.0.0
runWriterAssocR
    :: Monoid o
    => Sem (Writer o ': r) a
    -> Sem r (o, a)
runWriterAssocR :: forall o (r :: EffectRow) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
runWriterAssocR =
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) (forall a. Endo a -> a -> a
`appEndo` forall a. Monoid a => a
mempty)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o (r :: EffectRow) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
runWriter
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o (r :: EffectRow) a.
(Monoid o, Member (Writer (Endo o)) r) =>
Sem (Writer o : r) a -> Sem r a
writerToEndoWriter
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder
{-# INLINE runWriterAssocR #-}


-----------------------------------------------------------------------------
-- | Like 'runLazyWriter', but right-associates uses of '<>'.
--
-- This asymptotically improves performance if the time complexity of '<>'
-- for the 'Monoid' depends only on the size of the first argument.
--
-- You should always use this instead of 'runLazyWriter' if the monoid
-- is a list, such as 'String'.
--
-- __Warning: This inherits the nasty space leak issue of__
-- __'Lazy.WriterT'! Don't use this if you don't have to.__
--
-- @since 1.3.0.0
runLazyWriterAssocR
    :: Monoid o
    => Sem (Writer o ': r) a
    -> Sem r (o, a)
runLazyWriterAssocR :: forall o (r :: EffectRow) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
runLazyWriterAssocR =
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) (forall a. Endo a -> a -> a
`appEndo` forall a. Monoid a => a
mempty)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o (r :: EffectRow) a.
Monoid o =>
Sem (Writer o : r) a -> Sem r (o, a)
runLazyWriter
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o (r :: EffectRow) a.
(Monoid o, Member (Writer (Endo o)) r) =>
Sem (Writer o : r) a -> Sem r a
writerToEndoWriter
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder
{-# INLINE runLazyWriterAssocR #-}

--------------------------------------------------------------------
-- | Transform a 'Writer' effect into atomic operations
-- over a 'TVar' through final 'IO'.
--
-- @since 1.2.0.0
runWriterTVar :: (Monoid o, Member (Final IO) r)
              => TVar o
              -> Sem (Writer o ': r) a
              -> Sem r a
runWriterTVar :: forall o (r :: EffectRow) a.
(Monoid o, Member (Final IO) r) =>
TVar o -> Sem (Writer o : r) a -> Sem r a
runWriterTVar TVar o
tvar = forall o (r :: EffectRow) a.
(Member (Final IO) r, Monoid o) =>
(o -> STM ()) -> Sem (Writer o : r) a -> Sem r a
runWriterSTMAction forall a b. (a -> b) -> a -> b
$ \o
o -> do
  o
s <- forall a. TVar a -> STM a
readTVar TVar o
tvar
  forall a. TVar a -> a -> STM ()
writeTVar TVar o
tvar forall a b. (a -> b) -> a -> b
$! o
s forall a. Semigroup a => a -> a -> a
<> o
o
{-# INLINE runWriterTVar #-}


--------------------------------------------------------------------
-- | Run a 'Writer' effect by transforming it into atomic operations
-- through final 'IO'.
--
-- Internally, this simply creates a new 'TVar', passes it to
-- 'runWriterTVar', and then returns the result and the final value
-- of the 'TVar'.
--
-- /Beware/: Effects that aren't interpreted in terms of 'IO'
-- will have local state semantics in regards to 'Writer' effects
-- interpreted this way. See 'Final'.
--
-- @since 1.2.0.0
writerToIOFinal :: (Monoid o, Member (Final IO) r)
                => Sem (Writer o ': r) a
                -> Sem r (o, a)
writerToIOFinal :: forall o (r :: EffectRow) a.
(Monoid o, Member (Final IO) r) =>
Sem (Writer o : r) a -> Sem r (o, a)
writerToIOFinal Sem (Writer o : r) a
sem = do
  TVar o
tvar <- forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO forall a. Monoid a => a
mempty
  a
res  <- forall o (r :: EffectRow) a.
(Monoid o, Member (Final IO) r) =>
TVar o -> Sem (Writer o : r) a -> Sem r a
runWriterTVar TVar o
tvar Sem (Writer o : r) a
sem
  o
end  <- forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar o
tvar
  forall (m :: * -> *) a. Monad m => a -> m a
return (o
end, a
res)
{-# INLINE writerToIOFinal #-}

--------------------------------------------------------------------
-- | Like 'writerToIOFinal'. but right-associates uses of '<>'.
--
-- This asymptotically improves performance if the time complexity of '<>'
-- for the 'Monoid' depends only on the size of the first argument.
--
-- You should always use this instead of 'writerToIOFinal' if the monoid
-- is a list, such as 'String'.
--
-- /Beware/: Effects that aren't interpreted in terms of 'IO'
-- will have local state semantics in regards to 'Writer' effects
-- interpreted this way. See 'Final'.
--
-- @since 1.2.0.0
writerToIOAssocRFinal :: (Monoid o, Member (Final IO) r)
                      => Sem (Writer o ': r) a
                      -> Sem r (o, a)
writerToIOAssocRFinal :: forall o (r :: EffectRow) a.
(Monoid o, Member (Final IO) r) =>
Sem (Writer o : r) a -> Sem r (o, a)
writerToIOAssocRFinal =
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) (forall a. Endo a -> a -> a
`appEndo` forall a. Monoid a => a
mempty)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o (r :: EffectRow) a.
(Monoid o, Member (Final IO) r) =>
Sem (Writer o : r) a -> Sem r (o, a)
writerToIOFinal
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o (r :: EffectRow) a.
(Monoid o, Member (Writer (Endo o)) r) =>
Sem (Writer o : r) a -> Sem r a
writerToEndoWriter
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder
{-# INLINE writerToIOAssocRFinal #-}