-- | Support for access to a write only value of a particular type.
--
-- The value is thread local. If you want it to be shared between threads, use
-- "Effectful.Writer.Static.Shared".
--
-- /Warning:/ 'Writer'\'s state will be accumulated via __left-associated__ uses
-- of '<>', which makes it unsuitable for use with types for which such pattern
-- is inefficient. __This applies, in particular, to the standard list type__,
-- which makes the 'Writer' effect pretty niche.
--
-- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the
-- @transformers@ package includes additional operations
-- 'Control.Monad.Trans.Writer.Strict.pass' and
-- 'Control.Monad.Trans.Writer.Strict.censor', they don't cooperate with runtime
-- exceptions very well, so they're deliberately omitted here.
module Effectful.Writer.Static.Local
  ( -- * Effect
    Writer

    -- ** Handlers
  , runWriter
  , execWriter

    -- ** Operations
  , tell
  , listen
  , listens
  ) where

import Control.Exception (onException, mask)
import Data.Kind

import Effectful
import Effectful.Dispatch.Static
import Effectful.Dispatch.Static.Primitive

-- | Provide access to a strict (WHNF), thread local, write only value of type
-- @w@.
data Writer (w :: Type) :: Effect

type instance DispatchOf (Writer w) = Static NoSideEffects
newtype instance StaticRep (Writer w) = Writer w

-- | Run a 'Writer' effect and return the final value along with the final
-- output.
runWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w)
runWriter :: forall w (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Monoid w) =>
Eff (Writer w : es) a -> Eff es (a, w)
runWriter Eff (Writer w : es) a
m = do
  (a
a, Writer w
w) <- StaticRep (Writer w)
-> Eff (Writer w : es) a -> Eff es (a, StaticRep (Writer w))
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es (a, StaticRep e)
runStaticRep (w -> StaticRep (Writer w)
forall w. w -> StaticRep (Writer w)
Writer w
forall a. Monoid a => a
mempty) Eff (Writer w : es) a
m
  (a, w) -> Eff es (a, w)
forall a. a -> Eff es a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
a, w
w)

-- | Run a 'Writer' effect and return the final output, discarding the final
-- value.
execWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w
execWriter :: forall w (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Monoid w) =>
Eff (Writer w : es) a -> Eff es w
execWriter Eff (Writer w : es) a
m = do
  Writer w
w <- StaticRep (Writer w)
-> Eff (Writer w : es) a -> Eff es (StaticRep (Writer w))
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects,
 MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es (StaticRep e)
execStaticRep (w -> StaticRep (Writer w)
forall w. w -> StaticRep (Writer w)
Writer w
forall a. Monoid a => a
mempty) Eff (Writer w : es) a
m
  w -> Eff es w
forall a. a -> Eff es a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure w
w

-- | Append the given output to the overall output of the 'Writer'.
tell :: (HasCallStack, Writer w :> es, Monoid w) => w -> Eff es ()
tell :: forall w (es :: [(Type -> Type) -> Type -> Type]).
(HasCallStack, Writer w :> es, Monoid w) =>
w -> Eff es ()
tell w
w = (StaticRep (Writer w) -> ((), StaticRep (Writer w))) -> Eff es ()
forall (e :: (Type -> Type) -> Type -> Type)
       (sideEffects :: SideEffects)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, DispatchOf e ~ 'Static sideEffects, e :> es) =>
(StaticRep e -> (a, StaticRep e)) -> Eff es a
stateStaticRep ((StaticRep (Writer w) -> ((), StaticRep (Writer w))) -> Eff es ())
-> (StaticRep (Writer w) -> ((), StaticRep (Writer w)))
-> Eff es ()
forall a b. (a -> b) -> a -> b
$ \(Writer w
w0) -> ((), w -> StaticRep (Writer w)
forall w. w -> StaticRep (Writer w)
Writer (w
w0 w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w))

-- | Execute an action and append its output to the overall output of the
-- 'Writer'.
--
-- /Note:/ if an exception is received while the action is executed, the partial
-- output of the action will still be appended to the overall output of the
-- 'Writer':
--
-- >>> :{
--   runEff . execWriter @String $ do
--     tell "Hi"
--     handle (\(_::ErrorCall) -> pure ((), "")) $ do
--       tell " there"
--       listen $ do
--         tell "!"
--         error "oops"
-- :}
-- "Hi there!"
listen :: (HasCallStack, Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
listen :: forall w (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, Writer w :> es, Monoid w) =>
Eff es a -> Eff es (a, w)
listen Eff es a
m = (Env es -> IO (a, w)) -> Eff es (a, w)
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO (a, w)) -> Eff es (a, w))
-> (Env es -> IO (a, w)) -> Eff es (a, w)
forall a b. (a -> b) -> a -> b
$ \Env es
es -> ((forall a. IO a -> IO a) -> IO (a, w)) -> IO (a, w)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (a, w)) -> IO (a, w))
-> ((forall a. IO a -> IO a) -> IO (a, w)) -> IO (a, w)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
  w
w0 <- Env es
-> (EffectRep (DispatchOf (Writer w)) (Writer w)
    -> (w, EffectRep (DispatchOf (Writer w)) (Writer w)))
-> IO w
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, e :> es) =>
Env es
-> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e))
-> IO a
stateEnv Env es
es ((EffectRep (DispatchOf (Writer w)) (Writer w)
  -> (w, EffectRep (DispatchOf (Writer w)) (Writer w)))
 -> IO w)
-> (EffectRep (DispatchOf (Writer w)) (Writer w)
    -> (w, EffectRep (DispatchOf (Writer w)) (Writer w)))
-> IO w
forall a b. (a -> b) -> a -> b
$ \(Writer w
w) -> (w
w, w -> StaticRep (Writer w)
forall w. w -> StaticRep (Writer w)
Writer w
forall a. Monoid a => a
mempty)
  a
a <- IO a -> IO a
forall a. IO a -> IO a
unmask (Eff es a -> Env es -> IO a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
Eff es a -> Env es -> IO a
unEff Eff es a
m Env es
es) IO a -> IO w -> IO a
forall a b. IO a -> IO b -> IO a
`onException` Env es -> w -> IO w
forall {w} {es :: [(Type -> Type) -> Type -> Type]}.
(Writer w :> es, Semigroup w) =>
Env es -> w -> IO w
merge Env es
es w
w0
  (a
a, ) (w -> (a, w)) -> IO w -> IO (a, w)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Env es -> w -> IO w
forall {w} {es :: [(Type -> Type) -> Type -> Type]}.
(Writer w :> es, Semigroup w) =>
Env es -> w -> IO w
merge Env es
es w
w0
  where
    merge :: Env es -> w -> IO w
merge Env es
es w
w0 =
      -- If an exception is thrown, restore w0 and keep parts of w1.
      Env es
-> (EffectRep (DispatchOf (Writer w)) (Writer w)
    -> (w, EffectRep (DispatchOf (Writer w)) (Writer w)))
-> IO w
forall (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(HasCallStack, e :> es) =>
Env es
-> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e))
-> IO a
stateEnv Env es
es ((EffectRep (DispatchOf (Writer w)) (Writer w)
  -> (w, EffectRep (DispatchOf (Writer w)) (Writer w)))
 -> IO w)
-> (EffectRep (DispatchOf (Writer w)) (Writer w)
    -> (w, EffectRep (DispatchOf (Writer w)) (Writer w)))
-> IO w
forall a b. (a -> b) -> a -> b
$ \(Writer w
w1) -> (w
w1, w -> StaticRep (Writer w)
forall w. w -> StaticRep (Writer w)
Writer (w
w0 w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w1))

-- | Execute an action and append its output to the overall output of the
-- 'Writer', then return the final value along with a function of the recorded
-- output.
--
-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@
listens
  :: (HasCallStack, Writer w :> es, Monoid w)
  => (w -> b)
  -> Eff es a
  -> Eff es (a, b)
listens :: forall w (es :: [(Type -> Type) -> Type -> Type]) b a.
(HasCallStack, Writer w :> es, Monoid w) =>
(w -> b) -> Eff es a -> Eff es (a, b)
listens w -> b
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.
(HasCallStack, Writer w :> es, Monoid w) =>
Eff es a -> Eff es (a, w)
listen Eff es a
m
  (a, b) -> Eff es (a, b)
forall a. a -> Eff es a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (a
a, w -> b
f w
w)

-- $setup
-- >>> import Control.Exception (ErrorCall)
-- >>> import Effectful.Exception