mirror of
https://github.com/haskell-effectful/effectful.git
synced 2024-11-30 13:23:07 +03:00
Slightly smaller stateStaticRepM
This commit is contained in:
parent
870660445d
commit
34a3e57420
@ -292,11 +292,11 @@ putEnv env e = do
|
|||||||
stateEnv
|
stateEnv
|
||||||
:: forall e es a. e :> es
|
:: forall e es a. e :> es
|
||||||
=> Env es -- ^ The environment.
|
=> Env es -- ^ The environment.
|
||||||
-> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e))
|
-> (EffectRep (DispatchOf e) e -> IO (a, EffectRep (DispatchOf e) e))
|
||||||
-> IO a
|
-> IO a
|
||||||
stateEnv env f = do
|
stateEnv env f = do
|
||||||
(i, es) <- getLocation @e env
|
(i, es) <- getLocation @e env
|
||||||
(a, e) <- f . fromAny <$> readSmallArray es i
|
(a, e) <- f . fromAny =<< readSmallArray es i
|
||||||
e `seq` writeSmallArray es i (toAny e)
|
e `seq` writeSmallArray es i (toAny e)
|
||||||
pure a
|
pure a
|
||||||
|
|
||||||
@ -304,11 +304,11 @@ stateEnv env f = do
|
|||||||
modifyEnv
|
modifyEnv
|
||||||
:: forall e es. e :> es
|
:: forall e es. e :> es
|
||||||
=> Env es -- ^ The environment.
|
=> Env es -- ^ The environment.
|
||||||
-> (EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e)
|
-> (EffectRep (DispatchOf e) e -> IO (EffectRep (DispatchOf e) e))
|
||||||
-> IO ()
|
-> IO ()
|
||||||
modifyEnv env f = do
|
modifyEnv env f = do
|
||||||
(i, es) <- getLocation @e env
|
(i, es) <- getLocation @e env
|
||||||
e <- f . fromAny <$> readSmallArray es i
|
e <- f . fromAny =<< readSmallArray es i
|
||||||
e `seq` writeSmallArray es i (toAny e)
|
e `seq` writeSmallArray es i (toAny e)
|
||||||
|
|
||||||
-- | Determine location of the effect in the environment.
|
-- | Determine location of the effect in the environment.
|
||||||
|
@ -474,7 +474,7 @@ stateStaticRep
|
|||||||
=> (StaticRep e -> (a, StaticRep e))
|
=> (StaticRep e -> (a, StaticRep e))
|
||||||
-- ^ The function to modify the representation.
|
-- ^ The function to modify the representation.
|
||||||
-> Eff es a
|
-> Eff es a
|
||||||
stateStaticRep f = unsafeEff $ \es -> stateEnv es f
|
stateStaticRep f = unsafeEff $ \es -> stateEnv es (pure . f)
|
||||||
|
|
||||||
-- | Apply the monadic function to the current representation of the effect and
|
-- | Apply the monadic function to the current representation of the effect and
|
||||||
-- return a value.
|
-- return a value.
|
||||||
@ -484,9 +484,7 @@ stateStaticRepM
|
|||||||
-- ^ The function to modify the representation.
|
-- ^ The function to modify the representation.
|
||||||
-> Eff es a
|
-> Eff es a
|
||||||
stateStaticRepM f = unsafeEff $ \es -> E.mask $ \unmask -> do
|
stateStaticRepM f = unsafeEff $ \es -> E.mask $ \unmask -> do
|
||||||
(a, s) <- (\s0 -> unmask $ unEff (f s0) es) =<< getEnv es
|
stateEnv es $ unmask . (`unEff` es) . f
|
||||||
putEnv es s
|
|
||||||
pure a
|
|
||||||
|
|
||||||
-- | Execute a computation with a temporarily modified representation of the
|
-- | Execute a computation with a temporarily modified representation of the
|
||||||
-- effect.
|
-- effect.
|
||||||
@ -497,6 +495,6 @@ localStaticRep
|
|||||||
-> Eff es a
|
-> Eff es a
|
||||||
-> Eff es a
|
-> Eff es a
|
||||||
localStaticRep f m = unsafeEff $ \es -> do
|
localStaticRep f m = unsafeEff $ \es -> do
|
||||||
E.bracket (stateEnv es $ \s -> (s, f s))
|
E.bracket (stateEnv es $ \s -> pure (s, f s))
|
||||||
(\s -> putEnv es s)
|
(\s -> putEnv es s)
|
||||||
(\_ -> unEff m es)
|
(\_ -> unEff m es)
|
||||||
|
@ -77,13 +77,13 @@ tell w = stateStaticRep $ \(Writer w0) -> ((), Writer (w0 <> w))
|
|||||||
-- "Hi there!"
|
-- "Hi there!"
|
||||||
listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
|
listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
|
||||||
listen m = unsafeEff $ \es -> mask $ \unmask -> do
|
listen m = unsafeEff $ \es -> mask $ \unmask -> do
|
||||||
w0 <- stateEnv es $ \(Writer w) -> (w, Writer mempty)
|
w0 <- stateEnv es $ \(Writer w) -> pure (w, Writer mempty)
|
||||||
a <- unmask (unEff m es) `onException` merge es w0
|
a <- unmask (unEff m es) `onException` merge es w0
|
||||||
(a, ) <$> merge es w0
|
(a, ) <$> merge es w0
|
||||||
where
|
where
|
||||||
merge es w0 =
|
merge es w0 =
|
||||||
-- If an exception is thrown, restore w0 and keep parts of w1.
|
-- If an exception is thrown, restore w0 and keep parts of w1.
|
||||||
stateEnv es $ \(Writer w1) -> (w1, Writer (w0 <> w1))
|
stateEnv es $ \(Writer w1) -> pure (w1, Writer (w0 <> w1))
|
||||||
|
|
||||||
-- | Execute an action and append its output to the overall output of the
|
-- | Execute an action and append its output to the overall output of the
|
||||||
-- 'Writer', then return the final value along with a function of the recorded
|
-- 'Writer', then return the final value along with a function of the recorded
|
||||||
|
@ -87,7 +87,7 @@ listen m = unsafeEff $ \es -> do
|
|||||||
uninterruptibleMask $ \unmask -> do
|
uninterruptibleMask $ \unmask -> do
|
||||||
v1 <- newMVar mempty
|
v1 <- newMVar mempty
|
||||||
-- Replace thread local MVar with a fresh one for isolated listening.
|
-- Replace thread local MVar with a fresh one for isolated listening.
|
||||||
v0 <- stateEnv es $ \(Writer v) -> (v, Writer v1)
|
v0 <- stateEnv es $ \(Writer v) -> pure (v, Writer v1)
|
||||||
a <- unmask (unEff m es) `onException` merge es v0 v1
|
a <- unmask (unEff m es) `onException` merge es v0 v1
|
||||||
(a, ) <$> merge es v0 v1
|
(a, ) <$> merge es v0 v1
|
||||||
where
|
where
|
||||||
|
Loading…
Reference in New Issue
Block a user