diff --git a/effectful.cabal b/effectful.cabal index 62bd020..3fb0e76 100644 --- a/effectful.cabal +++ b/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 diff --git a/src/Effectful/Class/Writer.hs b/src/Effectful/Class/Writer.hs index 7121a31..e2bf907 100644 --- a/src/Effectful/Class/Writer.hs +++ b/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'. diff --git a/src/Effectful/Writer/Dynamic.hs b/src/Effectful/Writer/Dynamic.hs new file mode 100644 index 0000000..c6d24c0 --- /dev/null +++ b/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) diff --git a/src/Effectful/Writer/MVar.hs b/src/Effectful/Writer/MVar.hs new file mode 100644 index 0000000..f824b11 --- /dev/null +++ b/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)