git.iko.soy/effectful
on master help sign in
Provide a complete set of (un)lifts for dealing with local operations
91e64bfAndrzej Rybczak
bench/Concurrency.hs+62−28
compare with master
unifiedsplit
@@ -20,57 +20,91 @@ import Utils
20
20
21concurrencyBenchmark :: Benchmark
21concurrencyBenchmark :: Benchmark
22concurrencyBenchmark = bgroup "concurrency"
22concurrencyBenchmark = bgroup "concurrency"
23− [ bench "async (IO)" $ nfAppIO asyncBenchIO (pure 1)
24− , bgroup "shallow"
23+ [ bgroup "shallow" $ map shallowBench [1, 10, 100]
25− [ bench "async (Eff)" $ nfAppIO (runShallow . A.runAsyncE . asyncBench) (pure 1)
26− , bench "Fork (1)" $ nfAppIO (runShallow . runFork1 . forkBench) (pure 1)
27− , bench "Fork (2)" $ nfAppIO (runShallow . runFork2 . forkBench) (pure 1)
28− ]
29− , bgroup "deep"
24+ , bgroup "deep" $ map deepBench [1, 10, 100]
30− [ bench "async (Eff)" $ nfAppIO (runDeep . A.runAsyncE . asyncBench) (pure 1)
31− , bench "Fork (1)" $ nfAppIO (runDeep . runFork1 . forkBench) (pure 1)
32− , bench "Fork (2)" $ nfAppIO (runDeep . runFork2 . forkBench) (pure 1)
33− ]
34 ]
25 ]
35
26
27+shallowBench :: Int -> Benchmark
28+shallowBench n = bgroup ("unmask " ++ show n ++ "x")
29+ [ bench "async (IO)" $ nfAppIO (asyncBenchIO n) op
30+ , bench "async (Eff)" $ nfAppIO (runShallow . A.runAsyncE . asyncBench n) op
31+ , bench "Fork (localUnliftIO/withLiftMapIO)" $
32+ nfAppIO (runShallow . runFork1 . forkBench n) op
33+ , bench "Fork (localUnlift/withLiftMap)" $
34+ nfAppIO (runShallow . runFork2 . forkBench n) op
35+ , bench "Fork (localLiftUnliftIO)" $
36+ nfAppIO (runShallow . runFork3 . forkBench n) op
37+ , bench "Fork (localLiftUnlift)" $
38+ nfAppIO (runShallow . runFork4 . forkBench n) op
39+ ]
40+
41+deepBench :: Int -> Benchmark
42+deepBench n = bgroup ("unmask " ++ show n ++ "x")
43+ [ bench "async (Eff)" $ nfAppIO (runDeep . A.runAsyncE . asyncBench n) op
44+ , bench "Fork (localUnliftIO/withLiftMapIO)" $
45+ nfAppIO (runDeep . runFork1 . forkBench n) op
46+ , bench "Fork (localUnlift/withLiftMap)" $
47+ nfAppIO (runDeep . runFork2 . forkBench n) op
48+ , bench "Fork (localLiftUnliftIO)" $
49+ nfAppIO (runDeep . runFork3 . forkBench n) op
50+ , bench "Fork (localLiftUnlift)" $
51+ nfAppIO (runDeep . runFork4 . forkBench n) op
52+ ]
53+
54+op :: Monad m => m Int
55+op = pure 1
56+
36----------------------------------------
57----------------------------------------
37
58
38data Fork :: Effect where
59data Fork :: Effect where
39 ForkWithUnmask :: ((forall a. m a -> m a) -> m r) -> Fork m (Async r)
60 ForkWithUnmask :: ((forall a. m a -> m a) -> m r) -> Fork m (Async r)
40
61
41−-- | Uses 'localUnliftIO' and 'withLiftSeqOp'.
62+-- | Uses 'localUnliftIO' and 'withLiftMapIO'.
42runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a
63runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a
43−runFork1 = interpretM $ \env (ForkWithUnmask m) -> withLiftSeqOp $ \liftSeqOp -> do
64+runFork1 = interpretM $ \env -> \case
65+ ForkWithUnmask m -> withLiftMapIO $ \liftMap -> do
44− localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do
66+ localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do
45− asyncWithUnmask $ \unmask -> unlift $ m $ liftSeqOp unmask
67+ asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
46
68
47−-- | Uses 'localLiftUnliftIO', slower than (1).
69+-- | Uses 'localUnlift' and 'withLiftMap'.
48runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a
70runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a
71+runFork2 = reinterpretM A.runAsyncE $ \env -> \case
49−runFork2 = interpretM $ \env (ForkWithUnmask m) -> do
72+ ForkWithUnmask m -> withLiftMap $ \liftMap -> do
50− localLiftUnliftIO env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do
73+ localUnlift env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do
51− asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift
74+ A.asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
52
75
53−----------------------------------------
76+-- | Uses 'localLiftUnliftIO'.
77+runFork3 :: IOE :> es => Eff (Fork : es) a -> Eff es a
78+runFork3 = interpretM $ \env -> \case
79+ ForkWithUnmask m -> do
80+ localLiftUnliftIO env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do
81+ asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift
54
82
55−n :: Int
83+-- | Uses 'localLiftUnlift'.
56−n = 100
84+runFork4 :: IOE :> es => Eff (Fork : es) a -> Eff es a
85+runFork4 = reinterpretM A.runAsyncE $ \env -> \case
86+ ForkWithUnmask m -> do
87+ localLiftUnlift env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do
88+ A.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift
89+
90+----------------------------------------
57
91
58−asyncBenchIO :: IO Int -> IO Int
92+asyncBenchIO :: Int -> IO Int -> IO Int
59−asyncBenchIO f = do
93+asyncBenchIO n f = do
60 a <- asyncWithUnmask $ \unmask -> do
94 a <- asyncWithUnmask $ \unmask -> do
61 sum <$> replicateM n (unmask f)
95 sum <$> replicateM n (unmask f)
62 wait a
96 wait a
63{-# NOINLINE asyncBenchIO #-}
97{-# NOINLINE asyncBenchIO #-}
64
98
65−asyncBench :: A.AsyncE :> es => Eff es Int -> Eff es Int
99+asyncBench :: A.AsyncE :> es => Int -> Eff es Int -> Eff es Int
66−asyncBench f = do
100+asyncBench n f = do
67 a <- A.asyncWithUnmask $ \unmask -> do
101 a <- A.asyncWithUnmask $ \unmask -> do
68 sum <$> replicateM n (unmask f)
102 sum <$> replicateM n (unmask f)
69 A.wait a
103 A.wait a
70{-# NOINLINE asyncBench #-}
104{-# NOINLINE asyncBench #-}
71
105
72−forkBench :: (IOE :> es, Fork :> es) => Eff es Int -> Eff es Int
106+forkBench :: (IOE :> es, Fork :> es) => Int -> Eff es Int -> Eff es Int
73−forkBench f = do
107+forkBench n f = do
74 a <- send $ ForkWithUnmask $ \unmask -> do
108 a <- send $ ForkWithUnmask $ \unmask -> do
75 sum <$> replicateM n (unmask f)
109 sum <$> replicateM n (unmask f)
76 liftIO $ wait a
110 liftIO $ wait a
bench/Unlift.hs+1−1
@@ -18,7 +18,7 @@ import Utils
18import qualified Effectful.Async as A
18import qualified Effectful.Async as A
19
19
20unliftBenchmark :: Benchmark
20unliftBenchmark :: Benchmark
21−unliftBenchmark = bgroup "unlift"
21+unliftBenchmark = bgroup "unlifting"
22 [ bgroup "reference"
22 [ bgroup "reference"
23 [ bench "dummy" $ nfIO benchDummy
23 [ bench "dummy" $ nfIO benchDummy
24 , bench "async" $ nfIO benchAsync
24 , bench "async" $ nfIO benchAsync
src/Effectful.hs+14−10
@@ -6,9 +6,6 @@ module Effectful
6 , Effect
6 , Effect
7 , (:>)
7 , (:>)
8
8
9− -- ** Sending effects
10− , send
11−
12 -- * Running the 'Eff' monad
9 -- * Running the 'Eff' monad
13
10
14 -- ** Pure operations
11 -- ** Pure operations
@@ -25,7 +22,10 @@ module Effectful
25 , unliftStrategy
22 , unliftStrategy
26 , withUnliftStrategy
23 , withUnliftStrategy
27
24
28− -- * Building 'Effect' handlers
25+ -- * 'Effect' handlers
26+
27+ -- ** Sending operations to the handler
28+ , send
29
29
30 -- ** Basic handlers
30 -- ** Basic handlers
31 , interpret
31 , interpret
@@ -35,18 +35,22 @@ module Effectful
35 , reinterpret
35 , reinterpret
36 , reinterpretM
36 , reinterpretM
37
37
38− -- ** Local operations
38+ -- ** Handling local 'Eff' operations
39 , LocalEnv
39 , LocalEnv
40
40
41− -- *** 'Eff'
41+ -- *** Unlifts
42 , localSeqUnlift
42 , localSeqUnlift
43− , localUnlift
44−
45− -- *** 'IO'
46 , localSeqUnliftIO
43 , localSeqUnliftIO
44+ , localUnlift
47 , localUnliftIO
45 , localUnliftIO
46+
47+ -- *** Lifts
48+ , withLiftMap
49+ , withLiftMapIO
50+
51+ -- *** Bidirectional lifts
52+ , localLiftUnlift
48 , localLiftUnliftIO
53 , localLiftUnliftIO
49− , withLiftSeqOp
50 ) where
54 ) where
51
55
52import Effectful.Interpreter
56import Effectful.Interpreter
src/Effectful/Async.hs+4−4
@@ -532,9 +532,9 @@ liftAsyncWithUnmask
532 -> ((forall b. Eff es b -> Eff es b) -> Eff es a)
532 -> ((forall b. Eff es b -> Eff es b) -> Eff es a)
533 -> Eff es (Async a)
533 -> Eff es (Async a)
534liftAsyncWithUnmask fork action = do
534liftAsyncWithUnmask fork action = do
535− unsafeWithLiftSeqOp $ \liftSeqOp -> unsafeEff $ \es -> do
535+ unsafeWithLiftMapIO $ \liftMap -> unsafeEff $ \es -> do
536 esA <- cloneEnv es
536 esA <- cloneEnv es
537− fork $ \unmask -> unEff (action $ liftSeqOp unmask) esA
537+ fork $ \unmask -> unEff (action $ liftMap unmask) esA
538
538
539liftWithAsync
539liftWithAsync
540 :: (IO a -> (Async a -> IO b) -> IO b)
540 :: (IO a -> (Async a -> IO b) -> IO b)
@@ -552,7 +552,7 @@ liftWithAsyncWithUnmask
552 -> (Async a -> Eff es b)
552 -> (Async a -> Eff es b)
553 -> Eff es b
553 -> Eff es b
554liftWithAsyncWithUnmask withA action k = do
554liftWithAsyncWithUnmask withA action k = do
555− unsafeWithLiftSeqOp $ \liftSeqOp -> unsafeEff $ \es -> do
555+ unsafeWithLiftMapIO $ \liftMap -> unsafeEff $ \es -> do
556 esA <- cloneEnv es
556 esA <- cloneEnv es
557− withA (\unmask -> unEff (action $ liftSeqOp unmask) esA)
557+ withA (\unmask -> unEff (action $ liftMap unmask) esA)
558 (\a -> unEff (k a) es)
558 (\a -> unEff (k a) es)
src/Effectful/Internal/Monad.hs+6−7
@@ -35,7 +35,7 @@ module Effectful.Internal.Monad
35 , withUnliftStrategy
35 , withUnliftStrategy
36
36
37 --- *** Low-level helpers
37 --- *** Low-level helpers
38− , unsafeWithLiftSeqOp
38+ , unsafeWithLiftMapIO
39 , unsafeSeqUnliftEff
39 , unsafeSeqUnliftEff
40 , unsafeConcUnliftEff
40 , unsafeConcUnliftEff
41
41
@@ -142,10 +142,10 @@ unsafeEff_ m = unsafeEff $ \_ -> m
142--
142--
143-- /Note:/ the 'IO' operation must not run its argument in a separate thread,
143-- /Note:/ the 'IO' operation must not run its argument in a separate thread,
144-- attempting to do so will result in a runtime error.
144-- attempting to do so will result in a runtime error.
145−unsafeWithLiftSeqOp
145+unsafeWithLiftMapIO
146 :: ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
146 :: ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
147 -> Eff es r
147 -> Eff es r
148−unsafeWithLiftSeqOp k = k $ \mapIO m -> unsafeEff $ \es -> do
148+unsafeWithLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do
149 unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
149 unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
150
150
151-- | Lower 'Eff' operations into 'IO' ('SeqUnlift').
151-- | Lower 'Eff' operations into 'IO' ('SeqUnlift').
@@ -272,8 +272,7 @@ tryFailIO tag m =
272----------------------------------------
272----------------------------------------
273-- IO
273-- IO
274
274
275−-- | Run arbitrary 'IO' operations via 'MonadIO', 'MonadUnliftIO' or
275+-- | Run arbitrary 'IO' operations via 'MonadIO' or 'MonadUnliftIO'.
276−-- 'MonadBaseControl' 'IO'.
277newtype IOE :: Effect where
276newtype IOE :: Effect where
278 IOE :: UnliftStrategy -> IOE m r
277 IOE :: UnliftStrategy -> IOE m r
279
278
@@ -319,8 +318,8 @@ instance Prim :> es => PrimMonad (Eff es) where
319----------------------------------------
318----------------------------------------
320-- Unlift strategies
319-- Unlift strategies
321
320
322−-- | The strategy to use when unlifting 'Eff' operations via 'withRunInIO',
321+-- | The strategy to use when unlifting 'Eff' operations via 'withRunInIO' or
323−-- 'liftBaseWith' or the 'Effectful.Interpreter.localUnlift' family.
322+-- the 'Effectful.Interpreter.localUnlift' family.
324data UnliftStrategy
323data UnliftStrategy
325 = SeqUnlift
324 = SeqUnlift
326 -- ^ The fastest strategy and a default setting for 'IOE'. An attempt to call
325 -- ^ The fastest strategy and a default setting for 'IOE'. An attempt to call
src/Effectful/Internal/Unlift.hs+1−1
@@ -1,7 +1,7 @@
1{-# LANGUAGE MagicHash #-}
1{-# LANGUAGE MagicHash #-}
2{-# LANGUAGE UnboxedTuples #-}
2{-# LANGUAGE UnboxedTuples #-}
3{-# OPTIONS_HADDOCK not-home #-}
3{-# OPTIONS_HADDOCK not-home #-}
4−-- | Implementation of the concurrent unlift.
4+-- | Implementation of concurrent unlifts.
5--
5--
6-- This module is intended for internal use only, and may change without warning
6-- This module is intended for internal use only, and may change without warning
7-- in subsequent releases.
7-- in subsequent releases.
src/Effectful/Interpreter.hs+94−41
@@ -1,5 +1,5 @@
1module Effectful.Interpreter
1module Effectful.Interpreter
2− ( -- * Sending commands
2+ ( -- * Sending operations to the handler
3 send
3 send
4
4
5 -- * Handling effects
5 -- * Handling effects
@@ -12,21 +12,26 @@ module Effectful.Interpreter
12 , reinterpret
12 , reinterpret
13 , reinterpretM
13 , reinterpretM
14
14
15− -- ** Local operations
15+ -- ** Handling local 'Eff' operations
16 , LocalEnv
16 , LocalEnv
17
17
18− -- *** 'Eff'
18+ -- *** Unlifts
19 , localSeqUnlift
19 , localSeqUnlift
20− , localUnlift
21−
22− -- *** 'IO'
23 , localSeqUnliftIO
20 , localSeqUnliftIO
21+ , localUnlift
24 , localUnliftIO
22 , localUnliftIO
23+
24+ -- *** Lifts
25+ , withLiftMap
26+ , withLiftMapIO
27+
28+ -- *** Bidirectional lifts
29+ , localLiftUnlift
25 , localLiftUnliftIO
30 , localLiftUnliftIO
26− , withLiftSeqOp
27 ) where
31 ) where
28
32
29import Control.Exception
33import Control.Exception
34+import Control.Monad.IO.Unlift
30import GHC.Stack
35import GHC.Stack
31
36
32import Effectful.Internal.Effect
37import Effectful.Internal.Effect
@@ -64,7 +69,7 @@ runInterpreter es0 e m = do
64----------------------------------------
69----------------------------------------
65-- Sending commands
70-- Sending commands
66
71
67−-- | Send an operation of a given effect to the interpreter.
72+-- | Send an operation of a given effect to the interpreter for execution.
68send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a
73send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a
69send op = unsafeEff $ \es -> do
74send op = unsafeEff $ \es -> do
70 Interpreter{..} <- getEnv es
75 Interpreter{..} <- getEnv es
@@ -129,7 +134,7 @@ reinterpretM runHandlerEs interpreter m = unsafeEff $ \es -> do
129 runInterpreter es (Interpreter les interpreter) m
134 runInterpreter es (Interpreter les interpreter) m
130
135
131----------------------------------------
136----------------------------------------
132−-- Unlifting
137+-- Unlifts
133
138
134-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
139-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
135-- general version see 'localUnlift'.
140-- general version see 'localUnlift'.
@@ -139,8 +144,7 @@ localSeqUnlift
139 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
144 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
140 -- ^ Continuation with the unlifting function in scope.
145 -- ^ Continuation with the unlifting function in scope.
141 -> Eff es a
146 -> Eff es a
142−localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do
147+localSeqUnlift env = localUnlift env SeqUnlift
143− unsafeSeqUnliftEff les $ \unlift -> unEff (k $ unsafeEff_ . unlift) es
144
148
145-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
149-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
146-- general version see 'localUnliftIO'.
150-- general version see 'localUnliftIO'.
@@ -151,7 +155,7 @@ localSeqUnliftIO
151 -> ((forall r. Eff localEs r -> IO r) -> IO a)
155 -> ((forall r. Eff localEs r -> IO r) -> IO a)
152 -- ^ Continuation with the unlifting function in scope.
156 -- ^ Continuation with the unlifting function in scope.
153 -> Eff es a
157 -> Eff es a
154−localSeqUnliftIO (LocalEnv les) k = unsafeEff_ $ unsafeSeqUnliftEff les k
158+localSeqUnliftIO env = localUnliftIO env SeqUnlift
155
159
156-- | Create a local unlifting function with the given strategy.
160-- | Create a local unlifting function with the given strategy.
157localUnlift
161localUnlift
@@ -161,11 +165,13 @@ localUnlift
161 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
165 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
162 -- ^ Continuation with the unlifting function in scope.
166 -- ^ Continuation with the unlifting function in scope.
163 -> Eff es a
167 -> Eff es a
164−localUnlift (LocalEnv les) strategy k = unsafeEff $ \es -> case strategy of
168+localUnlift (LocalEnv les) strategy k = case strategy of
169+ SeqUnlift -> unsafeEff $ \es -> do
165− SeqUnlift -> unsafeSeqUnliftEff les $ \unlift -> do
170+ unsafeSeqUnliftEff les $ \unlift -> do
166− unEff (k $ unsafeEff_ . unlift) es
171+ (`unEff` es) $ k $ unsafeEff_ . unlift
172+ ConcUnlift p l -> unsafeEff $ \es -> do
167− ConcUnlift p l -> unsafeConcUnliftEff les p l $ \unlift -> do
173+ unsafeConcUnliftEff les p l $ \unlift -> do
168− unEff (k $ unsafeEff_ . unlift) es
174+ (`unEff` es) $ k $ unsafeEff_ . unlift
169
175
170-- | Create a local unlifting function with the given strategy.
176-- | Create a local unlifting function with the given strategy.
171localUnliftIO
177localUnliftIO
@@ -176,29 +182,28 @@ localUnliftIO
176 -> ((forall r. Eff localEs r -> IO r) -> IO a)
182 -> ((forall r. Eff localEs r -> IO r) -> IO a)
177 -- ^ Continuation with the unlifting function in scope.
183 -- ^ Continuation with the unlifting function in scope.
178 -> Eff es a
184 -> Eff es a
179−localUnliftIO (LocalEnv les) unlift k = unsafeEff_ $ case unlift of
185+localUnliftIO (LocalEnv les) strategy k = case strategy of
180− SeqUnlift -> unsafeSeqUnliftEff les k
186+ SeqUnlift -> liftIO $ unsafeSeqUnliftEff les k
181− ConcUnlift p l -> unsafeConcUnliftEff les p l k
187+ ConcUnlift p l -> liftIO $ unsafeConcUnliftEff les p l k
182
188
183−-- | Create a local unlifting function with the given strategy along with an
189+-- | Utility for lifting 'Eff' operations of type
184−-- unrestricted lifting function.
185--
190--
186−-- Useful for lifting 'IO' operations where the monadic action shows in both
191+-- @'Eff' es a -> 'Eff' es b@
187−-- positive (as a result) and negative (as an argument) position.
188--
192--
189−-- /Note:/ depending on the operations you're lifting, 'localUnliftIO' along
193+-- to
190−-- with 'withLiftSeqOp' might be enough and is more efficient.
194+--
191−localLiftUnliftIO
195+-- @forall localEs. 'Eff' localEs a -> 'Eff' localEs b@
196+--
197+-- /Note:/ the operation must not run its argument in a separate thread,
198+-- attempting to do so will result in a runtime error.
199+withLiftMap
192 :: IOE :> es
200 :: IOE :> es
193− => LocalEnv localEs
201+ => ((forall a b localEs. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
194− -- ^ Local environment.
195− -> UnliftStrategy
196− -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a)
197− -- ^ Continuation with the lifting and unlifting function in scope.
202+ -- ^ Continuation with the lifting function in scope.
198− -> Eff es a
203+ -> Eff es r
199−localLiftUnliftIO (LocalEnv les) unlift k = unsafeEff_ $ case unlift of
204+withLiftMap k = unsafeWithLiftMapIO $ \liftMap -> do
200− SeqUnlift -> unsafeSeqUnliftEff les $ k unsafeEff_
205+ unsafeEff $ \es -> (`unEff` es) $ k $ \f -> do
201− ConcUnlift p l -> unsafeConcUnliftEff les p l $ k unsafeEff_
206+ liftMap $ (`unEff` es) . f . liftIO
202
207
203-- | Utility for lifting 'IO' operations of type
208-- | Utility for lifting 'IO' operations of type
204--
209--
@@ -208,7 +213,7 @@ localLiftUnliftIO (LocalEnv les) unlift k = unsafeEff_ $ case unlift of
208--
213--
209-- @forall localEs. 'Eff' localEs a -> 'Eff' localEs b@
214-- @forall localEs. 'Eff' localEs a -> 'Eff' localEs b@
210--
215--
211−-- /Note:/ the 'IO' operation must not run its argument in a separate thread,
216+-- /Note:/ the operation must not run its argument in a separate thread,
212-- attempting to do so will result in a runtime error.
217-- attempting to do so will result in a runtime error.
213--
218--
214-- Useful e.g. for lifting the unmasking function in
219-- Useful e.g. for lifting the unmasking function in
@@ -221,16 +226,64 @@ localLiftUnliftIO (LocalEnv les) unlift k = unsafeEff_ $ case unlift of
221--
226--
222-- >>> :{
227-- >>> :{
223-- runFork :: IOE :> es => Eff (Fork : es) a -> Eff es a
228-- runFork :: IOE :> es => Eff (Fork : es) a -> Eff es a
224−-- runFork = interpretM $ \env (ForkWithUnmask m) -> withLiftSeqOp $ \liftSeqOp -> do
229+-- runFork = interpretM $ \env (ForkWithUnmask m) -> withLiftMapIO $ \liftMap -> do
225-- localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do
230-- localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do
226−-- forkIOWithUnmask $ \unmask -> unlift $ m $ liftSeqOp unmask
231+-- forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
227-- :}
232-- :}
228−withLiftSeqOp
233+withLiftMapIO
229 :: IOE :> es
234 :: IOE :> es
230 => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
235 => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
231 -- ^ Continuation with the lifting function in scope.
236 -- ^ Continuation with the lifting function in scope.
232 -> Eff es r
237 -> Eff es r
233−withLiftSeqOp = unsafeWithLiftSeqOp
238+withLiftMapIO = unsafeWithLiftMapIO
239+
240+----------------------------------------
241+-- Bidirectional lifts
242+
243+-- | Create a local lifting and unlifting function with the given strategy.
244+--
245+-- Useful for lifting complicated 'Eff' operations where the monadic action
246+-- shows in both positive (as a result) and negative (as an argument) position.
247+--
248+-- /Note:/ depending on the operation you're lifting 'localUnlift' along with
249+-- 'withLiftMap' might be enough and is more efficient.
250+localLiftUnlift
251+ :: IOE :> es
252+ => LocalEnv localEs
253+ -- ^ Local environment.
254+ -> UnliftStrategy
255+ -> ((forall r. Eff es r -> Eff localEs r) -> (forall r. Eff localEs r -> Eff es r) -> Eff es a)
256+ -- ^ Continuation with the lifting and unlifting function in scope.
257+ -> Eff es a
258+localLiftUnlift (LocalEnv les) strategy k = case strategy of
259+ SeqUnlift -> unsafeEff $ \es -> do
260+ unsafeSeqUnliftEff es $ \unliftEs -> do
261+ unsafeSeqUnliftEff les $ \unliftLocalEs -> do
262+ (`unEff` es) $ k (unsafeEff_ . unliftEs) (liftIO . unliftLocalEs)
263+ ConcUnlift p l -> unsafeEff $ \es -> do
264+ unsafeConcUnliftEff es p l $ \unliftEs -> do
265+ unsafeConcUnliftEff les p l $ \unliftLocalEs -> do
266+ (`unEff` es) $ k (unsafeEff_ . unliftEs) (liftIO . unliftLocalEs)
267+
268+-- | Create a local unlifting function with the given strategy along with an
269+-- unrestricted lifting function.
270+--
271+-- Useful for lifting complicated 'IO' operations where the monadic action shows
272+-- in both positive (as a result) and negative (as an argument) position.
273+--
274+-- /Note:/ depending on the operation you're lifting 'localUnliftIO' along with
275+-- 'withLiftMapIO' might be enough and is more efficient.
276+localLiftUnliftIO
277+ :: IOE :> es
278+ => LocalEnv localEs
279+ -- ^ Local environment.
280+ -> UnliftStrategy
281+ -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a)
282+ -- ^ Continuation with the lifting and unlifting function in scope.
283+ -> Eff es a
284+localLiftUnliftIO (LocalEnv les) strategy k = case strategy of
285+ SeqUnlift -> liftIO $ unsafeSeqUnliftEff les $ k unsafeEff_
286+ ConcUnlift p l -> liftIO $ unsafeConcUnliftEff les p l $ k unsafeEff_
234
287
235-- $setup
288-- $setup
236-- >>> import Control.Concurrent
289-- >>> import Control.Concurrent