git.iko.soy/effectful
on master help sign in
Add MVar and Dynamic version of Writer
commiteb1e75e3e0d50ac3562ba4529cbc2ec91c2d45ae authorAndrzej Rybczak <andrzej@rybczak.net> dateSat 26 Jun 2021, 16:03 (5 years ago) parent26001d9
4 files changed+162−1
compare with master
unifiedsplit
effectful.cabal+2 src/Effectful/Class/Writer.hs+1−1 src/Effectful/Writer/Dynamic.hs+88 src/Effectful/Writer/MVar.hs+71
effectful.cabal+2
@@ -83,6 +83,8 @@ library
8383 Effectful.State.MVar
8484 Effectful.STM
8585 Effectful.Writer
86+ Effectful.Writer.Dynamic
87+ Effectful.Writer.MVar
8688
8789test-suite test
8890 import: language
src/Effectful/Class/Writer.hs+1−1
@@ -6,7 +6,7 @@ import Control.Monad.Trans.Control
66
77import Effectful.Internal.Effect
88import Effectful.Internal.Monad
9−import qualified Effectful.Writer as W
9+import qualified Effectful.Writer.Dynamic as W
1010
1111-- | Compatiblity layer for a transition period from MTL-style effect handling
1212-- to 'Effectful.Eff'.
src/Effectful/Writer/Dynamic.hsnew file+88
@@ -0,0 +1,88 @@
1+module Effectful.Writer.Dynamic
2+ ( Writer(..)
3+
4+ -- * Pure
5+ , runWriter
6+ , execWriter
7+
8+ -- * MVar
9+ , runWriterMVar
10+ , execWriterMVar
11+
12+ -- * Operations
13+ , writer
14+ , tell
15+ , listen
16+ , listens
17+ ) where
18+
19+import Effectful.Internal.Effect
20+import Effectful.Internal.Monad
21+import Effectful.Interpreter
22+
23+import qualified Effectful.Writer as WP
24+import qualified Effectful.Writer.MVar as WM
25+
26+data Writer w :: Effect where
27+ Writer :: (a, w) -> Writer w m a
28+ Tell :: ~w -> Writer w m ()
29+ Listen :: m a -> Writer w m (a, w)
30+
31+----------------------------------------
32+-- Pure
33+
34+runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
35+runWriter = reinterpretM WP.runWriter writerPure
36+
37+execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
38+execWriter = reinterpretM WP.execWriter writerPure
39+
40+writerPure
41+ :: (Monoid w, WP.Writer w :> localEs)
42+ => RunIn es (Eff localEs)
43+ -> Writer w (Eff es) a
44+ -> Eff localEs a
45+writerPure run = \case
46+ Writer aw -> WP.writer aw
47+ Tell w -> WP.tell w
48+ Listen m -> WP.listen (run m)
49+
50+----------------------------------------
51+-- MVar
52+
53+runWriterMVar :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
54+runWriterMVar = reinterpretM WM.runWriter writerMVar
55+
56+execWriterMVar :: Monoid w => Eff (Writer w : es) a -> Eff es w
57+execWriterMVar = reinterpretM WM.execWriter writerMVar
58+
59+writerMVar
60+ :: (Monoid w, WM.Writer w :> localEs)
61+ => RunIn es (Eff localEs)
62+ -> Writer w (Eff es) a
63+ -> Eff localEs a
64+writerMVar run = \case
65+ Writer aw -> WM.writer aw
66+ Tell w -> WM.tell w
67+ Listen m -> WM.listen (run m)
68+
69+----------------------------------------
70+-- Operations
71+
72+writer :: (Writer w :> es, Monoid w) => (a, w) -> Eff es a
73+writer = send . Writer
74+
75+tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
76+tell = send . Tell
77+
78+listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
79+listen = send . Listen
80+
81+listens
82+ :: (Writer w :> es, Monoid w)
83+ => (w -> b)
84+ -> Eff es a
85+ -> Eff es (a, b)
86+listens f m = do
87+ (a, w) <- listen m
88+ pure (a, f w)
src/Effectful/Writer/MVar.hsnew file+71
@@ -0,0 +1,71 @@
1+module Effectful.Writer.MVar
2+ ( Writer
3+ , runWriter
4+ , execWriter
5+ , writer
6+ , tell
7+ , listen
8+ , listens
9+ ) where
10+
11+import Control.Concurrent.MVar
12+import Control.Monad.Catch
13+
14+import Effectful.Internal.Effect
15+import Effectful.Internal.Env
16+import Effectful.Internal.Monad
17+
18+newtype Writer w :: Effect where
19+ Writer :: MVar w -> Writer w m r
20+
21+runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
22+runWriter m = do
23+ v <- unsafeEff_ $ newMVar mempty
24+ a <- evalEffect (IdE (Writer v)) m
25+ (a, ) <$> unsafeEff_ (readMVar v)
26+
27+execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
28+execWriter m = do
29+ v <- unsafeEff_ $ newMVar mempty
30+ _ <- evalEffect (IdE (Writer v)) m
31+ unsafeEff_ $ readMVar v
32+
33+writer :: (Writer w :> es, Monoid w) => (a, w) -> Eff es a
34+writer (a, w1) = do
35+ IdE (Writer v) <- getEffect
36+ unsafeEff_ . modifyMVar v $ \w0 -> let w = w0 `mappend` w1 in w `seq` pure (w, a)
37+
38+tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
39+tell w1 = do
40+ IdE (Writer v) <- getEffect
41+ unsafeEff_ . modifyMVar_ v $ \w0 -> let w = w0 `mappend` w1 in w `seq` pure w
42+
43+listen
44+ :: forall w es a. (Writer w :> es, Monoid w)
45+ => Eff es a
46+ -> Eff es (a, w)
47+listen (Eff m) = unsafeEff $ \es -> uninterruptibleMask $ \restore -> do
48+ v1 <- newMVar mempty
49+ -- Replace thread local MVar with a fresh one for isolated listening.
50+ v0 <- unsafeStateEnv (\(IdE (Writer v)) -> (v, IdE (Writer v1))) es
51+ a <- restore (m es) `onException` merge es v0 v1
52+ (a, ) <$> merge es v0 v1
53+ where
54+ -- Merge results accumulated in the local MVar with the mainline. If an
55+ -- exception was received while listening, merge results recorded so far.
56+ merge es v0 v1 = do
57+ unsafePutEnv @(Writer w) (IdE (Writer v0)) es
58+ w1 <- readMVar v1
59+ -- The mask is uninterruptible because modifyMVar_ v0 might block and if
60+ -- we get an async exception while waiting, w1 will be lost.
61+ modifyMVar_ v0 $ \w0 -> let w = w0 `mappend` w1 in w `seq` pure w
62+ pure w1
63+
64+listens
65+ :: (Writer w :> es, Monoid w)
66+ => (w -> b)
67+ -> Eff es a
68+ -> Eff es (a, b)
69+listens f m = do
70+ (a, w) <- listen m
71+ pure (a, f w)