module Effectful.Writer.Static.Shared
(
Writer
, runWriter
, execWriter
, tell
, listen
, listens
) where
import Control.Exception (onException, uninterruptibleMask)
import Effectful
import Effectful.Dispatch.Static
import Effectful.Dispatch.Static.Primitive
import Effectful.Internal.Utils
data Writer w :: Effect
type instance DispatchOf (Writer w) = Static NoSideEffects
newtype instance StaticRep (Writer w) = Writer (MVar' w)
runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
runWriter :: forall w (es :: [(Type -> Type) -> Type -> Type]) a.
Monoid w =>
Eff (Writer w : es) a -> Eff es (a, w)
runWriter Eff (Writer w : es) a
m = do
MVar' w
v <- IO (MVar' w) -> Eff es (MVar' w)
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (IO (MVar' w) -> Eff es (MVar' w))
-> IO (MVar' w) -> Eff es (MVar' w)
forall a b. (a -> b) -> a -> b
$ w -> IO (MVar' w)
forall a. a -> IO (MVar' a)
newMVar' w
forall a. Monoid a => a
mempty
a
a <- StaticRep (Writer w) -> Eff (Writer w : es) a -> Eff es a
forall (e :: (Type -> Type) -> Type -> Type)
(sideEffects :: SideEffects)
(es :: [(Type -> Type) -> Type -> Type]) a.
(DispatchOf e ~ 'Static sideEffects, MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (MVar' w -> StaticRep (Writer w)
forall w. MVar' w -> StaticRep (Writer w)
Writer MVar' w
v) Eff (Writer w : es) a
m
(a
a, ) (w -> (a, w)) -> Eff es w -> Eff es (a, w)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO w -> Eff es w
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (MVar' w -> IO w
forall a. MVar' a -> IO a
readMVar' MVar' w
v)
execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
execWriter :: forall w (es :: [(Type -> Type) -> Type -> Type]) a.
Monoid w =>
Eff (Writer w : es) a -> Eff es w
execWriter Eff (Writer w : es) a
m = do
MVar' w
v <- IO (MVar' w) -> Eff es (MVar' w)
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (IO (MVar' w) -> Eff es (MVar' w))
-> IO (MVar' w) -> Eff es (MVar' w)
forall a b. (a -> b) -> a -> b
$ w -> IO (MVar' w)
forall a. a -> IO (MVar' a)
newMVar' w
forall a. Monoid a => a
mempty
a
_ <- StaticRep (Writer w) -> Eff (Writer w : es) a -> Eff es a
forall (e :: (Type -> Type) -> Type -> Type)
(sideEffects :: SideEffects)
(es :: [(Type -> Type) -> Type -> Type]) a.
(DispatchOf e ~ 'Static sideEffects, MaybeIOE sideEffects es) =>
StaticRep e -> Eff (e : es) a -> Eff es a
evalStaticRep (MVar' w -> StaticRep (Writer w)
forall w. MVar' w -> StaticRep (Writer w)
Writer MVar' w
v) Eff (Writer w : es) a
m
IO w -> Eff es w
forall a (es :: [(Type -> Type) -> Type -> Type]). IO a -> Eff es a
unsafeEff_ (IO w -> Eff es w) -> IO w -> Eff es w
forall a b. (a -> b) -> a -> b
$ MVar' w -> IO w
forall a. MVar' a -> IO a
readMVar' MVar' w
v
tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
tell :: forall w (es :: [(Type -> Type) -> Type -> Type]).
(Writer w :> es, Monoid w) =>
w -> Eff es ()
tell w
w1 = (Env es -> IO ()) -> Eff es ()
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO ()) -> Eff es ()) -> (Env es -> IO ()) -> Eff es ()
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
Writer MVar' w
v <- Env es -> IO (EffectRep (DispatchOf (Writer w)) (Writer w))
forall (e :: (Type -> Type) -> Type -> Type)
(es :: [(Type -> Type) -> Type -> Type]).
(e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env es
es
MVar' w -> (w -> IO w) -> IO ()
forall a. MVar' a -> (a -> IO a) -> IO ()
modifyMVar_' MVar' w
v ((w -> IO w) -> IO ()) -> (w -> IO w) -> IO ()
forall a b. (a -> b) -> a -> b
$ \w
w0 -> let w :: w
w = w
w0 w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w1 in w -> IO w
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure w
w
listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
listen :: forall w (es :: [(Type -> Type) -> Type -> Type]) a.
(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 -> do
((forall a. IO a -> IO a) -> IO (a, w)) -> IO (a, w)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask (((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
MVar' w
v1 <- w -> IO (MVar' w)
forall a. a -> IO (MVar' a)
newMVar' w
forall a. Monoid a => a
mempty
MVar' w
v0 <- Env es
-> (EffectRep (DispatchOf (Writer w)) (Writer w)
-> IO (MVar' w, EffectRep (DispatchOf (Writer w)) (Writer w)))
-> IO (MVar' w)
forall (e :: (Type -> Type) -> Type -> Type)
(es :: [(Type -> Type) -> Type -> Type]) a.
(e :> es) =>
Env es
-> (EffectRep (DispatchOf e) e
-> IO (a, EffectRep (DispatchOf e) e))
-> IO a
stateEnv Env es
es ((EffectRep (DispatchOf (Writer w)) (Writer w)
-> IO (MVar' w, EffectRep (DispatchOf (Writer w)) (Writer w)))
-> IO (MVar' w))
-> (EffectRep (DispatchOf (Writer w)) (Writer w)
-> IO (MVar' w, EffectRep (DispatchOf (Writer w)) (Writer w)))
-> IO (MVar' w)
forall a b. (a -> b) -> a -> b
$ \(Writer MVar' w
v) -> (MVar' w, StaticRep (Writer w))
-> IO (MVar' w, StaticRep (Writer w))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (MVar' w
v, MVar' w -> StaticRep (Writer w)
forall w. MVar' w -> StaticRep (Writer w)
Writer MVar' w
v1)
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 -> MVar' w -> MVar' w -> IO w
forall {b} {es :: [(Type -> Type) -> Type -> Type]}.
(Writer b :> es, Semigroup b) =>
Env es -> MVar' b -> MVar' b -> IO b
merge Env es
es MVar' w
v0 MVar' w
v1
(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 -> MVar' w -> MVar' w -> IO w
forall {b} {es :: [(Type -> Type) -> Type -> Type]}.
(Writer b :> es, Semigroup b) =>
Env es -> MVar' b -> MVar' b -> IO b
merge Env es
es MVar' w
v0 MVar' w
v1
where
merge :: Env es -> MVar' b -> MVar' b -> IO b
merge Env es
es MVar' b
v0 MVar' b
v1 = do
Env es -> EffectRep (DispatchOf (Writer b)) (Writer b) -> IO ()
forall (e :: (Type -> Type) -> Type -> Type)
(es :: [(Type -> Type) -> Type -> Type]).
(e :> es) =>
Env es -> EffectRep (DispatchOf e) e -> IO ()
putEnv Env es
es (EffectRep (DispatchOf (Writer b)) (Writer b) -> IO ())
-> EffectRep (DispatchOf (Writer b)) (Writer b) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar' b -> StaticRep (Writer b)
forall w. MVar' w -> StaticRep (Writer w)
Writer MVar' b
v0
b
w1 <- MVar' b -> IO b
forall a. MVar' a -> IO a
readMVar' MVar' b
v1
MVar' b -> (b -> IO b) -> IO ()
forall a. MVar' a -> (a -> IO a) -> IO ()
modifyMVar_' MVar' b
v0 ((b -> IO b) -> IO ()) -> (b -> IO b) -> IO ()
forall a b. (a -> b) -> a -> b
$ \b
w0 -> let w :: b
w = b
w0 b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
w1 in b -> IO b
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
w
b -> IO b
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
w1
listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)
listens :: forall w (es :: [(Type -> Type) -> Type -> Type]) b a.
(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.
(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)