Add MVar and Dynamic version of Writer

effectful.cabal

@@ -83,6 +83,8 @@ library
                      Effectful.State.MVar
                      Effectful.STM
                      Effectful.Writer
+                     Effectful.Writer.Dynamic
+                     Effectful.Writer.MVar
 
 test-suite test
     import:         language

src/Effectful/Class/Writer.hs

@@ -6,7 +6,7 @@ import Control.Monad.Trans.Control
 
 import Effectful.Internal.Effect
 import Effectful.Internal.Monad
-import qualified Effectful.Writer as W
+import qualified Effectful.Writer.Dynamic as W
 
 -- | Compatiblity layer for a transition period from MTL-style effect handling
 -- to 'Effectful.Eff'.

src/Effectful/Writer/Dynamic.hs

@@ -0,0 +1,88 @@
+module Effectful.Writer.Dynamic
+  ( Writer(..)
+
+  -- * Pure
+  , runWriter
+  , execWriter
+
+  -- * MVar
+  , runWriterMVar
+  , execWriterMVar
+
+  -- * Operations
+  , writer
+  , tell
+  , listen
+  , listens
+  ) where
+
+import Effectful.Internal.Effect
+import Effectful.Internal.Monad
+import Effectful.Interpreter
+
+import qualified Effectful.Writer as WP
+import qualified Effectful.Writer.MVar as WM
+
+data Writer w :: Effect where
+  Writer :: (a, w) -> Writer w m a
+  Tell   :: ~w     -> Writer w m ()
+  Listen :: m a    -> Writer w m (a, w)
+
+----------------------------------------
+-- Pure
+
+runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
+runWriter = reinterpretM WP.runWriter writerPure
+
+execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
+execWriter = reinterpretM WP.execWriter writerPure
+
+writerPure
+  :: (Monoid w, WP.Writer w :> localEs)
+  => RunIn es (Eff localEs)
+  -> Writer w (Eff es) a
+  -> Eff localEs a
+writerPure run = \case
+  Writer aw -> WP.writer aw
+  Tell w    -> WP.tell w
+  Listen m  -> WP.listen (run m)
+
+----------------------------------------
+-- MVar
+
+runWriterMVar :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
+runWriterMVar = reinterpretM WM.runWriter writerMVar
+
+execWriterMVar :: Monoid w => Eff (Writer w : es) a -> Eff es w
+execWriterMVar = reinterpretM WM.execWriter writerMVar
+
+writerMVar
+  :: (Monoid w, WM.Writer w :> localEs)
+  => RunIn es (Eff localEs)
+  -> Writer w (Eff es) a
+  -> Eff localEs a
+writerMVar run = \case
+  Writer aw -> WM.writer aw
+  Tell w    -> WM.tell w
+  Listen m  -> WM.listen (run m)
+
+----------------------------------------
+-- Operations
+
+writer :: (Writer w :> es, Monoid w) => (a, w) -> Eff es a
+writer = send . Writer
+
+tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
+tell = send . Tell
+
+listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
+listen = send . Listen
+
+listens
+  :: (Writer w :> es, Monoid w)
+  => (w -> b)
+  -> Eff es a
+  -> Eff es (a, b)
+listens f m = do
+  (a, w) <- listen m
+  pure (a, f w)

src/Effectful/Writer/MVar.hs

@@ -0,0 +1,71 @@
+module Effectful.Writer.MVar
+  ( Writer
+  , runWriter
+  , execWriter
+  , writer
+  , tell
+  , listen
+  , listens
+  ) where
+
+import Control.Concurrent.MVar
+import Control.Monad.Catch
+
+import Effectful.Internal.Effect
+import Effectful.Internal.Env
+import Effectful.Internal.Monad
+
+newtype Writer w :: Effect where
+  Writer :: MVar w -> Writer w m r
+
+runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
+runWriter m = do
+  v <- unsafeEff_ $ newMVar mempty
+  a <- evalEffect (IdE (Writer v)) m
+  (a, ) <$> unsafeEff_ (readMVar v)
+
+execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
+execWriter m = do
+  v <- unsafeEff_ $ newMVar mempty
+  _ <- evalEffect (IdE (Writer v)) m
+  unsafeEff_ $ readMVar v
+
+writer :: (Writer w :> es, Monoid w) => (a, w) -> Eff es a
+writer (a, w1) = do
+  IdE (Writer v) <- getEffect
+  unsafeEff_ . modifyMVar v $ \w0 -> let w = w0 `mappend` w1 in w `seq` pure (w, a)
+
+tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
+tell w1 = do
+  IdE (Writer v) <- getEffect
+  unsafeEff_ . modifyMVar_ v $ \w0 -> let w = w0 `mappend` w1 in w `seq` pure w
+
+listen
+  :: forall w es a. (Writer w :> es, Monoid w)
+  => Eff es a
+  -> Eff es (a, w)
+listen (Eff m) = unsafeEff $ \es -> uninterruptibleMask $ \restore -> do
+  v1 <- newMVar mempty
+  -- Replace thread local MVar with a fresh one for isolated listening.
+  v0 <- unsafeStateEnv (\(IdE (Writer v)) -> (v, IdE (Writer v1))) es
+  a <- restore (m es) `onException` merge es v0 v1
+  (a, ) <$> merge es v0 v1
+  where
+    -- Merge results accumulated in the local MVar with the mainline. If an
+    -- exception was received while listening, merge results recorded so far.
+    merge es v0 v1 = do
+      unsafePutEnv @(Writer w) (IdE (Writer v0)) es
+      w1 <- readMVar v1
+      -- The mask is uninterruptible because modifyMVar_ v0 might block and if
+      -- we get an async exception while waiting, w1 will be lost.
+      modifyMVar_ v0 $ \w0 -> let w = w0 `mappend` w1 in w `seq` pure w
+      pure w1
+
+listens
+  :: (Writer w :> es, Monoid w)
+  => (w -> b)
+  -> Eff es a
+  -> Eff es (a, b)
+listens f m = do
+  (a, w) <- listen m
+  pure (a, f w)