module Cleff.Writer 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 outputs. This roughly corresponds to the @MonadWriter@ typeclass and @WriterT@
-- monad transformer in the @mtl@ approach.
--
-- 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

-- | 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 :: [(Type -> Type) -> Type -> Type]) 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.
--
-- __Caveat__: 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 :: [(Type -> Type) -> Type -> Type]).
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' :: (Type -> Type) -> Type -> Type)
       (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
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 (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type])
       (esSend :: [(Type -> Type) -> Type -> Type]).
Handling e es esSend =>
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 #-}

-- f :: Writer String :> es => Int -> Eff es [String]
-- f 0 = tell "0" >> pure []
-- f n = do
--   tell (show n) >> uncurry (flip (:)) <$> listen (f $ n - 1)

-- >>> runPure $ runWriter @String $ f 10
-- (["9876543210","876543210","76543210","6543210","543210","43210","3210","210","10","0"],"109876543210")