{-# LANGUAGE Trustworthy #-}
-- |
-- Copyright: (c) 2021 Xy Ren
-- License: BSD3
-- Maintainer: xy.r@outlook.com
-- Stability: experimental
-- Portability: non-portable (GHC only)
module Cleff.Writer
  ( -- * Effect
    Writer (..)
    -- * Operations
  , tell
  , listen
  , listens
    -- * Interpretations
  , runWriter
  , runWriterBatch
  ) where

import           Cleff
import           Cleff.Internal.Base
import           Data.Atomics        (atomicModifyIORefCAS_)
import           Data.Foldable       (traverse_)
import           UnliftIO.IORef      (IORef, newIORef, readIORef)

-- * Effect

-- | An effect capable of accumulating monoidal outputs. This roughly corresponds to the @MonadWriter@ typeclass and
-- @WriterT@ monad transformer in the @mtl@ library.
--
-- However, note that this does not have a @pass@ operation as we are not sure what its semantics should be. In fact,
-- the @pass@ semantics in @mtl@ is also unclear and will change when handlers are put in different orders. To avoid
-- any confusion we decided it is best that we don't include it because no one seems to be relying on it anyway.
data Writer w :: Effect where
  Tell :: w -> Writer w m ()
  Listen :: m a -> Writer w m (a, w)

-- * Operations

makeEffect_ ''Writer

-- | Produces an output that is appended to the accumulated value.
tell :: Writer w :> es => w -> Eff es ()

-- | Monitor the output of a computation, and return the output alongside the computation's result.
listen :: Writer w :> es => Eff es a -> Eff es (a, w)

-- | Apply a function to the accumulated output of 'listen'.
listens :: Writer w :> es => (w -> x) -> Eff es a -> Eff es (a, x)
listens :: (w -> x) -> Eff es a -> Eff es (a, x)
listens w -> x
f Eff es a
m = do
  (a
a, w
w) <- Eff es a -> Eff es (a, w)
forall w (es :: [Effect]) a.
(Writer w :> es) =>
Eff es a -> Eff es (a, w)
listen Eff es a
m
  (a, x) -> Eff es (a, x)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
a, w -> x
f w
w)

-- * Interpretations

-- | Run a monoidal 'Writer' effect.
--
-- === Caveats
--
-- Both 'runWriter' and 'listen's under 'runWriter' will stop taking care of writer operations done on
-- forked threads as soon as the main thread finishes its computation. Any writer operation done
-- /before main thread finishes/ is still taken into account.
runWriter :: ∀ w es a. Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
runWriter :: Eff (Writer w : es) a -> Eff es (a, w)
runWriter Eff (Writer w : es) a
m = Eff (IOE : es) (a, w) -> Eff es (a, w)
forall (es :: [Effect]). Eff (IOE : es) ~> Eff es
thisIsPureTrustMe do
  IORef w
rw <- w -> Eff (IOE : es) (IORef w)
forall (m :: Type -> Type) a. MonadIO m => a -> m (IORef a)
newIORef w
forall a. Monoid a => a
mempty
  a
x <- Handler (Writer w) (IOE : es)
-> Eff (Writer w : es) a -> Eff (IOE : es) a
forall (e' :: Effect) (e :: Effect) (es :: [Effect]).
Handler e (e' : es) -> Eff (e : es) ~> Eff (e' : es)
reinterpret ([IORef w] -> Handler (Writer w) (IOE : es)
h [IORef w
rw]) Eff (Writer w : es) a
m
  w
w' <- IORef w -> Eff (IOE : es) w
forall (m :: Type -> Type) a. MonadIO m => IORef a -> m a
readIORef IORef w
rw
  (a, w) -> Eff (IOE : es) (a, w)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
x, w
w')
  where
    h :: [IORef w] -> Handler (Writer w) (IOE : es)
    h :: [IORef w] -> Handler (Writer w) (IOE : es)
h [IORef w]
rws = \case
      Tell w
w' -> (IORef w -> Eff (IOE : es) ()) -> [IORef w] -> Eff (IOE : es) ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\IORef w
rw -> IO () -> Eff (IOE : es) ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff (IOE : es) ()) -> IO () -> Eff (IOE : es) ()
forall a b. (a -> b) -> a -> b
$ IORef w -> (w -> w) -> IO ()
forall t. IORef t -> (t -> t) -> IO ()
atomicModifyIORefCAS_ IORef w
rw (w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w')) [IORef w]
rws
      Listen Eff esSend a
m' -> do
        IORef w
rw' <- w -> Eff (IOE : es) (IORef w)
forall (m :: Type -> Type) a. MonadIO m => a -> m (IORef a)
newIORef w
forall a. Monoid a => a
mempty
        a
x <- Handler (Writer w) (IOE : es) -> Eff esSend a -> Eff (IOE : es) a
forall (esSend :: [Effect]) (e :: Effect) (es :: [Effect]).
Handling esSend e es =>
Handler e es -> Eff esSend ~> Eff es
toEffWith ([IORef w] -> Handler (Writer w) (IOE : es)
h ([IORef w] -> Handler (Writer w) (IOE : es))
-> [IORef w] -> Handler (Writer w) (IOE : es)
forall a b. (a -> b) -> a -> b
$ IORef w
rw' IORef w -> [IORef w] -> [IORef w]
forall a. a -> [a] -> [a]
: [IORef w]
rws) Eff esSend a
m'
        w
w' <- IORef w -> Eff (IOE : es) w
forall (m :: Type -> Type) a. MonadIO m => IORef a -> m a
readIORef IORef w
rw'
        (a, w) -> Eff (IOE : es) (a, w)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
x, w
w')
{-# INLINE runWriter #-}

-- | Run a monoidal 'Writer' effect, but appends the listened output to the parent value only when the listen operation
-- finishes. This means that when you run two 'listen's on two threads, the values 'tell'ed inside will not be appended
-- to the parent value in real time, but only after the thread finishes 'listen'ing. For example, this code
--
-- @
-- 'UnliftIO.concurrently_'
--   ('listen' '$' 'tell' "1" '>>' 'tell' "2" '>>' 'tell' "3")
--   ('listen' '$' 'tell' "4" '>>' 'tell' "5" '>>' 'tell' "6")
-- @
--
-- will produce either @"123456"@ or @"456123"@ with 'runWriterBatch', but may produce these digits in any order with
-- 'runWriter'.
--
-- This version of interpreter can be faster than 'runWriter' in 'listen'-intense code. It is subject to all caveats
-- of 'runWriter'.
--
-- @since 0.2.0.0
runWriterBatch :: ∀ w es a. Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
runWriterBatch :: Eff (Writer w : es) a -> Eff es (a, w)
runWriterBatch Eff (Writer w : es) a
m = Eff (IOE : es) (a, w) -> Eff es (a, w)
forall (es :: [Effect]). Eff (IOE : es) ~> Eff es
thisIsPureTrustMe do
  IORef w
rw <- w -> Eff (IOE : es) (IORef w)
forall (m :: Type -> Type) a. MonadIO m => a -> m (IORef a)
newIORef w
forall a. Monoid a => a
mempty
  a
x <- Handler (Writer w) (IOE : es)
-> Eff (Writer w : es) a -> Eff (IOE : es) a
forall (e' :: Effect) (e :: Effect) (es :: [Effect]).
Handler e (e' : es) -> Eff (e : es) ~> Eff (e' : es)
reinterpret (IORef w -> Handler (Writer w) (IOE : es)
h IORef w
rw) Eff (Writer w : es) a
m
  w
w' <- IORef w -> Eff (IOE : es) w
forall (m :: Type -> Type) a. MonadIO m => IORef a -> m a
readIORef IORef w
rw
  (a, w) -> Eff (IOE : es) (a, w)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
x, w
w')
  where
    h :: IORef w -> Handler (Writer w) (IOE : es)
    h :: IORef w -> Handler (Writer w) (IOE : es)
h IORef w
rw = \case
      Tell w
w' -> IO () -> Eff (IOE : es) ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff (IOE : es) ()) -> IO () -> Eff (IOE : es) ()
forall a b. (a -> b) -> a -> b
$ IORef w -> (w -> w) -> IO ()
forall t. IORef t -> (t -> t) -> IO ()
atomicModifyIORefCAS_ IORef w
rw (w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w')
      Listen Eff esSend a
m' -> do
        IORef w
rw' <- w -> Eff (IOE : es) (IORef w)
forall (m :: Type -> Type) a. MonadIO m => a -> m (IORef a)
newIORef w
forall a. Monoid a => a
mempty
        a
x <- Handler (Writer w) (IOE : es) -> Eff esSend a -> Eff (IOE : es) a
forall (esSend :: [Effect]) (e :: Effect) (es :: [Effect]).
Handling esSend e es =>
Handler e es -> Eff esSend ~> Eff es
toEffWith (IORef w -> Handler (Writer w) (IOE : es)
h IORef w
rw') Eff esSend a
m'
        w
w' <- IORef w -> Eff (IOE : es) w
forall (m :: Type -> Type) a. MonadIO m => IORef a -> m a
readIORef IORef w
rw'
        IO () -> Eff (IOE : es) ()
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff (IOE : es) ()) -> IO () -> Eff (IOE : es) ()
forall a b. (a -> b) -> a -> b
$ IORef w -> (w -> w) -> IO ()
forall t. IORef t -> (t -> t) -> IO ()
atomicModifyIORefCAS_ IORef w
rw (w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w')
        (a, w) -> Eff (IOE : es) (a, w)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
x, w
w')
{-# INLINE runWriterBatch #-}