polysemy 1.1.0.0 → 1.2.0.0

raw patch · 26 files changed

+1378/−158 lines, 26 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +38/−1
• README.md +10/−1
• polysemy.cabal +6/−2
• src/Polysemy.hs +17/−2
• src/Polysemy/Async.hs +44/−4
• src/Polysemy/AtomicState.hs +40/−4
• src/Polysemy/Error.hs +45/−1
• src/Polysemy/Fail.hs +1/−1
• src/Polysemy/Final.hs +260/−0
• src/Polysemy/Fixpoint.hs +45/−11
• src/Polysemy/Internal.hs +60/−6
• src/Polysemy/Internal/Fixpoint.hs +4/−3
• src/Polysemy/Internal/Forklift.hs +2/−1
• src/Polysemy/Internal/Strategy.hs +131/−0
• src/Polysemy/Internal/Union.hs +9/−3
• src/Polysemy/Internal/Writer.hs +158/−0
• src/Polysemy/NonDet.hs +86/−51
• src/Polysemy/Output.hs +69/−3
• src/Polysemy/Resource.hs +42/−4
• src/Polysemy/State.hs +34/−0
• src/Polysemy/Writer.hs +77/−36
• test/AsyncSpec.hs +0/−1
• test/FinalSpec.hs +96/−0
• test/FixpointSpec.hs +22/−17
• test/OutputSpec.hs +11/−4
• test/WriterSpec.hs +71/−2

@@ -1,10 +1,45 @@ # Changelog for polysemy ++## 1.2.0.0 (2019-09-04)++### Breaking Changes++- All `lower-` interpreters have been deprecated, in favor of corresponding+    `-Final` interpreters.+- `runFixpoint` and `runFixpointM` have been deprecated in favor of+    `fixpointToFinal`.+- The semantics for `runNonDet` when `<|>` is used inside a higher-order action+    of another effect has been changed.+- Type variables for certain internal functions, `failToEmbed`, and+    `atomicState'` have been rearranged.++## Other changes++- Added `Final` effect, an effect for embedding higher-order actions in the+    final monad of the effect stack. Any interpreter should use this instead of+    requiring to be provided an explicit lowering function to the final monad.+- Added `Strategy` environment for use together with `Final`+- Added `asyncToIOFinal`, a better alternative of `lowerAsync`+- Added `errorToIOFinal`, a better alternative of `lowerError`+- Added `fixpointToFinal`, a better alternative of `runFixpoint` and `runFixpointM`+- Added `resourceToIOFinal`, a better alternative of `lowerResource`+- Added `outputToIOMonoid` and `outputToIOMonoidAssocR`+- Added `stateToIO`+- Added `atomicStateToIO`+- Added `runWriterTVar`, `writerToIOFinal`, and `writerToIOAssocRFinal`+- Added `writerToEndoWriter`+- Added `subsume` operation+- Exposed `raiseUnder`/`2`/`3` in `Polysemy`++ ## 1.1.0.0 (2019-08-15)  ### Breaking Changes -- `MonadFail` is now implemented in terms of `Fail`, instead of `NonDet`(thanks to @KingoftheHomeless)+- `MonadFail` is now implemented in terms of `Fail`, instead of `NonDet` (thanks to @KingoftheHomeless)+- `LastMember` has been removed. `withLowerToIO` and all interpreters that make use of it+    now only requires `Member (Embed IO) r` (thanks to @KingoftheHomeless) - `State` and `Writer` now have better strictness semantics  ### Other Changes@@ -12,7 +47,9 @@ - Added `AtomicState` effect (thanks to @KingoftheHomeless) - Added `Fail` effect (thanks to @KingoftheHomeless) - Added `runOutputSem` (thanks to @cnr)+- Added `modify'`, a strict variant of `modify` (thanks to @KingoftheHomeless) - Added right-associative variants of `runOutputMonoid` and `runWriter` (thanks to @KingoftheHomeless)+- Added `runOutputMonoidIORef` and `runOutputMonoidTVar` (thanks to @KingoftheHomeless) - Improved `Fixpoint` so it won't always diverge (thanks to @KingoftheHomeless) - `makeSem` will now complain if `DataKinds` isn't enabled (thanks to @pepegar) 

@@ -67,7 +67,10 @@ <sup><a name="fn1">1</a></sup>: Unfortunately this is not true in GHC 8.6.3, but will be true in GHC 8.10.1. +## Tutorial +Raghu Kaippully wrote a beginner friendly [tutorial](https://haskell-explained.gitlab.io/blog/posts/2019/07/28/polysemy-is-cool-part-1/index.html).+ ## Examples  Make sure you read the [Necessary Language@@ -153,7 +156,13 @@             _             -> writeTTY input >> writeTTY "no exceptions"  main :: IO (Either CustomException ())-main = (runM .@ lowerResource .@@ lowerError @CustomException) . teletypeToIO $ program+main =+    runFinal+  . embedToFinal @IO+  . resourceToIOFinal+  . errorToIOFinal @CustomException+  . teletypeToIO+  $ program ```  Easy.

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: ed739126c69520676b38ca047f46cbddc31813120ceb38b36fe7ac3c0012a606+-- hash: a8b3a81d8983405247d7e8cb0010669caf9e8f62f85762990fadbeccdafc6094  name:           polysemy-version:        1.1.0.0+version:        1.2.0.0 synopsis:       Higher-order, low-boilerplate, zero-cost free monads. description:    Please see the README on GitHub at <https://github.com/isovector/polysemy#readme> category:       Language@@ -47,6 +47,7 @@       Polysemy.Error       Polysemy.Fail       Polysemy.Fail.Type+      Polysemy.Final       Polysemy.Fixpoint       Polysemy.Input       Polysemy.Internal@@ -57,10 +58,12 @@       Polysemy.Internal.Forklift       Polysemy.Internal.Kind       Polysemy.Internal.NonDet+      Polysemy.Internal.Strategy       Polysemy.Internal.Tactics       Polysemy.Internal.TH.Common       Polysemy.Internal.TH.Effect       Polysemy.Internal.Union+      Polysemy.Internal.Writer       Polysemy.IO       Polysemy.NonDet       Polysemy.Output@@ -118,6 +121,7 @@       BracketSpec       DoctestSpec       FailSpec+      FinalSpec       FixpointSpec       FusionSpec       HigherOrderSpec

@@ -7,14 +7,28 @@   -- * Running Sem   , run   , runM+  , runFinal    -- * Interoperating With Other Monads+  -- ** Embed   , Embed (..)   , embed+  , embedToFinal+  -- ** Final+  -- | For advanced uses of 'Final', including creating your own interpreters+  -- that make use of it, see "Polysemy.Final"+  , Final+  , embedFinal      -- * Lifting   , raise+  , raiseUnder+  , raiseUnder2+  , raiseUnder3 +    -- * Trivial Interpretation+  , subsume+     -- * Creating New Effects     -- | Effects should be defined as a GADT (enable @-XGADTs@), with kind @(*     -- -> *) -> * -> *@. Every primitive action in the effect should be its@@ -27,8 +41,8 @@     --   ReadLine  :: Console m String     -- @     ---    -- Notice that the @a@ parameter gets instataniated at the /desired return-    -- type/ of the actions. Writing a line returns a '()', but reading one+    -- Notice that the @a@ parameter gets instantiated at the /desired return/+    -- /type/ of the actions. Writing a line returns a @()@, but reading one     -- returns 'String'.     --     -- By enabling @-XTemplateHaskell@, we can use the 'makeSem' function@@ -124,4 +138,5 @@ import Polysemy.Internal.Kind import Polysemy.Internal.TH.Effect import Polysemy.Internal.Tactics+import Polysemy.Final 

@@ -10,11 +10,13 @@      -- * Interpretations   , asyncToIO+  , asyncToIOFinal   , lowerAsync   ) where  import qualified Control.Concurrent.Async as A import           Polysemy+import           Polysemy.Final   @@ -32,13 +34,23 @@ makeSem ''Async  --------------------------------------------------------------------------------- | A more flexible --- though less performant ---  version of 'lowerAsync'.+-- | A more flexible --- though less performant ---+-- version of 'asyncToIOFinal'. -- -- This function is capable of running 'Async' effects anywhere within an--- effect stack, without relying on an explicit function to lower it into 'IO'.+-- effect stack, without relying on 'Final' to lower it into 'IO'. -- Notably, this means that 'Polysemy.State.State' effects will be consistent -- in the presence of 'Async'. --+-- 'asyncToIO' is __unsafe__ if you're using 'await' inside higher-order actions+-- of other effects interpreted after 'Async'.+-- See <https://github.com/polysemy-research/polysemy/issues/205 Issue #205>.+--+-- Prefer 'asyncToIOFinal' unless you need to run pure, stateful interpreters+-- after the interpreter for 'Async'.+-- (Pure interpreters are interpreters that aren't expressed in terms of+-- another effect or monad; for example, 'Polysemy.State.runState'.)+-- -- @since 1.0.0.0 asyncToIO     :: Member (Embed IO) r@@ -57,9 +69,37 @@     )  m {-# INLINE asyncToIO #-} +------------------------------------------------------------------------------+-- | Run an 'Async' effect in terms of 'A.async' through final 'IO'.+--+-- /Beware/: Effects that aren't interpreted in terms of 'IO'+-- will have local state semantics in regards to 'Async' effects+-- interpreted this way. See 'Final'.+--+-- Notably, unlike 'asyncToIO', this is not consistent with+-- 'Polysemy.State.State' unless 'Polysemy.State.runStateIORef' is used.+-- State that seems like it should be threaded globally throughout 'Async'+-- /will not be./+--+-- Use 'asyncToIO' instead if you need to run+-- pure, stateful interpreters after the interpreter for 'Async'.+-- (Pure interpreters are interpreters that aren't expressed in terms of+-- another effect or monad; for example, 'Polysemy.State.runState'.)+--+-- @since 1.2.0.0+asyncToIOFinal :: Member (Final IO) r+               => Sem (Async ': r) a+               -> Sem r a+asyncToIOFinal = interpretFinal $ \case+  Async m -> do+    ins <- getInspectorS+    m'  <- runS m+    liftS $ A.async (inspect ins <$> m')+  Await a -> liftS (A.wait a)+{-# INLINE asyncToIOFinal #-}  --------------------------------------------------------------------------------- | Run an 'Async' effect via in terms of 'A.async'.+-- | Run an 'Async' effect in terms of 'A.async'. -- -- @since 1.0.0.0 lowerAsync@@ -80,4 +120,4 @@         Await a -> pureT =<< embed (A.wait a)     )  m {-# INLINE lowerAsync #-}-+{-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}

@@ -15,6 +15,7 @@     -- * Interpretations   , runAtomicStateIORef   , runAtomicStateTVar+  , atomicStateToIO   , atomicStateToState   ) where @@ -26,6 +27,10 @@  import Data.IORef +------------------------------------------------------------------------------+-- | A variant of 'State' that supports atomic operations.+--+-- @since 1.1.0.0 data AtomicState s m a where   AtomicState :: (s -> (s, a)) -> AtomicState s m a   AtomicGet   :: AtomicState s m s@@ -46,9 +51,10 @@ ----------------------------------------------------------------------------- -- | A variant of 'atomicState' in which the computation is strict in the new -- state and return value.-atomicState' :: Member (AtomicState s) r-              => (s -> (s, a))-              -> Sem r a+atomicState' :: forall s a r+              . Member (AtomicState s) r+             => (s -> (s, a))+             -> Sem r a atomicState' f = do   -- KingoftheHomeless: return value needs to be forced due to how   -- 'atomicModifyIORef' is implemented: the computation@@ -87,7 +93,8 @@ ------------------------------------------------------------------------------ -- | Run an 'AtomicState' effect by transforming it into atomic operations -- over an 'IORef'.-runAtomicStateIORef :: Member (Embed IO) r+runAtomicStateIORef :: forall s r a+                     . Member (Embed IO) r                     => IORef s                     -> Sem (AtomicState s ': r) a                     -> Sem r a@@ -110,6 +117,35 @@     return a   AtomicGet -> embed $ readTVarIO tvar {-# INLINE runAtomicStateTVar #-}++--------------------------------------------------------------------+-- | Run an 'AtomicState' effect in terms of atomic operations+-- in 'IO'.+--+-- Internally, this simply creates a new 'IORef', passes it to+-- 'runAtomicStateIORef', and then returns the result and the final value+-- of the 'IORef'.+--+-- /Beware/: As this uses an 'IORef' internally,+-- all other effects will have local+-- state semantics in regards to 'AtomicState' effects+-- interpreted this way.+-- For example, 'Polysemy.Error.throw' and 'Polysemy.Error.catch' will+-- never revert 'atomicModify's, even if 'Polysemy.Error.runError' is used+-- after 'atomicStateToIO'.+--+-- @since 1.2.0.0+atomicStateToIO :: forall s r a+                 . Member (Embed IO) r+                => s+                -> Sem (AtomicState s ': r) a+                -> Sem r (s, a)+atomicStateToIO s sem = do+  ref <- embed $ newIORef s+  res <- runAtomicStateIORef ref sem+  end <- embed $ readIORef ref+  return (end, res)+{-# INLINE atomicStateToIO #-}  ------------------------------------------------------------------------------ -- | Transform an 'AtomicState' effect to a 'State' effect, discarding

@@ -13,6 +13,7 @@     -- * Interpretations   , runError   , mapError+  , errorToIOFinal   , lowerError   ) where @@ -22,6 +23,7 @@ import           Data.Bifunctor (first) import           Data.Typeable import           Polysemy+import           Polysemy.Final import           Polysemy.Internal import           Polysemy.Internal.Union @@ -131,6 +133,48 @@   ------------------------------------------------------------------------------+-- | Run an 'Error' effect as an 'IO' 'X.Exception' through final 'IO'. This+-- interpretation is significantly faster than 'runError'.+--+-- /Beware/: Effects that aren't interpreted in terms of 'IO'+-- will have local state semantics in regards to 'Error' effects+-- interpreted this way. See 'Final'.+--+-- @since 1.2.0.0+errorToIOFinal+    :: ( Typeable e+       , Member (Final IO) r+       )+    => Sem (Error e ': r) a+    -> Sem r (Either e a)+errorToIOFinal sem = withStrategicToFinal @IO $ do+  m' <- runS (runErrorAsExcFinal sem)+  s  <- getInitialStateS+  pure $+    either+      ((<$ s) . Left . unwrapExc)+      (fmap Right)+    <$> X.try m'+{-# INLINE errorToIOFinal #-}++runErrorAsExcFinal+    :: forall e r a+    .  ( Typeable e+       , Member (Final IO) r+       )+    => Sem (Error e ': r) a+    -> Sem r a+runErrorAsExcFinal = interpretFinal $ \case+  Throw e   -> pure $ X.throwIO $ WrappedExc e+  Catch m h -> do+    m' <- runS m+    h' <- bindS h+    s  <- getInitialStateS+    pure $ X.catch m' $ \(se :: WrappedExc e) ->+      h' (unwrapExc se <$ s)+{-# INLINE runErrorAsExcFinal #-}++------------------------------------------------------------------------------ -- | Run an 'Error' effect as an 'IO' 'X.Exception'. This interpretation is -- significantly faster than 'runError', at the cost of being less flexible. --@@ -151,6 +195,7 @@     . X.try     . (lower .@ runErrorAsExc) {-# INLINE lowerError #-}+{-# DEPRECATED lowerError "Use 'errorToIOFinal' instead" #-}   -- TODO(sandy): Can we use the new withLowerToIO machinery for this?@@ -171,4 +216,3 @@     embed $ X.catch (runIt t) $ \(se :: WrappedExc e) ->       runIt $ h $ unwrapExc se <$ is {-# INLINE runErrorAsExc #-}-

@@ -47,7 +47,7 @@  ------------------------------------------------------------------------------ -- | Run a 'Fail' effect in terms of an underlying 'MonadFail' instance.-failToEmbed :: forall m a r+failToEmbed :: forall m r a              . (Member (Embed m) r, MonadFail m)             => Sem (Fail ': r) a             -> Sem r a

@@ -0,0 +1,260 @@+{-# LANGUAGE TemplateHaskell #-}+module Polysemy.Final+  (+    -- * Effect+    Final(..)+  , ThroughWeavingToFinal++    -- * Actions+  , withWeavingToFinal+  , withStrategicToFinal+  , embedFinal++    -- * Combinators for Interpreting to the Final Monad+  , interpretFinal++    -- * Strategy+    -- | Strategy is a domain-specific language very similar to @Tactics@+    -- (see 'Polysemy.Tactical'), and is used to describe how higher-order+    -- effects are threaded down to the final monad.+    --+    -- Much like @Tactics@, computations can be run and threaded+    -- through the use of 'runS' and 'bindS', and first-order constructors+    -- may use 'pureS'. In addition, 'liftS' may be used to+    -- lift actions of the final monad.+    --+    -- Unlike @Tactics@, the final return value within a 'Strategic'+    -- must be a monadic value of the target monad+    -- with the functorial state wrapped inside of it.+  , Strategic+  , WithStrategy+  , pureS+  , liftS+  , runS+  , bindS+  , getInspectorS+  , getInitialStateS++    -- * Interpretations+  , runFinal+  , finalToFinal++  -- * Interpretations for Other Effects+  , embedToFinal+  ) where++import Polysemy.Internal+import Polysemy.Internal.Combinators+import Polysemy.Internal.Union+import Polysemy.Internal.Strategy+import Polysemy.Internal.TH.Effect++-----------------------------------------------------------------------------+-- | This represents a function which produces+-- an action of the final monad @m@ given:+--+--   * The initial effectful state at the moment the action+--     is to be executed.+--+--   * A way to convert @z@ (which is typically @'Sem' r@) to @m@ by+--     threading the effectful state through.+--+--   * An inspector that is able to view some value within the+--     effectful state if the effectful state contains any values.+--+-- A @'Polysemy.Internal.Union.Weaving'@ provides these components,+-- hence the name 'ThroughWeavingToFinal'.+--+-- @since 1.2.0.0+type ThroughWeavingToFinal m z a =+     forall f+   . Functor f+  => f ()+  -> (forall x. f (z x) -> m (f x))+  -> (forall x. f x -> Maybe x)+  -> m (f a)++-----------------------------------------------------------------------------+-- | An effect for embedding higher-order actions in the final target monad+-- of the effect stack.+--+-- This is very useful for writing interpreters that interpret higher-order+-- effects in terms of the final monad.+--+-- 'Final' is more powerful than 'Embed', but is also less flexible+-- to interpret (compare 'Polysemy.Embed.runEmbedded' with 'finalToFinal').+-- If you only need the power of 'embed', then you should use 'Embed' instead.+--+-- /Beware/: 'Final' actions are interpreted as actions of the final monad,+-- and the effectful state visible to+-- 'withWeavingToFinal' \/ 'withStrategicToFinal'+-- \/ 'interpretFinal'+-- is that of /all interpreters run in order to produce the final monad/.+--+-- This means that any interpreter built using 'Final' will /not/+-- respect local/global state semantics based on the order of+-- interpreters run. You should signal interpreters that make use of+-- 'Final' by adding a @-'Final'@ suffix to the names of these.+--+-- State semantics of effects that are /not/+-- interpreted in terms of the final monad will always+-- appear local to effects that are interpreted in terms of the final monad.+--+-- State semantics between effects that are interpreted in terms of the final monad+-- depend on the final monad. For example, if the final monad is a monad transformer+-- stack, then state semantics will depend on the order monad transformers are stacked.+--+-- @since 1.2.0.0+newtype Final m z a where+  WithWeavingToFinal+    :: ThroughWeavingToFinal m z a+    -> Final m z a++makeSem_ ''Final++-----------------------------------------------------------------------------+-- | Allows for embedding higher-order actions of the final monad+-- by providing the means of explicitly threading effects through @'Sem' r@+-- to the final monad.+--+-- Consider using 'withStrategicToFinal' instead,+-- which provides a more user-friendly interface, but is also slightly weaker.+--+-- You are discouraged from using 'withWeavingToFinal' directly+-- in application code, as it ties your application code directly to+-- the final monad.+--+-- @since 1.2.0.0+withWeavingToFinal+  :: forall m r a+   . Member (Final m) r+  => ThroughWeavingToFinal m (Sem r) a+  -> Sem r a+++-----------------------------------------------------------------------------+-- | 'withWeavingToFinal' admits an implementation of 'embed'.+--+-- Just like 'embed', you are discouraged from using this in application code.+--+-- @since 1.2.0.0+embedFinal :: (Member (Final m) r, Functor m) => m a -> Sem r a+embedFinal m = withWeavingToFinal $ \s _ _ -> (<$ s) <$> m+{-# INLINE embedFinal #-}++-----------------------------------------------------------------------------+-- | Allows for embedding higher-order actions of the final monad+-- by providing the means of explicitly threading effects through @'Sem' r@+-- to the final monad. This is done through the use of the 'Strategic'+-- environment, which provides 'runS' and 'bindS'.+--+-- You are discouraged from using 'withStrategicToFinal' in application code,+-- as it ties your application code directly to the final monad.+--+-- @since 1.2.0.0+withStrategicToFinal :: Member (Final m) r+                     => Strategic m (Sem r) a+                     -> Sem r a+withStrategicToFinal strat = withWeavingToFinal (runStrategy strat)+{-# INLINE withStrategicToFinal #-}++------------------------------------------------------------------------------+-- | Like 'interpretH', but may be used to+-- interpret higher-order effects in terms of the final monad.+--+-- 'interpretFinal' requires less boilerplate than using 'interpretH'+-- together with 'withStrategicToFinal' \/ 'withWeavingToFinal',+-- but is also less powerful.+-- 'interpretFinal' does not provide any means of executing actions+-- of @'Sem' r@ as you interpret each action, and the provided interpreter+-- is automatically recursively used to process higher-order occurences of+-- @'Sem' (e ': r)@ to @'Sem' r@.+--+-- If you need greater control of how the effect is interpreted,+-- use 'interpretH' together with 'withStrategicToFinal' \/+-- 'withWeavingToFinal' instead.+--+-- /Beware/: Effects that aren't interpreted in terms of the final+-- monad will have local state semantics in regards to effects+-- interpreted using 'interpretFinal'. See 'Final'.+--+-- @since 1.2.0.0+interpretFinal+    :: forall m e r a+     . Member (Final m) r+    => (forall x n. e n x -> Strategic m n x)+       -- ^ A natural transformation from the handled effect to the final monad.+    -> Sem (e ': r) a+    -> Sem r a+interpretFinal n =+  let+    go :: Sem (e ': r) x -> Sem r x+    go = hoistSem $ \u -> case decomp u of+      Right (Weaving e s wv ex ins) ->+        injWeaving $+          Weaving+            (WithWeavingToFinal (runStrategy (n e)))+            s+            (go . wv)+            ex+            ins+      Left g -> hoist go g+    {-# INLINE go #-}+  in+    go+{-# INLINE interpretFinal #-}++------------------------------------------------------------------------------+-- | Lower a 'Sem' containing only a single lifted, final 'Monad' into that+-- monad.+--+-- If you also need to process an @'Embed' m@ effect, use this together with+-- 'embedToFinal'.+--+-- @since 1.2.0.0+runFinal :: Monad m => Sem '[Final m] a -> m a+runFinal = usingSem $ \u -> case extract u of+  Weaving (WithWeavingToFinal wav) s wv ex ins ->+    ex <$> wav s (runFinal . wv) ins+{-# INLINE runFinal #-}++------------------------------------------------------------------------------+-- | Given natural transformations between @m1@ and @m2@, run a @'Final' m1@+-- effect by transforming it into a @'Final' m2@ effect.+--+-- @since 1.2.0.0+finalToFinal :: forall m1 m2 r a+              . Member (Final m2) r+             => (forall x. m1 x -> m2 x)+             -> (forall x. m2 x -> m1 x)+             -> Sem (Final m1 ': r) a+             -> Sem r a+finalToFinal to from =+  let+    go :: Sem (Final m1 ': r) x -> Sem r x+    go = hoistSem $ \u -> case decomp u of+      Right (Weaving (WithWeavingToFinal wav) s wv ex ins) ->+        injWeaving $+          Weaving+            (WithWeavingToFinal $ \s' wv' ins' ->+              to $ wav s' (from . wv') ins'+            )+            s+            (go . wv)+            ex+            ins+      Left g -> hoist go g+    {-# INLINE go #-}+  in+    go+{-# INLINE finalToFinal #-}++------------------------------------------------------------------------------+-- | Transform an @'Embed' m@ effect into a @'Final' m@ effect+--+-- @since 1.2.0.0+embedToFinal :: (Member (Final m) r, Functor m)+             => Sem (Embed m ': r) a+             -> Sem r a+embedToFinal = interpret $ \(Embed m) -> embedFinal m+{-# INLINE embedToFinal #-}

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-}  module Polysemy.Fixpoint   ( -- * Effect@@ -12,11 +12,15 @@ import Data.Maybe  import Polysemy+import Polysemy.Final import Polysemy.Internal.Fixpoint ---------------------------------------------------------------------------------- | Run a 'Fixpoint' effect purely.+-----------------------------------------------------------------------------+-- | Run a 'Fixpoint' effect in terms of a final 'MonadFix' instance. --+-- If you need to run a 'Fixpoint' effect purely, use this together with+-- @'Final' 'Data.Functor.Identity.Identity'@.+-- -- __Note__: This is subject to the same traps as 'MonadFix' instances for -- monads with failure: this will throw an exception if you try to recursively use -- the result of a failed computation in an action whose effect may be observed@@ -24,12 +28,14 @@ -- -- For example, the following program will throw an exception upon evaluating the -- final state:+-- -- @ -- bad :: (Int, Either () Int) -- bad =---    'run'---  . 'runFixpoint' 'run'---  . 'Polysemy.State.runLazyState' @Int 1+--    'Data.Functor.Identity.runIdentity'+--  . 'runFinal'+--  . 'fixpointToFinal' \@'Data.Functor.Identity.Identity'+--  . 'Polysemy.State.runLazyState' \@Int 1 --  . 'Polysemy.Error.runError' --  $ mdo --   'Polysemy.State.put' a@@ -37,16 +43,40 @@ --   return a -- @ ----- 'runFixpoint' also operates under the assumption that any effectful+-- 'fixpointToFinal' also operates under the assumption that any effectful -- state which can't be inspected using 'Polysemy.Inspector' can't contain any--- values. This is true for all interpreters featured in this package,+-- values. For example, the effectful state for 'Polysemy.Error.runError' is+-- @'Either' e a@. The inspector for this effectful state only fails if the+-- effectful state is a @'Left'@ value, which therefore doesn't contain any+-- values of @a@.+--+-- This assumption holds true for all interpreters featured in this package, -- and is presumably always true for any properly implemented interpreter.--- 'runFixpoint' may throw an exception if it is used together with an+-- 'fixpointToFinal' may throw an exception if it is used together with an -- interpreter that uses 'Polysemy.Internal.Union.weave' improperly. ----- If 'runFixpoint' throws an exception for you, and it can't+-- If 'fixpointToFinal' throws an exception for you, and it can't -- be due to any of the above, then open an issue over at the -- GitHub repository for polysemy.+--+-- @since 1.2.0.0+fixpointToFinal :: forall m r a+                 . (Member (Final m) r, MonadFix m)+                => Sem (Fixpoint ': r) a+                -> Sem r a+fixpointToFinal = interpretFinal @m $+  \(Fixpoint f) -> do+    f'  <- bindS f+    s   <- getInitialStateS+    ins <- getInspectorS+    pure $ mfix $ \fa -> f' $+      fromMaybe (bomb "fixpointToFinal") (inspect ins fa) <$ s+{-# INLINE fixpointToFinal #-}++------------------------------------------------------------------------------+-- | Run a 'Fixpoint' effect purely.+--+-- __Note__: 'runFixpoint' is subject to the same caveats as 'fixpointToFinal'. runFixpoint     :: (∀ x. Sem r x -> x)     -> Sem (Fixpoint ': r) a@@ -60,11 +90,14 @@       lower . runFixpoint lower . c $         fromMaybe (bomb "runFixpoint") (inspect ins fa) <$ s {-# INLINE runFixpoint #-}+{-# DEPRECATED runFixpoint "Use 'fixpointToFinal' together with \+                           \'Data.Functor.Identity.Identity' instead" #-} + ------------------------------------------------------------------------------ -- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance. ----- __Note__: 'runFixpointM' is subject to the same caveats as 'runFixpoint'.+-- __Note__: 'runFixpointM' is subject to the same caveats as 'fixpointToFinal'. runFixpointM     :: ( MonadFix m        , Member (Embed m) r@@ -81,3 +114,4 @@       lower . runFixpointM lower . c $         fromMaybe (bomb "runFixpointM") (inspect ins fa) <$ s {-# INLINE runFixpointM #-}+{-# DEPRECATED runFixpointM "Use 'fixpointToFinal' instead" #-}

@@ -18,6 +18,7 @@   , raiseUnder   , raiseUnder2   , raiseUnder3+  , subsume   , Embed (..)   , usingSem   , liftSem@@ -60,15 +61,19 @@ -- interpretations (and others that you might add) may be used interchangably -- without needing to write any newtypes or 'Monad' instances. The only -- change needed to swap interpretations is to change a call from--- 'Polysemy.Error.runError' to 'Polysemy.Error.lowerError'.+-- 'Polysemy.Error.runError' to 'Polysemy.Error.errorToIOFinal'. -- -- The effect stack @r@ can contain arbitrary other monads inside of it. These -- monads are lifted into effects via the 'Embed' effect. Monadic values can be -- lifted into a 'Sem' via 'embed'. --+-- Higher-order actions of another monad can be lifted into higher-order actions+-- of 'Sem' via the 'Polysemy.Final' effect, which is more powerful+-- than 'Embed', but also less flexible to interpret.+-- -- A 'Sem' can be interpreted as a pure value (via 'run') or as any--- traditional 'Monad' (via 'runM'). Each effect @E@ comes equipped with some--- interpreters of the form:+-- traditional 'Monad' (via 'runM' or 'Polysemy.runFinal').+-- Each effect @E@ comes equipped with some interpreters of the form: -- -- @ -- runE :: 'Sem' (E ': r) a -> 'Sem' r a@@ -126,8 +131,9 @@ -- behaviour over other effects later in the chain. -- -- After all of your effects are handled, you'll be left with either--- a @'Sem' '[] a@ or a @'Sem' '[ 'Embed' m ] a@ value, which can be--- consumed respectively by 'run' and 'runM'.+-- a @'Sem' '[] a@, a @'Sem' '[ 'Embed' m ] a@, or a @'Sem' '[ 'Polysemy.Final' m ] a@+-- value, which can be consumed respectively by 'run', 'runM', and+-- 'Polysemy.runFinal'. -- -- ==== Examples --@@ -272,7 +278,7 @@   mzero = empty   mplus = (<|>) --- | TODO: @since _+-- | @since 1.1.0.0 instance (Member Fail r) => MonadFail (Sem r) where   fail = send . Fail   {-# INLINE fail #-}@@ -303,6 +309,7 @@ hoistSem nat (Sem m) = Sem $ \k -> m $ \u -> k $ nat u {-# INLINE hoistSem #-} + ------------------------------------------------------------------------------ -- | Introduce an effect into 'Sem'. Analogous to -- 'Control.Monad.Class.Trans.lift' in the mtl ecosystem@@ -314,6 +321,30 @@ ------------------------------------------------------------------------------ -- | Like 'raise', but introduces a new effect underneath the head of the -- list.+--+-- 'raiseUnder' can be used in order to turn transformative interpreters+-- into reinterpreters. This is especially useful if you're writing an interpreter+-- which introduces an intermediary effect, and then want to use an existing+-- interpreter on that effect.+--+-- For example, given:+--+-- @+-- fooToBar :: 'Member' Bar r => 'Sem' (Foo ': r) a -> 'Sem' r a+-- runBar   :: 'Sem' (Bar ': r) a -> 'Sem' r a+-- @+--+-- You can write:+--+-- @+-- runFoo :: 'Sem' (Foo ': r) a -> 'Sem' r a+-- runFoo =+--     runBar     -- Consume Bar+--   . fooToBar   -- Interpret Foo in terms of the new Bar+--   . 'raiseUnder' -- Introduces Bar under Foo+-- @+--+-- @since 1.2.0.0 raiseUnder :: ∀ e2 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': r) a raiseUnder = hoistSem $ hoist raiseUnder . weakenUnder   where@@ -327,6 +358,8 @@ ------------------------------------------------------------------------------ -- | Like 'raise', but introduces two new effects underneath the head of the -- list.+--+-- @since 1.2.0.0 raiseUnder2 :: ∀ e2 e3 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': r) a raiseUnder2 = hoistSem $ hoist raiseUnder2 . weakenUnder2   where@@ -340,6 +373,8 @@ ------------------------------------------------------------------------------ -- | Like 'raise', but introduces two new effects underneath the head of the -- list.+--+-- @since 1.2.0.0 raiseUnder3 :: ∀ e2 e3 e4 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': e4 ': r) a raiseUnder3 = hoistSem $ hoist raiseUnder3 . weakenUnder3   where@@ -349,6 +384,20 @@     {-# INLINE weakenUnder3 #-} {-# INLINE raiseUnder3 #-} +------------------------------------------------------------------------------+-- | Interprets an effect in terms of another identical effect.+--+-- This is useful for defining interpreters that use 'Polysemy.reinterpretH'+-- without immediately consuming the newly introduced effect.+-- Using such an interpreter recursively may result in duplicate effects,+-- which may then be eliminated using 'subsume'.+--+-- @since 1.2.0.0+subsume :: Member e r => Sem (e ': r) a -> Sem r a+subsume = hoistSem $ \u -> hoist subsume $ case decomp u of+  Right w -> injWeaving w+  Left  g -> g+{-# INLINE subsume #-}  ------------------------------------------------------------------------------ -- | Embed an effect into a 'Sem'. This is used primarily via@@ -415,6 +464,11 @@ -- just for initialization. This can result in rather surprising behavior. For -- a version of '.@' that won't duplicate work, see the @.\@!@ operator in -- <http://hackage.haskell.org/package/polysemy-zoo/docs/Polysemy-IdempotentLowering.html polysemy-zoo>.+--+-- Interpreters using 'Polysemy.Final' may be composed normally, and+-- avoid the work duplication issue. For that reason, you're encouraged to use+-- @-'Polysemy.Final'@ interpreters instead of @lower-@ interpreters whenever+-- possible. (.@)     :: Monad m     => (∀ x. Sem r x -> m x)

@@ -4,13 +4,14 @@  ------------------------------------------------------------------------------ -- | An effect for providing 'Control.Monad.Fix.mfix'.-data Fixpoint m a where+newtype Fixpoint m a where   Fixpoint :: (a -> m a) -> Fixpoint m a   --------------------------------------------------------------------------------- | The error used in 'Polysemy.Fixpoint.runFixpoint' and--- 'Polysemy.Fixpoint.runFixpointM' when the result of a failed computation+-- | The error used in 'Polysemy.Fixpoint.fixpointToFinal',+-- 'Polysemy.Fixpoint.runFixpoint' and 'Polysemy.Fixpoint.runFixpointM'+-- when the result of a failed computation -- is recursively used and somehow visible. You may use this for your own -- 'Fixpoint' interpreters. The argument should be the name of the interpreter. bomb :: String -> a

@@ -9,6 +9,7 @@ import qualified Control.Concurrent.Async as A import           Control.Concurrent.Chan.Unagi import           Control.Concurrent.MVar+import           Control.Exception import           Polysemy.Internal import           Polysemy.Internal.Union @@ -66,7 +67,7 @@   res <- embed $ A.async $ do     a <- action (runViaForklift inchan)                 (putMVar signal ())-    putMVar signal ()+          `finally` (putMVar signal ())     pure a    let me = do

@@ -0,0 +1,131 @@+{-# OPTIONS_HADDOCK not-home #-}++module Polysemy.Internal.Strategy where++import Polysemy.Internal+import Polysemy.Internal.Combinators+import Polysemy.Internal.Tactics (Inspector(..))++++data Strategy m f n z a where+  GetInitialState     :: Strategy m f n z (f ())+  HoistInterpretation :: (a -> n b) -> Strategy m f n z (f a -> m (f b))+  GetInspector        :: Strategy m f n z (Inspector f)+++------------------------------------------------------------------------------+-- | 'Strategic' is an environment in which you're capable of explicitly+-- threading higher-order effect states to the final monad.+-- This is a variant of @Tactics@ (see 'Polysemy.Tactical'), and usage+-- is extremely similar.+--+-- @since 1.2.0.0+type Strategic m n a = forall f. Functor f => Sem (WithStrategy m f n) (m (f a))+++------------------------------------------------------------------------------+-- | @since 1.2.0.0+type WithStrategy m f n = '[Strategy m f n]+++------------------------------------------------------------------------------+-- | Internal function to process Strategies in terms of+-- 'Polysemy.Final.withWeavingToFinal'.+--+-- @since 1.2.0.0+runStrategy :: Functor f+            => Sem '[Strategy m f n] a+            -> f ()+            -> (forall x. f (n x) -> m (f x))+            -> (forall x. f x -> Maybe x)+            -> a+runStrategy sem = \s wv ins -> run $ interpret+  (\case+    GetInitialState       -> pure s+    HoistInterpretation f -> pure $ \fa -> wv (f <$> fa)+    GetInspector          -> pure (Inspector ins)+  ) sem+{-# INLINE runStrategy #-}+++------------------------------------------------------------------------------+-- | Get a natural transformation capable of potentially inspecting values+-- inside of @f@. Binding the result of 'getInspectorS' produces a function that+-- can sometimes peek inside values returned by 'bindS'.+--+-- This is often useful for running callback functions that are not managed by+-- polysemy code.+--+-- See also 'Polysemy.getInspectorT'+--+-- @since 1.2.0.0+getInspectorS :: forall m f n. Sem (WithStrategy m f n) (Inspector f)+getInspectorS = send (GetInspector @m @f @n)+{-# INLINE getInspectorS #-}+++------------------------------------------------------------------------------+-- | Get the stateful environment of the world at the moment the+-- @Strategy@ is to be run.+--+-- Prefer 'pureS', 'liftS', 'runS', or 'bindS' instead of using this function+-- directly.+--+-- @since 1.2.0.0+getInitialStateS :: forall m f n. Sem (WithStrategy m f n) (f ())+getInitialStateS = send (GetInitialState @m @f @n)+{-# INLINE getInitialStateS #-}+++------------------------------------------------------------------------------+-- | Embed a value into 'Strategic'.+--+-- @since 1.2.0.0+pureS :: Applicative m => a -> Strategic m n a+pureS a = pure . (a <$) <$> getInitialStateS+{-# INLINE pureS #-}+++------------------------------------------------------------------------------+-- | Lifts an action of the final monad into 'Strategic'.+--+-- /Note/: you don't need to use this function if you already have a monadic+-- action with the functorial state threaded into it, by the use of+-- 'runS' or 'bindS'.+-- In these cases, you need only use 'pure' to embed the action into the+-- 'Strategic' environment.+--+-- @since 1.2.0.0+liftS :: Functor m => m a -> Strategic m n a+liftS m = do+  s <- getInitialStateS+  pure $ fmap (<$ s) m+{-# INLINE liftS #-}+++------------------------------------------------------------------------------+-- | Lifts a monadic action into the stateful environment, in terms+-- of the final monad.+-- The stateful environment will be the same as the one that the @Strategy@+-- is initially run in.+--+-- Use 'bindS'  if you'd prefer to explicitly manage your stateful environment.+--+-- @since 1.2.0.0+runS :: n a -> Sem (WithStrategy m f n) (m (f a))+runS na = bindS (const na) <*> getInitialStateS+{-# INLINE runS #-}+++------------------------------------------------------------------------------+-- | Embed a kleisli action into the stateful environment, in terms of the final+-- monad. You can use 'bindS' to get an effect parameter of the form @a -> n b@+-- into something that can be used after calling 'runS' on an effect parameter+-- @n a@.+--+-- @since 1.2.0.0+bindS :: (a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))+bindS = send . HoistInterpretation+{-# INLINE bindS #-}+

@@ -20,6 +20,7 @@   , hoist   -- * Building Unions   , inj+  , injWeaving   , weaken   -- * Using Unions   , decomp@@ -227,18 +228,23 @@  ------------------------------------------------------------------------------ -- | Lift an effect @e@ into a 'Union' capable of holding it.-inj :: forall r e a m. (Functor m , Member e r) => e m a -> Union r m a-inj e = Union (finder @_ @r @e) $+inj :: forall e r m a. (Functor m , Member e r) => e m a -> Union r m a+inj e = injWeaving $   Weaving e (Identity ())             (fmap Identity . runIdentity)             runIdentity             (Just . runIdentity) {-# INLINE inj #-} +------------------------------------------------------------------------------+-- | Lift a @'Weaving' e@ into a 'Union' capable of holding it.+injWeaving :: forall e r m a. Member e r => Weaving e m a -> Union r m a+injWeaving = Union (finder @_ @r @e)+{-# INLINE injWeaving #-}  ------------------------------------------------------------------------------ -- | Attempt to take an @e@ effect out of a 'Union'.-prj :: forall e r a m+prj :: forall e r m a      . ( Member e r        )     => Union r m a

@@ -0,0 +1,158 @@+{-# LANGUAGE BangPatterns, TemplateHaskell, TupleSections #-}+{-# OPTIONS_HADDOCK not-home #-}+module Polysemy.Internal.Writer where++import Control.Concurrent.STM+import Control.Exception+import Control.Monad++import Data.Semigroup++import Polysemy+import Polysemy.Final+++------------------------------------------------------------------------------+-- | An effect capable of emitting and intercepting messages.+data Writer o m a where+  Tell   :: o -> Writer o m ()+  Listen :: ∀ o m a. m a -> Writer o m (o, a)+  Pass   :: m (o -> o, a) -> Writer o m a++makeSem ''Writer++-- TODO(KingoftheHomeless): Research if this is more or less efficient than+-- using 'reinterpretH' + 'subsume'++-----------------------------------------------------------------------------+-- | Transform a @'Writer' o@ effect into a  @'Writer' ('Endo' o)@ effect,+-- right-associating all uses of '<>' for @o@.+--+-- This can be used together with 'raiseUnder' in order to create+-- @-AssocR@ variants out of regular 'Writer' interpreters.+--+-- @since 1.2.0.0+writerToEndoWriter+    :: (Monoid o, Member (Writer (Endo o)) r)+    => Sem (Writer o ': r) a+    -> Sem r a+writerToEndoWriter = interpretH $ \case+      Tell o   -> tell (Endo (o <>)) >>= pureT+      Listen m -> do+        m' <- writerToEndoWriter <$> runT m+        raise $ do+          (o, fa) <- listen m'+          return $ (,) (appEndo o mempty) <$> fa+      Pass m -> do+        ins <- getInspectorT+        m'  <- writerToEndoWriter <$> runT m+        raise $ pass $ do+          t <- m'+          let+            f' =+              maybe+                id+                (\(f, _) (Endo oo) -> let !o' = f (oo mempty) in Endo (o' <>))+                (inspect ins t)+          return (f', fmap snd t)+{-# INLINE writerToEndoWriter #-}+++-- TODO(KingoftheHomeless): Make this mess more palatable+--+-- 'interpretFinal' is too weak for our purposes, so we+-- use 'interpretH' + 'withWeavingToFinal'.++------------------------------------------------------------------------------+-- | A variant of 'Polysemy.Writer.runWriterTVar' where an 'STM' action is+-- used instead of a 'TVar' to commit 'tell's.+runWriterSTMAction :: forall o r a+                          . (Member (Final IO) r, Monoid o)+                         => (o -> STM ())+                         -> Sem (Writer o ': r) a+                         -> Sem r a+runWriterSTMAction write = interpretH $ \case+  Tell o -> do+    t <- embedFinal $ atomically (write o)+    pureT t+  Listen m -> do+    m' <- runT m+    -- Using 'withWeavingToFinal' instead of 'withStrategicToFinal'+    -- here allows us to avoid using two additional 'embedFinal's in+    -- order to create the TVars.+    raise $ withWeavingToFinal $ \s wv _ -> mask $ \restore -> do+      -- See below to understand how this works+      tvar   <- newTVarIO mempty+      switch <- newTVarIO False+      fa     <-+        restore (wv (runWriterSTMAction (write' tvar switch) m' <$ s))+          `onException` commit tvar switch id+      o      <- commit tvar switch id+      return $ (fmap . fmap) (o, ) fa+  Pass m -> do+    m'  <- runT m+    ins <- getInspectorT+    raise $ withWeavingToFinal $ \s wv ins' -> mask $ \restore -> do+      tvar   <- newTVarIO mempty+      switch <- newTVarIO False+      t      <-+        restore (wv (runWriterSTMAction (write' tvar switch) m' <$ s))+          `onException` commit tvar switch id+      _      <- commit tvar switch+        (maybe id fst $ ins' t >>= inspect ins)+      return $ (fmap . fmap) snd t++  where+    {- KingoftheHomeless:+      'write'' is used by the argument computation to a 'listen' or 'pass'+      in order to 'tell', rather than directly using the 'write'.+      This is because we need to temporarily store its+      'tell's seperately in order for the 'listen'/'pass' to work+      properly. Once the 'listen'/'pass' completes, we 'commit' the+      changes done to the local tvar globally through 'write'.++      'commit' is protected by 'mask'+'onException'. Combine this+      with the fact that the 'withWeavingToFinal' can't be interrupted+      by pure errors emitted by effects (since these will be+      represented as part of the functorial state), and we+      guarantee that no writes will be lost if the argument computation+      fails for whatever reason.++      The argument computation to a 'listen'/'pass' may also spawn+      asynchronous computations which do 'tell's of their own.+      In order to make sure these 'tell's won't be lost once a+      'listen'/'pass' completes, a switch is used to+      control which tvar 'write'' writes to. The switch is flipped+      atomically together with commiting the writes of the local tvar+      as part of 'commit'. Once the switch is flipped,+      any asynchrounous computations spawned by the argument+      computation will write to the global tvar instead of the local+      tvar (which is no longer relevant), and thus no writes will be+      lost.+    -}+    write' :: TVar o+           -> TVar Bool+           -> o+           -> STM ()+    write' tvar switch = \o -> do+      useGlobal <- readTVar switch+      if useGlobal then+        write o+      else do+        s <- readTVar tvar+        writeTVar tvar $! s <> o++    commit :: TVar o+           -> TVar Bool+           -> (o -> o)+           -> IO o+    commit tvar switch f = atomically $ do+      o <- readTVar tvar+      let !o' = f o+      -- Likely redundant, but doesn't hurt.+      alreadyCommited <- readTVar switch+      unless alreadyCommited $+        write o'+      writeTVar switch True+      return o'+{-# INLINE runWriterSTMAction #-}

@@ -13,14 +13,63 @@  import Control.Applicative import Control.Monad.Trans.Maybe-import Data.Maybe+ import Polysemy import Polysemy.Error import Polysemy.Internal import Polysemy.Internal.NonDet import Polysemy.Internal.Union +------------------------------------------------------------------------------+-- | Run a 'NonDet' effect in terms of some underlying 'Alternative' @f@.+runNonDet :: Alternative f => Sem (NonDet ': r) a -> Sem r (f a)+runNonDet = runNonDetC . runNonDetInC+{-# INLINE runNonDet #-} +------------------------------------------------------------------------------+-- | Run a 'NonDet' effect in terms of an underlying 'Maybe'+--+-- Unlike 'runNonDet', uses of '<|>' will not execute the+-- second branch at all if the first option succeeds.+--+-- @since 1.1.0.0+runNonDetMaybe :: Sem (NonDet ': r) a -> Sem r (Maybe a)+runNonDetMaybe (Sem sem) = Sem $ \k -> runMaybeT $ sem $ \u ->+  case decomp u of+    Right (Weaving e s wv ex _) ->+      case e of+        Empty -> empty+        Choose left right ->+          MaybeT $ usingSem k $ runMaybeT $ fmap ex $ do+              MaybeT (runNonDetMaybe (wv (left <$ s)))+          <|> MaybeT (runNonDetMaybe (wv (right <$ s)))+    Left x -> MaybeT $+      k $ weave (Just ())+          (maybe (pure Nothing) runNonDetMaybe)+          id+          x+{-# INLINE runNonDetMaybe #-}++------------------------------------------------------------------------------+-- | Transform a 'NonDet' effect into an @'Error' e@ effect,+-- through providing an exception that 'empty' may be mapped to.+--+-- This allows '<|>' to handle 'throw's of the @'Error' e@ effect.+--+-- @since 1.1.0.0+nonDetToError :: Member (Error e) r+              => e+              -> Sem (NonDet ': r) a+              -> Sem r a+nonDetToError (e :: e) = interpretH $ \case+  Empty -> throw e+  Choose left right -> do+    left'  <- nonDetToError e <$> runT left+    right' <- nonDetToError e <$> runT right+    raise (left' `catch` \(_ :: e) -> right')+{-# INLINE nonDetToError #-}++ -------------------------------------------------------------------------------- -- This stuff is lifted from 'fused-effects'. Thanks guys! runNonDetC :: (Alternative f, Applicative m) => NonDetC m a -> m (f a)@@ -56,63 +105,49 @@     a (\ a' -> unNonDetC (f a') cons)   {-# INLINE (>>=) #-} ----------------------------------------------------------------------------------- | Run a 'NonDet' effect in terms of some underlying 'Alternative' @f@.-runNonDet :: Alternative f => Sem (NonDet ': r) a -> Sem r (f a)-runNonDet = runNonDetC . runNonDetInC-{-# INLINE runNonDet #-}- runNonDetInC :: Sem (NonDet ': r) a -> NonDetC (Sem r) a runNonDetInC = usingSem $ \u ->   case decomp u of-    Left x  -> NonDetC $ \cons nil -> do-      z <- liftSem $ weave [()]-                     (fmap concat . traverse runNonDet)-                     -- TODO(sandy): Is this the right semantics?-                     listToMaybe-                     x-      foldr cons nil z+    Left x  -> consC $ fmap getNonDetState $+      liftSem $ weave (NonDetState (Just ((), empty)))+                  distribNonDetC+                  -- TODO(KingoftheHomeless): Is THIS the right semantics?+                  (fmap fst . getNonDetState)+                  x     Right (Weaving Empty _ _ _ _) -> empty     Right (Weaving (Choose left right) s wv ex _) -> fmap ex $       runNonDetInC (wv (left <$ s)) <|> runNonDetInC (wv (right <$ s)) {-# INLINE runNonDetInC #-} ---------------------------------------------------------------------------------- | Run a 'NonDet' effect in terms of an underlying 'Maybe'+-- This choice of functorial state is inspired from the+-- MonadBaseControl instance for 'ListT' from 'list-t'. ----- Unlike 'runNonDet', uses of '<|>' will not execute the--- second branch at all if the first option succeeds.-runNonDetMaybe :: Sem (NonDet ': r) a -> Sem r (Maybe a)-runNonDetMaybe (Sem sem) = Sem $ \k -> runMaybeT $ sem $ \u ->-  case decomp u of-    Right (Weaving e s wv ex _) ->-      case e of-        Empty -> empty-        Choose left right ->-          MaybeT $ usingSem k $ runMaybeT $ fmap ex $ do-              MaybeT (runNonDetMaybe (wv (left <$ s)))-          <|> MaybeT (runNonDetMaybe (wv (right <$ s)))-    Left x -> MaybeT $-      k $ weave (Just ())-          (maybe (pure Nothing) runNonDetMaybe)-          id-          x-{-# INLINE runNonDetMaybe #-}+-- TODO(KingoftheHomeless):+-- Is there a different representation of this which doesn't require+-- 'unconsC' in 'distribNonDetC'?+newtype NonDetState r a = NonDetState {+  getNonDetState :: Maybe (a, NonDetC (Sem r) a)+  } deriving (Functor) ---------------------------------------------------------------------------------- | Transform a 'NonDet' effect into an @'Error' e@ effect,--- through providing an exception that 'empty' may be mapped to.------ This allows '<|>' to handle 'throw's of the @'Error' e@ effect.-nonDetToError :: Member (Error e) r-              => e-              -> Sem (NonDet ': r) a-              -> Sem r a-nonDetToError (e :: e) = interpretH $ \case-  Empty -> throw e-  Choose left right -> do-    left'  <- nonDetToError e <$> runT left-    right' <- nonDetToError e <$> runT right-    raise (left' `catch` \(_ :: e) -> right')-{-# INLINE nonDetToError #-}+-- KingoftheHomeless: The performance of this could be improved+-- if we weren't forced to use unconsC, which causes this to have+-- potentially O(n^2) behaviour.+distribNonDetC :: NonDetState r (Sem (NonDet ': r) a) -> Sem r (NonDetState r a)+distribNonDetC = \case+  NonDetState (Just (a, r)) ->+    fmap NonDetState $ unconsC $ runNonDetInC a <|> (r >>= runNonDetInC)+  _ ->+    pure (NonDetState Nothing)+{-# INLINE distribNonDetC #-}++-- O(n)+unconsC :: NonDetC (Sem r) a -> Sem r (Maybe (a, NonDetC (Sem r) a))+unconsC (NonDetC n) = n (\a r -> pure (Just (a, consC r))) (pure Nothing)+{-# INLINE unconsC #-}++consC :: Sem r (Maybe (a, NonDetC (Sem r) a)) -> NonDetC (Sem r) a+consC m = NonDetC $ \cons nil -> m >>= \case+  Just (a, r) -> cons a (unNonDetC r cons nil)+  _           -> nil+{-# INLINE consC #-}+

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BangPatterns, TemplateHaskell #-}  module Polysemy.Output   ( -- * Effect@@ -13,6 +13,8 @@   , runOutputMonoidAssocR   , runOutputMonoidIORef   , runOutputMonoidTVar+  , outputToIOMonoid+  , outputToIOMonoidAssocR   , ignoreOutput   , runOutputBatched   , runOutputSem@@ -75,6 +77,8 @@ -- -- You should always use this instead of 'runOutputMonoid' if the monoid -- is a list, such as 'String'.+--+-- @since 1.1.0.0 runOutputMonoidAssocR     :: forall o m r a      . Monoid m@@ -83,12 +87,14 @@     -> Sem r (m, a) runOutputMonoidAssocR f =     fmap (first (`appEndo` mempty))-  . runOutputMonoid (\a -> Endo (f a <>))+  . runOutputMonoid (\o -> let !o' = f o in Endo (o' <>)) {-# INLINE runOutputMonoidAssocR #-}  ------------------------------------------------------------------------------ -- | Run an 'Output' effect by transforming it into atomic operations -- over an 'IORef'.+--+-- @since 1.1.0.0 runOutputMonoidIORef     :: forall o m r a      . (Monoid m, Member (Embed IO) r)@@ -97,12 +103,14 @@     -> Sem (Output o ': r) a     -> Sem r a runOutputMonoidIORef ref f = interpret $ \case-  Output o -> embed $ atomicModifyIORef' ref (\s -> (s <> f o, ()))+  Output o -> embed $ atomicModifyIORef' ref (\s -> let !o' = f o in (s <> o', ())) {-# INLINE runOutputMonoidIORef #-}  ------------------------------------------------------------------------------ -- | Run an 'Output' effect by transforming it into atomic operations -- over a 'TVar'.+--+-- @since 1.1.0.0 runOutputMonoidTVar     :: forall o m r a      . (Monoid m, Member (Embed IO) r)@@ -115,6 +123,64 @@     s <- readTVar tvar     writeTVar tvar $! s <> f o {-# INLINE runOutputMonoidTVar #-}+++--------------------------------------------------------------------+-- | Run an 'Output' effect in terms of atomic operations+-- in 'IO'.+--+-- Internally, this simply creates a new 'IORef', passes it to+-- 'runOutputMonoidIORef', and then returns the result and the final value+-- of the 'IORef'.+--+-- /Beware/: As this uses an 'IORef' internally,+-- all other effects will have local+-- state semantics in regards to 'Output' effects+-- interpreted this way.+-- For example, 'Polysemy.Error.throw' and 'Polysemy.Error.catch' will+-- never revert 'output's, even if 'Polysemy.Error.runError' is used+-- after 'outputToIOMonoid'.+--+-- @since 1.2.0.0+outputToIOMonoid+  :: forall o m r a+   . (Monoid m, Member (Embed IO) r)+  => (o -> m)+  -> Sem (Output o ': r) a+  -> Sem r (m, a)+outputToIOMonoid f sem = do+  ref <- embed $ newIORef mempty+  res <- runOutputMonoidIORef ref f sem+  end <- embed $ readIORef ref+  return (end, res)++------------------------------------------------------------------------------+-- | Like 'outputToIOMonoid', but right-associates uses of '<>'.+--+-- This asymptotically improves performance if the time complexity of '<>' for+-- the 'Monoid' depends only on the size of the first argument.+--+-- You should always use this instead of 'outputToIOMonoid' if the monoid+-- is a list, such as 'String'.+--+-- /Beware/: As this uses an 'IORef' internally,+-- all other effects will have local+-- state semantics in regards to 'Output' effects+-- interpreted this way.+-- For example, 'Polysemy.Error.throw' and 'Polysemy.Error.catch' will+-- never revert 'output's, even if 'Polysemy.Error.runError' is used+-- after 'outputToIOMonoidAssocR'.+--+-- @since 1.2.0.0+outputToIOMonoidAssocR+  :: forall o m r a+   . (Monoid m, Member (Embed IO) r)+  => (o -> m)+  -> Sem (Output o ': r) a+  -> Sem r (m, a)+outputToIOMonoidAssocR f =+    (fmap . first) (`appEndo` mempty)+  . outputToIOMonoid (\o -> let !o' = f o in Endo (o' <>))  ------------------------------------------------------------------------------ -- | Run an 'Output' effect by ignoring it.

@@ -12,12 +12,14 @@      -- * Interpretations   , runResource-  , lowerResource+  , resourceToIOFinal   , resourceToIO+  , lowerResource   ) where  import qualified Control.Exception as X import           Polysemy+import           Polysemy.Final   ------------------------------------------------------------------------------@@ -72,9 +74,44 @@     -> Sem r a onException act end = bracketOnError (pure ()) (const end) (const act) +------------------------------------------------------------------------------+-- | Run a 'Resource' effect in terms of 'X.bracket' through final 'IO'+--+-- /Beware/: Effects that aren't interpreted in terms of 'IO'+-- will have local state semantics in regards to 'Resource' effects+-- interpreted this way. See 'Final'.+--+-- Notably, unlike 'resourceToIO', this is not consistent with+-- 'Polysemy.State.State' unless 'Polysemy.State.runStateInIORef' is used.+-- State that seems like it should be threaded globally throughout 'bracket's+-- /will not be./+--+-- Use 'resourceToIO' instead if you need to run+-- pure, stateful interpreters after the interpreter for 'Resource'.+-- (Pure interpreters are interpreters that aren't expressed in terms of+-- another effect or monad; for example, 'Polysemy.State.runState'.)+--+-- @since 1.2.0.0+resourceToIOFinal :: Member (Final IO) r+                  => Sem (Resource ': r) a+                  -> Sem r a+resourceToIOFinal = interpretFinal $ \case+  Bracket alloc dealloc use -> do+    a <- runS  alloc+    d <- bindS dealloc+    u <- bindS use+    pure $ X.bracket a d u +  BracketOnError alloc dealloc use -> do+    a <- runS  alloc+    d <- bindS dealloc+    u <- bindS use+    pure $ X.bracketOnError a d u+{-# INLINE resourceToIOFinal #-}++ --------------------------------------------------------------------------------- | Run a 'Resource' effect via in terms of 'X.bracket'.+-- | Run a 'Resource' effect in terms of 'X.bracket'. -- -- @since 1.0.0.0 lowerResource@@ -106,6 +143,7 @@      embed $ X.bracketOnError (run_it a) (run_it . d) (run_it . u) {-# INLINE lowerResource #-}+{-# DEPRECATED lowerResource "Use 'resourceToIOFinal' instead" #-}   ------------------------------------------------------------------------------@@ -148,7 +186,7 @@   --------------------------------------------------------------------------------- | A more flexible --- though less safe ---  version of 'lowerResource'.+-- | A more flexible --- though less safe ---  version of 'resourceToIOFinal' -- -- This function is capable of running 'Resource' effects anywhere within an -- effect stack, without relying on an explicit function to lower it into 'IO'.@@ -159,7 +197,7 @@ -- by effects _already handled_ in your effect stack, or in 'IO' code run -- directly inside of 'bracket'. It is not safe against exceptions thrown -- explicitly at the main thread. If this is not safe enough for your use-case,--- use 'lowerResource' instead.+-- use 'resourceToIOFinal' instead. -- -- This function creates a thread, and so should be compiled with @-threaded@. --

@@ -17,6 +17,7 @@   , runLazyState   , evalLazyState   , runStateIORef+  , stateToIO      -- * Interoperation with MTL   , hoistStateIntoStateT@@ -122,6 +123,39 @@   Put s -> embed $ writeIORef ref s {-# INLINE runStateIORef #-} +--------------------------------------------------------------------+-- | Run an 'State' effect in terms of operations+-- in 'IO'.+--+-- Internally, this simply creates a new 'IORef', passes it to+-- 'runStateIORef', and then returns the result and the final value+-- of the 'IORef'.+--+-- /Note/: This is not safe in a concurrent setting, as 'modify' isn't atomic.+-- If you need operations over the state to be atomic,+-- use 'Polysemy.AtomicState.atomicStateToIO' instead.+--+-- /Beware/: As this uses an 'IORef' internally,+-- all other effects will have local+-- state semantics in regards to 'State' effects+-- interpreted this way.+-- For example, 'Polysemy.Error.throw' and 'Polysemy.Error.catch' will+-- never revert 'put's, even if 'Polysemy.Error.runError' is used+-- after 'stateToIO'.+--+-- @since 1.2.0.0+stateToIO+    :: forall s r a+     . Member (Embed IO) r+    => s+    -> Sem (State s ': r) a+    -> Sem r (s, a)+stateToIO s sem = do+  ref <- embed $ newIORef s+  res <- runStateIORef ref sem+  end <- embed $ readIORef ref+  return (end, res)+{-# INLINE stateToIO #-}  ------------------------------------------------------------------------------ -- | Hoist a 'State' effect into a 'S.StateT' monad transformer. This can be

@@ -1,5 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE TupleSections #-}  module Polysemy.Writer   ( -- * Effect@@ -14,26 +13,27 @@     -- * Interpretations   , runWriter   , runWriterAssocR+  , runWriterTVar+  , writerToIOFinal+  , writerToIOAssocRFinal+  , writerToEndoWriter      -- * Interpretations for Other Effects   , outputToWriter   ) where +import Control.Concurrent.STM+ import Data.Bifunctor (first)+import Data.Semigroup  import Polysemy import Polysemy.Output import Polysemy.State +import Polysemy.Internal.Writer ---------------------------------------------------------------------------------- | An effect capable of emitting and intercepting messages.-data Writer o m a where-  Tell   :: o -> Writer o m ()-  Listen :: ∀ o m a. m a -> Writer o m (o, a)-  Pass   :: m (o -> o, a) -> Writer o m a -makeSem ''Writer  ------------------------------------------------------------------------------ -- | @since 0.7.0.0@@ -89,36 +89,77 @@ -- -- You should always use this instead of 'runWriter' if the monoid -- is a list, such as 'String'.+--+-- @since 1.1.0.0 runWriterAssocR     :: Monoid o     => Sem (Writer o ': r) a     -> Sem r (o, a) runWriterAssocR =-  let-    go :: forall o r a-        . Monoid o-       => Sem (Writer o ': r) a-       -> Sem r (o -> o, a)-    go =-        runState id-      . reinterpretH-      (\case-          Tell o -> do-            modify' @(o -> o) (. (o <>)) >>= pureT-          Listen m -> do-            mm <- runT m-            -- TODO(sandy): this is stupid-            (oo, fa) <- raise $ go mm-            modify' @(o -> o) (. oo)-            pure $ fmap (oo mempty, ) fa-          Pass m -> do-            mm <- runT m-            (o, t) <- raise $ runWriterAssocR mm-            ins <- getInspectorT-            let f = maybe id fst (inspect ins t)-            modify' @(o -> o) (. (f o <>))-            pure (fmap snd t)-      )-    {-# INLINE go #-}-  in fmap (first ($ mempty)) . go+    (fmap . first) (`appEndo` mempty)+  . runWriter+  . writerToEndoWriter+  . raiseUnder {-# INLINE runWriterAssocR #-}++--------------------------------------------------------------------+-- | Transform a 'Writer' effect into atomic operations+-- over a 'TVar' through final 'IO'.+--+-- @since 1.2.0.0+runWriterTVar :: (Monoid o, Member (Final IO) r)+              => TVar o+              -> Sem (Writer o ': r) a+              -> Sem r a+runWriterTVar tvar = runWriterSTMAction $ \o -> do+  s <- readTVar tvar+  writeTVar tvar $! s <> o+{-# INLINE runWriterTVar #-}+++--------------------------------------------------------------------+-- | Run a 'Writer' effect by transforming it into atomic operations+-- through final 'IO'.+--+-- Internally, this simply creates a new 'TVar', passes it to+-- 'runWriterTVar', and then returns the result and the final value+-- of the 'TVar'.+--+-- /Beware/: Effects that aren't interpreted in terms of 'IO'+-- will have local state semantics in regards to 'Writer' effects+-- interpreted this way. See 'Final'.+--+-- @since 1.2.0.0+writerToIOFinal :: (Monoid o, Member (Final IO) r)+                => Sem (Writer o ': r) a+                -> Sem r (o, a)+writerToIOFinal sem = do+  tvar <- embedFinal $ newTVarIO mempty+  res  <- runWriterTVar tvar sem+  end  <- embedFinal $ readTVarIO tvar+  return (end, res)+{-# INLINE writerToIOFinal #-}++--------------------------------------------------------------------+-- | Like 'writerToIOFinal'. but right-associates uses of '<>'.+--+-- This asymptotically improves performance if the time complexity of '<>'+-- for the 'Monoid' depends only on the size of the first argument.+--+-- You should always use this instead of 'writerToIOFinal' if the monoid+-- is a list, such as 'String'.+--+-- /Beware/: Effects that aren't interpreted in terms of 'IO'+-- will have local state semantics in regards to 'Writer' effects+-- interpreted this way. See 'Final'.+--+-- @since 1.2.0.0+writerToIOAssocRFinal :: (Monoid o, Member (Final IO) r)+                      => Sem (Writer o ': r) a+                      -> Sem r (o, a)+writerToIOAssocRFinal =+    (fmap . first) (`appEndo` mempty)+  . writerToIOFinal+  . writerToEndoWriter+  . raiseUnder+{-# INLINE writerToIOAssocRFinal #-}

@@ -2,7 +2,6 @@  module AsyncSpec where -import Control.Concurrent import Control.Concurrent.MVar import Control.Monad import Polysemy

@@ -0,0 +1,96 @@+{-# LANGUAGE RecursiveDo #-}+module FinalSpec where++import Test.Hspec++import Data.Either+import Data.IORef++import Polysemy+import Polysemy.Async+import Polysemy.Error+import Polysemy.Fixpoint+import Polysemy.Trace+import Polysemy.State+++data Node a = Node a (IORef (Node a))++mkNode :: (Member (Embed IO) r, Member Fixpoint r)+       => a+       -> Sem r (Node a)+mkNode a = mdo+  let nd = Node a p+  p <- embed $ newIORef nd+  return nd++linkNode :: Member (Embed IO) r+         => Node a+         -> Node a+         -> Sem r ()+linkNode (Node _ r) b =+  embed $ writeIORef r b++readNode :: Node a -> a+readNode (Node a _) = a++follow :: Member (Embed IO) r+       => Node a+       -> Sem r (Node a)+follow (Node _ ref) = embed $ readIORef ref++test1 :: IO (Either Int (String, Int, Maybe Int))+test1 = do+  ref <- newIORef "abra"+  runFinal+    . embedToFinal @IO+    . runStateIORef ref -- Order of these interpreters don't matter+    . errorToIOFinal+    . fixpointToFinal @IO+    . asyncToIOFinal+     $ do+     n1 <- mkNode 1+     n2 <- mkNode 2+     linkNode n2 n1+     aw <- async $ do+       linkNode n1 n2+       modify (++"hadabra")+       n2' <- follow n2+       throw (readNode n2')+     m <- await aw `catch` (\s -> return $ Just s)+     n1' <- follow n1+     s <- get+     return (s, readNode n1', m)++test2 :: IO ([String], Either () ())+test2 =+    runFinal+  . runTraceList+  . errorToIOFinal+  . asyncToIOFinal+  $ do+  fut <- async $ do+    trace "Global state semantics?"+  catch @() (trace "What's that?" *> throw ()) (\_ -> return ())+  _ <- await fut+  trace "Nothing at all."++++spec :: Spec+spec = do+  describe "Final on IO" $ do+    it "should terminate successfully, with no exceptions,\+        \ and have global state semantics on State." $ do+      res1 <- test1+      res1 `shouldSatisfy` isRight+      case res1 of+        Right (s, i, j) -> do+          i `shouldBe` 2+          j `shouldBe` Just 1+          s `shouldBe` "abrahadabra"+        _ -> pure ()++    it "should treat trace with local state semantics" $ do+      res2 <- test2+      res2 `shouldBe` (["Nothing at all."], Right ())

@@ -2,7 +2,8 @@ {-# LANGUAGE RecursiveDo #-} module FixpointSpec where -import Control.Exception (try, evaluate)+import Data.Functor.Identity+import Control.Exception (evaluate) import Control.Monad.Fix  import Polysemy@@ -29,8 +30,9 @@  test1 :: (String, (Int, ())) test1 =-    run-  . runFixpoint run+    runIdentity+  . runFinal+  . fixpointToFinal @Identity   . runOutputMonoid (show @Int)   . runFinalState 1   $ do@@ -42,8 +44,9 @@  test2 :: Either [Int] [Int] test2 =-    run-  . runFixpoint run+    runIdentity+  . runFinal+  . fixpointToFinal @Identity   . runError   $ mdo   a <- throw (2 : a) `catch` (\e -> return (1 : e))@@ -51,8 +54,9 @@  test3 :: Either () (Int, Int) test3 =-    run-  . runFixpoint run+    runIdentity+  . runFinal+  . fixpointToFinal @Identity   . runError   . runLazyState @Int 1   $ mdo@@ -62,8 +66,9 @@  test4 :: (Int, Either () Int) test4 =-    run-  . runFixpoint run+    runIdentity+  . runFinal+  . fixpointToFinal @Identity   . runLazyState @Int 1   . runError   $ mdo@@ -73,7 +78,7 @@   spec :: Spec-spec = parallel $ describe "runFixpoint" $ do+spec = parallel $ describe "fixpointToFinal on Identity" $ do   it "should work with runState" $ do     test1 `shouldBe` ("12",  (2, ()))   it "should work with runError" $ do@@ -88,10 +93,10 @@  bombMessage :: String bombMessage =-  "runFixpoint: Internal computation failed.\-              \ This is likely because you have tried to recursively use\-              \ the result of a failed computation in an action\-              \ whose effect may be observed even though the computation failed.\-              \ It's also possible that you're using an interpreter\-              \ that uses 'weave' improperly.\-              \ See documentation for more information."+  "fixpointToFinal: Internal computation failed.\+                  \ This is likely because you have tried to recursively use\+                  \ the result of a failed computation in an action\+                  \ whose effect may be observed even though the computation failed.\+                  \ It's also possible that you're using an interpreter\+                  \ that uses 'weave' improperly.\+                  \ See documentation for more information."

@@ -9,6 +9,7 @@ import Polysemy import Polysemy.Async import Polysemy.Output+import Polysemy.Final  import Test.Hspec @@ -47,8 +48,11 @@     it "should commit writes of asynced computations" $       let io = do             ref <- newIORef ""-            (runM .@ lowerAsync) . runOutputMonoidIORef ref (show @Int) $-              test1+            runFinal+              . embedToFinal @IO+              . asyncToIOFinal+              . runOutputMonoidIORef ref (show @Int)+              $ test1             readIORef ref       in do         res <- io@@ -58,8 +62,11 @@     it "should commit writes of asynced computations" $       let io = do             ref <- newTVarIO ""-            (runM .@ lowerAsync) . runOutputMonoidTVar ref (show @Int) $-              test1+            runFinal+              . embedToFinal @IO+              . asyncToIOFinal+              . runOutputMonoidTVar ref (show @Int)+              $ test1             readTVarIO ref       in do         res <- io

@@ -8,8 +8,6 @@ import Control.Concurrent.STM import Control.Exception (evaluate) -import Data.IORef- import Polysemy import Polysemy.Async import Polysemy.Error@@ -55,6 +53,56 @@ test3 :: (String, (String, ())) test3 = run . runWriter $ listen (tell "and hear") +test4 :: IO (String, String)+test4 = do+  tvar <- newTVarIO ""+  (listened, _) <- runFinal . asyncToIOFinal . runWriterTVar tvar $ do+    tell "message "+    listen $ do+      tell "has been"+      a <- async $ tell " received"+      await a+  end <- readTVarIO tvar+  return (end, listened)++test5 :: IO (String, String)+test5 = do+  tvar <- newTVarIO ""+  lock <- newEmptyMVar+  (listened, a) <- runFinal . asyncToIOFinal . runWriterTVar tvar $ do+    tell "message "+    listen $ do+      tell "has been"+      a <- async $ do+        embedFinal $ takeMVar lock+        tell " received"+      return a+  putMVar lock ()+  _ <- A.wait a+  end <- readTVarIO tvar+  return (end, listened)++test6 :: Sem '[Error (A.Async (Maybe ())), Final IO] String+test6 = do+  tvar <- embedFinal $ newTVarIO ""+  lock <- embedFinal $ newEmptyMVar+  let+      inner = do+        tell "message "+        fmap snd $ listen @String $ do+          tell "has been"+          a <- async $ do+            embedFinal $ takeMVar lock+            tell " received"+          throw a+  asyncToIOFinal (runWriterTVar tvar inner) `catch` \a ->+    embedFinal $ do+      putMVar lock ()+      (_ :: Maybe ()) <- A.wait a+      readTVarIO tvar+++ spec :: Spec spec = do   describe "writer" $ do@@ -87,3 +135,24 @@         evaluate (run t2) `shouldThrow` errorCall "strict"         runM t3           `shouldThrow` errorCall "strict"         evaluate (run t3) `shouldThrow` errorCall "strict"++  describe "runWriterTVar" $ do+    it "should listen and commit asyncs spawned and awaited upon in a listen \+       \block" $ do+      (end, listened) <- test4+      end `shouldBe` "message has been received"+      listened `shouldBe` "has been received"++    it "should commit writes of asyncs spawned inside a listen block even if \+       \the block has finished." $ do+      (end, listened) <- test5+      end `shouldBe` "message has been received"+      listened `shouldBe` "has been"+++    it "should commit writes of asyncs spawned inside a listen block even if \+       \the block failed for any reason." $ do+      Right end1 <- runFinal . errorToIOFinal $ test6+      Right end2 <- runFinal . runError $ test6+      end1 `shouldBe` "message has been received"+      end2 `shouldBe` "message has been received"