effectful-core 2.3.1.0 → 2.4.0.0

raw patch · 29 files changed

+1749/−633 lines, 29 filesdep +deepseqdep +safe-exceptionsdep +strict-mutable-basedep ~primitivePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, safe-exceptions, strict-mutable-base

Dependency ranges changed: primitive

API changes (from Hackage documentation)

Files

• CHANGELOG.md +36/−0
• effectful-core.cabal +15/−2
• src/Effectful.hs +3/−3
• src/Effectful/Dispatch/Dynamic.hs +359/−104
• src/Effectful/Error/Dynamic.hs +39/−9
• src/Effectful/Error/Static.hs +62/−28
• src/Effectful/Exception.hs +130/−0
• src/Effectful/Fail.hs +4/−4
• src/Effectful/Internal/Effect.hs +19/−11
• src/Effectful/Internal/Env.hs +185/−92
• src/Effectful/Internal/Monad.hs +72/−43
• src/Effectful/Internal/Unlift.hs +68/−57
• src/Effectful/Internal/Utils.hs +0/−59
• src/Effectful/Labeled.hs +26/−36
• src/Effectful/Labeled/Error.hs +139/−0
• src/Effectful/Labeled/Reader.hs +67/−0
• src/Effectful/Labeled/State.hs +177/−0
• src/Effectful/Labeled/Writer.hs +106/−0
• src/Effectful/NonDet.hs +47/−15
• src/Effectful/Provider.hs +37/−22
• src/Effectful/Provider/List.hs +55/−44
• src/Effectful/Reader/Dynamic.hs +4/−2
• src/Effectful/Reader/Static.hs +10/−6
• src/Effectful/State/Dynamic.hs +8/−16
• src/Effectful/State/Static/Local.hs +18/−14
• src/Effectful/State/Static/Shared.hs +27/−32
• src/Effectful/Writer/Dynamic.hs +6/−14
• src/Effectful/Writer/Static/Local.hs +14/−9
• src/Effectful/Writer/Static/Shared.hs +16/−11

@@ -1,3 +1,39 @@+# effectful-core-2.4.0.0 (2024-10-08)+* Add utility functions for handling effects that take the effect handler as the+  last parameter to `Effectful.Dispatch.Dynamic`.+* Add utility functions for handling first order effects to+  `Effectful.Dispatch.Dynamic`.+* Improve `Effectful.Labeled`, add `Effectful.Labeled.Error`,+  `Effectful.Labeled.Reader`, `Effectful.Labeled.State` and+  `Effectful.Labeled.Writer`.+* Add `throwErrorWith` and `throwError_` to `Effectful.Error.Static` and+  `Effectful.Error.Dynamic`.+* Add `HasCallStack` constraints where appropriate for better debugging+  experience.+* Add a `SeqForkUnlift` strategy to support running unlifting functions outside+  of the scope of effects they capture.+* Add `Effectful.Exception` with appropriate re-exports from the+  `safe-exceptions` library.+* **Bugfixes**:+  - Ensure that a `LocalEnv` is only used in a thread it belongs to.+  - Properly roll back changes made to the environment when `OnEmptyRollback`+    policy for the `NonDet` effect is selected.+  - Fix a bug in `stateM` and `modifyM` of thread local `State` effect that+    might've caused dropped state updates+    ([#237](https://github.com/haskell-effectful/effectful/issues/237)).+* **Breaking changes**:+  - `localSeqLend`, `localLend`, `localSeqBorrow` and `localBorrow` now take a+    list of effects instead of a single one.+  - `Effectful.Error.Static.throwError` now requires the error type to have a+    `Show` constraint. If this is not the case for some of your error types, use+    `throwError_` for them.+  - `ThrowError` operation from the dynamic version of the `Error` effect was+    replaced with `ThrowErrorWith`.+  - `stateEnv` and `modifyEnv` now take pure modification functions. If you rely+    on their old forms, switch to a combination of `getEnv` and `putEnv`.+  - `runStateMVar`, `evalStateMVar` and `execStateMVar` now take a strict+    `MVar'` from the `strict-mutable-base` package.+ # effectful-core-2.3.1.0 (2024-06-07) * Drop support for GHC 8.8. * Remove inaccurate information from the `Show` instance of `ErrorWrapper`.

@@ -1,7 +1,7 @@ cabal-version:      3.0 build-type:         Simple name:               effectful-core-version:            2.3.1.0+version:            2.4.0.0 license:            BSD-3-Clause license-file:       LICENSE category:           Control@@ -29,7 +29,10 @@   location: https://github.com/haskell-effectful/effectful.git  common language-    ghc-options:        -Wall -Wcompat -Wno-unticked-promoted-constructors+    ghc-options:        -Wall+                        -Wcompat+                        -Wno-unticked-promoted-constructors+                        -Wmissing-deriving-strategies                         -Werror=prepositive-qualified-module      default-language:   Haskell2010@@ -39,6 +42,7 @@                         DataKinds                         DeriveFunctor                         DeriveGeneric+                        DerivingStrategies                         FlexibleContexts                         FlexibleInstances                         GADTs@@ -47,6 +51,7 @@                         LambdaCase                         MultiParamTypeClasses                         NoStarIsType+                        PolyKinds                         RankNTypes                         RoleAnnotations                         ScopedTypeVariables@@ -63,9 +68,12 @@      build-depends:    base                >= 4.14      && < 5                     , containers          >= 0.6+                    , deepseq             >= 1.2                     , exceptions          >= 0.10.4                     , monad-control       >= 1.0.3                     , primitive           >= 0.7.3.0+                    , safe-exceptions     >= 0.1.7.2+                    , strict-mutable-base >= 1.1.0.0                     , transformers-base   >= 0.4.6                     , unliftio-core       >= 0.2.0.1 @@ -81,6 +89,7 @@                      Effectful.Dispatch.Static.Unsafe                      Effectful.Error.Dynamic                      Effectful.Error.Static+                     Effectful.Exception                      Effectful.Fail                      Effectful.Internal.Effect                      Effectful.Internal.Env@@ -88,6 +97,10 @@                      Effectful.Internal.Unlift                      Effectful.Internal.Utils                      Effectful.Labeled+                     Effectful.Labeled.Error+                     Effectful.Labeled.Reader+                     Effectful.Labeled.State+                     Effectful.Labeled.Writer                      Effectful.NonDet                      Effectful.Prim                      Effectful.Provider

@@ -148,7 +148,7 @@ -- -- These libraries can trivially be used with the 'Eff' monad since it provides -- typical instances that these libraries require the underlying monad to have,--- such as t'Control.Monad.Catch.MonadMask' or 'MonadUnliftIO'.+-- such as t'Effectful.Exception.MonadMask' or 'MonadUnliftIO'. -- -- In case the 'Eff' monad doesn't provide a specific instance out of the box, -- it can be supplied via an effect. As an example see how the instance of@@ -199,8 +199,8 @@ -- -- As an example, consider the following monad: ----- >>> import qualified Control.Monad.State as T--- >>> import qualified Control.Monad.Except as T+-- >>> import Control.Monad.State qualified as T+-- >>> import Control.Monad.Except qualified as T -- -- >>> data HandlerState -- >>> data HandlerError

@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE UndecidableInstances #-} -- | Dynamically dispatched effects.@@ -23,9 +24,13 @@     -- * Handling effects   , EffectHandler   , interpret+  , interpretWith   , reinterpret+  , reinterpretWith   , interpose+  , interposeWith   , impose+  , imposeWith      -- ** Handling local 'Eff' computations   , LocalEnv@@ -52,13 +57,23 @@   , localSeqBorrow   , localBorrow   , SharedSuffix+  , KnownSubset +    -- ** Utils for first order effects+  , EffectHandler_+  , interpret_+  , interpretWith_+  , reinterpret_+  , reinterpretWith_+  , interpose_+  , interposeWith_+  , impose_+  , imposeWith_+     -- * Re-exports   , HasCallStack   ) where -import Control.Monad-import Control.Monad.IO.Unlift import Data.Primitive.PrimArray import GHC.Stack (HasCallStack) import GHC.TypeLits@@ -138,11 +153,9 @@ -- The following defines an 'EffectHandler' that reads and writes files from the -- drive: ----- >>> import Control.Exception (IOException)--- >>> import Control.Monad.Catch (catch)--- >>> import qualified System.IO as IO--- -- >>> import Effectful.Error.Static+-- >>> import Effectful.Exception+-- >>> import System.IO qualified as IO -- -- >>> newtype FsError = FsError String deriving Show --@@ -155,7 +168,7 @@ --    ReadFile path           -> adapt $ IO.readFile path --    WriteFile path contents -> adapt $ IO.writeFile path contents --    where---      adapt m = liftIO m `catch` \(e::IOException) -> throwError . FsError $ show e+--      adapt m = liftIO m `catchIO` \e -> throwError . FsError $ show e -- :} -- -- Here, we use 'interpret' and simply execute corresponding 'IO' actions for@@ -164,8 +177,7 @@ -- On the other hand, maybe there is a situation in which instead of interacting -- with the outside world, a pure, in-memory storage is preferred: ----- >>> import qualified Data.Map.Strict as M---+-- >>> import Data.Map.Strict qualified as M -- >>> import Effectful.State.Static.Local -- -- >>> :{@@ -212,6 +224,9 @@ -- -- If an effect makes use of the @m@ parameter, it is a /higher order effect/. --+-- /Note:/ for handling first order effects you can use 'interpret_' or+-- 'reinterpret_' whose 'EffectHandler_' doesn't take the 'LocalEnv' parameter.+-- -- Interpretation of higher order effects is slightly more involving. To see -- why, let's consider the @Profiling@ effect for logging how much time a -- specific action took to run:@@ -343,7 +358,7 @@ -- -- >>> :{ --   runDummyRNG :: Eff (RNG : es) a -> Eff es a---   runDummyRNG = interpret $ \_ -> \case+--   runDummyRNG = interpret_ $ \case --     RandomInt -> pure 55 -- :} --@@ -381,9 +396,8 @@ -- ...    for functional dependency: ‘m -> i’... -- ... ----- However, there exists a [dirty--- trick](https://www.youtube.com/watch?v=ZXtdd8e7CQQ) for bypassing the--- coverage condition, i.e. including the instance head in the context:+-- However, there exists a trick for bypassing the coverage condition,+-- i.e. including the instance head in its context: -- -- >>> :{ --   instance (MonadInput i (Eff es), Reader i :> es) => MonadInput i (Eff es) where@@ -408,7 +422,7 @@ -- /Note:/ 'interpret' can be turned into a 'reinterpret' with the use of -- 'inject'. interpret-  :: DispatchOf e ~ Dynamic+  :: (HasCallStack, DispatchOf e ~ Dynamic)   => EffectHandler e es   -- ^ The effect handler.   -> Eff (e : es) a@@ -418,11 +432,22 @@   where     mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler) +-- | 'interpret' with the effect handler as the last argument.+--+-- @since 2.4.0.0+interpretWith+  :: (HasCallStack, DispatchOf e ~ Dynamic)+  => Eff (e : es) a+  -> EffectHandler e es+  -- ^ The effect handler.+  -> Eff      es  a+interpretWith m handler = interpret handler m+ -- | Interpret an effect using other, private effects. -- -- @'interpret' ≡ 'reinterpret' 'id'@ reinterpret-  :: DispatchOf e ~ Dynamic+  :: (HasCallStack, DispatchOf e ~ Dynamic)   => (Eff handlerEs a -> Eff es b)   -- ^ Introduction of effects encapsulated within the handler.   -> EffectHandler e handlerEs@@ -435,6 +460,19 @@   where     mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler) +-- | 'reinterpret' with the effect handler as the last argument.+--+-- @since 2.4.0.0+reinterpretWith+  :: (HasCallStack, DispatchOf e ~ Dynamic)+  => (Eff handlerEs a -> Eff es b)+  -- ^ Introduction of effects encapsulated within the handler.+  -> Eff (e : es) a+  -> EffectHandler e handlerEs+  -- ^ The effect handler.+  -> Eff      es  b+reinterpretWith runHandlerEs m handler = reinterpret runHandlerEs handler m+ -- | Replace the handler of an existing effect with a new one. -- -- /Note:/ this function allows for augmenting handlers with a new functionality@@ -442,29 +480,70 @@ -- -- >>> :{ --   data E :: Effect where---     Op :: E m ()+--     Op1 :: E m ()+--     Op2 :: E m () --   type instance DispatchOf E = Dynamic -- :} -- -- >>> :{ --   runE :: IOE :> es => Eff (E : es) a -> Eff es a---   runE = interpret $ \_ Op -> liftIO (putStrLn "op")+--   runE = interpret_ $ \case+--     Op1 -> liftIO (putStrLn "op1")+--     Op2 -> liftIO (putStrLn "op2") -- :} ----- >>> runEff . runE $ send Op--- op+-- >>> runEff . runE $ send Op1 >> send Op2+-- op1+-- op2 -- -- >>> :{---   augmentE :: (E :> es, IOE :> es) => Eff es a -> Eff es a---   augmentE = interpose $ \_ Op -> liftIO (putStrLn "augmented op") >> send Op+--   augmentOp2 :: (E :> es, IOE :> es) => Eff es a -> Eff es a+--   augmentOp2 = interpose_ $ \case+--     Op1 -> send Op1+--     Op2 -> liftIO (putStrLn "augmented op2") >> send Op2 -- :} ----- >>> runEff . runE . augmentE $ send Op--- augmented op--- op+-- >>> runEff . runE . augmentOp2 $ send Op1 >> send Op2+-- op1+-- augmented op2+-- op2 --+-- /Note:/ when using 'interpose' to modify only specific operations of the+-- effect, your first instinct might be to match on them, then handle the rest+-- with a generic match. Unfortunately, this doesn't work out of the box:+--+-- >>> :{+--   genericAugmentOp2 :: (E :> es, IOE :> es) => Eff es a -> Eff es a+--   genericAugmentOp2 = interpose_ $ \case+--     Op2 -> liftIO (putStrLn "augmented op2") >> send Op2+--     op  -> send op+-- :}+-- ...+-- ...Couldn't match type ‘localEs’ with ‘es’+-- ...+--+-- This is because within the generic match, 'send' expects @Op (Eff es) a@, but+-- @op@ has a type @Op (Eff localEs) a@. If the effect in question is first+-- order (i.e. its @m@ type parameter is phantom), you can use 'coerce':+--+-- >>> import Data.Coerce+-- >>> :{+--   genericAugmentOp2 :: (E :> es, IOE :> es) => Eff es a -> Eff es a+--   genericAugmentOp2 = interpose_ $ \case+--     Op2 -> liftIO (putStrLn "augmented op2") >> send Op2+--     op  -> send @E (coerce op)+-- :}+--+-- >>> runEff . runE . genericAugmentOp2 $ send Op1 >> send Op2+-- op1+-- augmented op2+-- op2+--+-- On the other hand, when dealing with higher order effects you need to pattern+-- match on each operation and unlift where necessary.+-- interpose-  :: forall e es a. (DispatchOf e ~ Dynamic, e :> es)+  :: forall e es a. (HasCallStack, DispatchOf e ~ Dynamic, e :> es)   => EffectHandler e es   -- ^ The effect handler.   -> Eff es a@@ -489,12 +568,23 @@   where     mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler) +-- | 'interpose' with the effect handler as the last argument.+--+-- @since 2.4.0.0+interposeWith+  :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+  => Eff es a+  -> EffectHandler e es+  -- ^ The effect handler.+  -> Eff es a+interposeWith m handler = interpose handler m+ -- | Replace the handler of an existing effect with a new one that uses other, -- private effects. -- -- @'interpose' ≡ 'impose' 'id'@ impose-  :: forall e es handlerEs a b. (DispatchOf e ~ Dynamic, e :> es)+  :: forall e es handlerEs a b. (HasCallStack, DispatchOf e ~ Dynamic, e :> es)   => (Eff handlerEs a -> Eff es b)   -- ^ Introduction of effects encapsulated within the handler.   -> EffectHandler e handlerEs@@ -523,7 +613,128 @@   where     mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler) +-- | 'impose' with the effect handler as the last argument.+--+-- @since 2.4.0.0+imposeWith+  :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+  => (Eff handlerEs a -> Eff es b)+  -- ^ Introduction of effects encapsulated within the handler.+  -> Eff es a+  -> EffectHandler e handlerEs+  -- ^ The effect handler.+  -> Eff es b+imposeWith runHandlerEs m handler = impose runHandlerEs handler m+ ----------------------------------------+-- First order effects++-- | Type signature of a first order effect handler.+--+-- @since 2.4.0.0+type EffectHandler_ (e :: Effect) (es :: [Effect])+  = forall a localEs. HasCallStack+  => e (Eff localEs) a+  -- ^ The operation.+  -> Eff es a++-- | 'interpret' for first order effects.+--+-- @since 2.4.0.0+interpret_+  :: (HasCallStack, DispatchOf e ~ Dynamic)+  => EffectHandler_ e es+  -- ^ The effect handler.+  -> Eff (e : es) a+  -> Eff      es  a+interpret_ handler = interpret (const handler)++-- | 'interpretWith' for first order effects.+--+-- @since 2.4.0.0+interpretWith_+  :: (HasCallStack, DispatchOf e ~ Dynamic)+  => Eff (e : es) a+  -> EffectHandler_ e es+  -- ^ The effect handler.+  -> Eff      es  a+interpretWith_ m handler = interpret (const handler) m++-- | 'reinterpret' for first order effects.+--+-- @since 2.4.0.0+reinterpret_+  :: (HasCallStack, DispatchOf e ~ Dynamic)+  => (Eff handlerEs a -> Eff es b)+  -- ^ Introduction of effects encapsulated within the handler.+  -> EffectHandler_ e handlerEs+  -- ^ The effect handler.+  -> Eff (e : es) a+  -> Eff      es  b+reinterpret_ runHandlerEs handler = reinterpret runHandlerEs (const handler)++-- | 'reinterpretWith' for first order effects.+--+-- @since 2.4.0.0+reinterpretWith_+  :: (HasCallStack, DispatchOf e ~ Dynamic)+  => (Eff handlerEs a -> Eff es b)+  -- ^ Introduction of effects encapsulated within the handler.+  -> Eff (e : es) a+  -> EffectHandler_ e handlerEs+  -- ^ The effect handler.+  -> Eff      es  b+reinterpretWith_ runHandlerEs m handler = reinterpret runHandlerEs (const handler) m++-- | 'interpose' for first order effects.+--+-- @since 2.4.0.0+interpose_+  :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+  => EffectHandler_ e es+  -- ^ The effect handler.+  -> Eff es a+  -> Eff es a+interpose_ handler = interpose (const handler)++-- | 'interposeWith' for first order effects.+--+-- @since 2.4.0.0+interposeWith_+  :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+  => Eff es a+  -> EffectHandler_ e es+  -- ^ The effect handler.+  -> Eff es a+interposeWith_ m handler = interpose (const handler) m++-- | 'impose' for first order effects.+--+-- @since 2.4.0.0+impose_+  :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+  => (Eff handlerEs a -> Eff es b)+  -- ^ Introduction of effects encapsulated within the handler.+  -> EffectHandler_ e handlerEs+  -- ^ The effect handler.+  -> Eff es a+  -> Eff es b+impose_ runHandlerEs handler = impose runHandlerEs (const handler)++-- | 'imposeWith' for first order effects.+--+-- @since 2.4.0.0+imposeWith_+  :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+  => (Eff handlerEs a -> Eff es b)+  -- ^ Introduction of effects encapsulated within the handler.+  -> Eff es a+  -> EffectHandler_ e handlerEs+  -- ^ The effect handler.+  -> Eff es b+imposeWith_ runHandlerEs m handler = impose runHandlerEs (const handler) m++---------------------------------------- -- Unlifts  -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the@@ -536,8 +747,10 @@   -- ^ Continuation with the unlifting function in scope.   -> Eff es a localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do+  requireMatchingStorages es les   seqUnliftIO les $ \unlift -> do     (`unEff` es) $ k $ unsafeEff_ . unlift+{-# INLINE localSeqUnlift #-}  -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the -- general version see 'localUnliftIO'.@@ -548,7 +761,10 @@   -> ((forall r. Eff localEs r -> IO r) -> IO a)   -- ^ Continuation with the unlifting function in scope.   -> Eff es a-localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftIO les k+localSeqUnliftIO (LocalEnv les) k = unsafeEff $ \es -> do+  requireMatchingStorages es les+  seqUnliftIO les k+{-# INLINE localSeqUnliftIO #-}  -- | Create a local unlifting function with the given strategy. localUnlift@@ -559,13 +775,15 @@   -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)   -- ^ Continuation with the unlifting function in scope.   -> Eff es a-localUnlift (LocalEnv les) strategy k = case strategy of-  SeqUnlift -> unsafeEff $ \es -> do-    seqUnliftIO les $ \unlift -> do+localUnlift (LocalEnv les) strategy k = unsafeEff $ \es -> do+  requireMatchingStorages es les+  case strategy of+    SeqUnlift -> seqUnliftIO les $ \unlift -> do       (`unEff` es) $ k $ unsafeEff_ . unlift-  ConcUnlift p l -> unsafeEff $ \es -> do-    concUnliftIO les p l $ \unlift -> do+    SeqForkUnlift -> seqForkUnliftIO les $ \unlift -> do       (`unEff` es) $ k $ unsafeEff_ . unlift+    ConcUnlift p l -> concUnliftIO les p l $ \unlift -> do+      (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localUnlift #-}  -- | Create a local unlifting function with the given strategy.@@ -577,9 +795,12 @@   -> ((forall r. Eff localEs r -> IO r) -> IO a)   -- ^ Continuation with the unlifting function in scope.   -> Eff es a-localUnliftIO (LocalEnv les) strategy k = case strategy of-  SeqUnlift      -> liftIO $ seqUnliftIO les k-  ConcUnlift p l -> liftIO $ concUnliftIO les p l k+localUnliftIO (LocalEnv les) strategy k = unsafeEff $ \es -> do+  requireMatchingStorages es les+  case strategy of+    SeqUnlift -> seqUnliftIO les k+    SeqForkUnlift -> seqForkUnliftIO les k+    ConcUnlift p l -> concUnliftIO les p l k {-# INLINE localUnliftIO #-}  ----------------------------------------@@ -596,11 +817,11 @@   -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a)   -- ^ Continuation with the lifting function in scope.   -> Eff es a-localSeqLift !_ k = unsafeEff $ \es -> do-  -- The LocalEnv parameter is not used, but we need it to constraint the-  -- localEs type variable. It's also strict so that callers don't cheat.+localSeqLift (LocalEnv les) k = unsafeEff $ \es -> do+  requireMatchingStorages es les   seqUnliftIO es $ \unlift -> do     (`unEff` es) $ k $ unsafeEff_ . unlift+{-# INLINE localSeqLift #-}  -- | Create a local lifting function with the given strategy. --@@ -613,15 +834,15 @@   -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a)   -- ^ Continuation with the lifting function in scope.   -> Eff es a-localLift !_ strategy k = case strategy of-  -- The LocalEnv parameter is not used, but we need it to constraint the-  -- localEs type variable. It's also strict so that callers don't cheat.-  SeqUnlift -> unsafeEff $ \es -> do-    seqUnliftIO es $ \unlift -> do+localLift (LocalEnv les) strategy k = unsafeEff $ \es -> do+  requireMatchingStorages es les+  case strategy of+    SeqUnlift -> seqUnliftIO es $ \unlift -> do       (`unEff` es) $ k $ unsafeEff_ . unlift-  ConcUnlift p l -> unsafeEff $ \es -> do-    concUnliftIO es p l $ \unlift -> do+    SeqForkUnlift -> seqForkUnliftIO es $ \unlift -> do       (`unEff` es) $ k $ unsafeEff_ . unlift+    ConcUnlift p l -> concUnliftIO es p l $ \unlift -> do+      (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localLift #-}  -- | Utility for lifting 'Eff' computations of type@@ -641,12 +862,12 @@   -> ((forall a b. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)   -- ^ Continuation with the lifting function in scope.   -> Eff es r-withLiftMap !_ k = unsafeEff $ \es -> do-  -- The LocalEnv parameter is not used, but we need it to constraint the-  -- localEs type variable. It's also strict so that callers don't cheat.+withLiftMap (LocalEnv les) k = unsafeEff $ \es -> do+  requireMatchingStorages es les   (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do     seqUnliftIO localEs $ \unlift -> do       (`unEff` es) . mapEff . unsafeEff_ $ unlift m+{-# INLINE withLiftMap #-}  -- | Utility for lifting 'IO' computations of type --@@ -681,10 +902,11 @@   -> ((forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)   -- ^ Continuation with the lifting function in scope.   -> Eff es r-withLiftMapIO !_ k = k $ \mapIO m -> unsafeEff $ \es -> do-  -- The LocalEnv parameter is not used, but we need it to constraint the-  -- localEs type variable. It's also strict so that callers don't cheat.-  seqUnliftIO es $ \unlift -> mapIO $ unlift m+withLiftMapIO (LocalEnv les) k = unsafeEff $ \es -> do+  requireMatchingStorages es les+  (`unEff` es) $ k $ \mapIO m -> unsafeEff $ \localEs -> do+    seqUnliftIO localEs $ \unlift -> mapIO $ unlift m+{-# INLINE withLiftMapIO #-}  ---------------------------------------- -- Bidirectional lifts@@ -704,13 +926,16 @@   -> ((forall r. Eff es r -> Eff localEs r) -> (forall r. Eff localEs r -> Eff es r) -> Eff es a)   -- ^ Continuation with the lifting and unlifting function in scope.   -> Eff es a-localLiftUnlift (LocalEnv les) strategy k = case strategy of-  SeqUnlift -> unsafeEff $ \es -> do-    seqUnliftIO es $ \unliftEs -> do+localLiftUnlift (LocalEnv les) strategy k = unsafeEff $ \es -> do+  requireMatchingStorages es les+  case strategy of+    SeqUnlift -> seqUnliftIO es $ \unliftEs -> do       seqUnliftIO les $ \unliftLocalEs -> do         (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)-  ConcUnlift p l -> unsafeEff $ \es -> do-    concUnliftIO es p l $ \unliftEs -> do+    SeqForkUnlift -> seqForkUnliftIO es $ \unliftEs -> do+      seqForkUnliftIO les $ \unliftLocalEs -> do+        (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)+    ConcUnlift p l -> concUnliftIO es p l $ \unliftEs -> do       concUnliftIO les p l $ \unliftLocalEs -> do         (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) {-# INLINE localLiftUnlift #-}@@ -731,15 +956,18 @@   -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a)   -- ^ Continuation with the lifting and unlifting function in scope.   -> Eff es a-localLiftUnliftIO (LocalEnv les) strategy k = case strategy of-  SeqUnlift      -> liftIO $ seqUnliftIO les $ k unsafeEff_-  ConcUnlift p l -> liftIO $ concUnliftIO les p l $ k unsafeEff_+localLiftUnliftIO (LocalEnv les) strategy k = unsafeEff $ \es -> do+  requireMatchingStorages es les+  case strategy of+    SeqUnlift      -> seqUnliftIO les $ k unsafeEff_+    SeqForkUnlift  -> seqForkUnliftIO les $ k unsafeEff_+    ConcUnlift p l -> concUnliftIO les p l $ k unsafeEff_ {-# INLINE localLiftUnliftIO #-}  ---------------------------------------- -- Misc --- | Lend an effect to the local environment.+-- | Lend effects to the local environment. -- -- Consider the following effect: --@@ -777,93 +1005,119 @@ --   runD :: IOE :> es => Eff (D : es) a -> Eff es a --   runD = interpret $ \env -> \case --     D -> localSeqUnlift env $ \unlift -> do---       localSeqLend @IOE env $ \useIOE -> do+--       localSeqLend @'[IOE] env $ \useIOE -> do --         unlift . useIOE . runE $ pure () -- :} ----- @since 2.3.1.0+-- @since 2.4.0.0 localSeqLend-  :: (e :> es, SharedSuffix es handlerEs)+  :: forall lentEs es handlerEs localEs a+   . (HasCallStack, KnownSubset lentEs es, SharedSuffix es handlerEs)   => LocalEnv localEs handlerEs-  -> ((forall r. Eff (e : localEs) r -> Eff localEs r) -> Eff es a)+  -> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a)   -- ^ Continuation with the lent handler in scope.   -> Eff es a localSeqLend (LocalEnv les) k = unsafeEff $ \es -> do-  eles <- copyRef es les+  eles <- copyRefs @lentEs es les   seqUnliftIO eles $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift+{-# INLINE localSeqLend #-} --- | Lend an effect to the local environment with a given unlifting strategy.+-- | Lend effects to the local environment with a given unlifting strategy. -- -- Generalizes 'localSeqLend'. ----- @since 2.3.1.0+-- @since 2.4.0.0 localLend-  :: (e :> es, SharedSuffix es handlerEs)+  :: forall lentEs es handlerEs localEs a+   . (HasCallStack, KnownSubset lentEs es, SharedSuffix es handlerEs)   => LocalEnv localEs handlerEs   -> UnliftStrategy-  -> ((forall r. Eff (e : localEs) r -> Eff localEs r) -> Eff es a)+  -> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a)   -- ^ Continuation with the lent handler in scope.   -> Eff es a-localLend (LocalEnv les) strategy k = case strategy of-  SeqUnlift -> unsafeEff $ \es -> do-    eles <- copyRef es les-    seqUnliftIO eles $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift-  ConcUnlift p l -> unsafeEff $ \es -> do-    eles <- copyRef es les-    concUnliftIO eles p l $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift+localLend (LocalEnv les) strategy k = unsafeEff $ \es -> do+  eles <- copyRefs @lentEs es les+  case strategy of+    SeqUnlift -> seqUnliftIO eles $ \unlift -> do+      (`unEff` es) $ k $ unsafeEff_ . unlift+    SeqForkUnlift -> seqForkUnliftIO eles $ \unlift -> do+      (`unEff` es) $ k $ unsafeEff_ . unlift+    ConcUnlift p l -> concUnliftIO eles p l $ \unlift -> do+      (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localLend #-} --- | Borrow an effect from the local environment.+-- | Borrow effects from the local environment. ----- @since 2.3.1.0+-- @since 2.4.0.0 localSeqBorrow-  :: (e :> localEs, SharedSuffix es handlerEs)+  :: forall borrowedEs es handlerEs localEs a+   . (HasCallStack, KnownSubset borrowedEs localEs, SharedSuffix es handlerEs)   => LocalEnv localEs handlerEs-  -> ((forall r. Eff (e : es) r -> Eff es r) -> Eff es a)+  -> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a)   -- ^ Continuation with the borrowed handler in scope.   -> Eff es a localSeqBorrow (LocalEnv les) k = unsafeEff $ \es -> do-  ees <- copyRef les es+  ees <- copyRefs @borrowedEs les es   seqUnliftIO ees $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift+{-# INLINE localSeqBorrow #-} --- | Borrow an effect from the local environment with a given unlifting+-- | Borrow effects from the local environment with a given unlifting -- strategy. -- -- Generalizes 'localSeqBorrow'. ----- @since 2.3.1.0+-- @since 2.4.0.0 localBorrow-  :: (e :> localEs, SharedSuffix es handlerEs)+  :: forall borrowedEs es handlerEs localEs a+   . (HasCallStack, KnownSubset borrowedEs localEs, SharedSuffix es handlerEs)   => LocalEnv localEs handlerEs   -> UnliftStrategy-  -> ((forall r. Eff (e : es) r -> Eff es r) -> Eff es a)+  -> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a)   -- ^ Continuation with the borrowed handler in scope.   -> Eff es a-localBorrow (LocalEnv les) strategy k = case strategy of-  SeqUnlift -> unsafeEff $ \es -> do-    ees <- copyRef les es-    seqUnliftIO ees $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift-  ConcUnlift p l -> unsafeEff $ \es -> do-    ees <- copyRef les es-    concUnliftIO ees p l $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift+localBorrow (LocalEnv les) strategy k = unsafeEff $ \es -> do+  ees <- copyRefs @borrowedEs les es+  case strategy of+    SeqUnlift -> seqUnliftIO ees $ \unlift -> do+      (`unEff` es) $ k $ unsafeEff_ . unlift+    SeqForkUnlift -> seqForkUnliftIO ees $ \unlift -> do+      (`unEff` es) $ k $ unsafeEff_ . unlift+    ConcUnlift p l -> concUnliftIO ees p l $ \unlift -> do+      (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localBorrow #-} -copyRef-  :: forall e srcEs destEs. e :> srcEs+copyRefs+  :: forall es srcEs destEs+   . (HasCallStack, KnownSubset es srcEs)   => Env srcEs   -> Env destEs-  -> IO (Env (e : destEs))-copyRef (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do-  when (hstorage /= storage) $ do-    error "storages do not match"-  let size = sizeofPrimArray refs0 - offset-      i = 2 * reifyIndex @e @srcEs-  mrefs <- newPrimArray (size + 2)-  copyPrimArray mrefs 0 hrefs (hoffset + i) 2-  copyPrimArray mrefs 2 refs0 offset size+  -> IO (Env (es ++ destEs))+copyRefs src@(Env soffset srefs _) dest@(Env doffset drefs storage) = do+  requireMatchingStorages src dest+  let es = reifyIndices @es @srcEs+      esSize = length es+      destSize = sizeofPrimArray drefs - doffset+  mrefs <- newPrimArray (esSize + destSize)+  copyPrimArray mrefs esSize drefs doffset destSize+  let writeRefs i = \case+        [] -> pure ()+        (x : xs) -> do+          writePrimArray mrefs i $ indexPrimArray srefs (soffset + x)+          writeRefs (i + 1) xs+  writeRefs 0 es   refs <- unsafeFreezePrimArray mrefs   pure $ Env 0 refs storage+{-# NOINLINE copyRefs #-} +requireMatchingStorages :: HasCallStack => Env es1 -> Env es2 -> IO ()+requireMatchingStorages es1 es2+  | envStorage es1 /= envStorage es2 = error+    $ "Env and LocalEnv point to different Storages.\n"+    ++ "If you passed LocalEnv to a different thread and tried to create an "+    ++ "unlifting function there, it's not allowed. You need to create it in "+    ++ "the thread of the effect handler."+  | otherwise = pure ()+ -- | Require that both effect stacks share an opaque suffix. -- -- Functions from the 'localUnlift' family utilize this constraint to guarantee@@ -937,4 +1191,5 @@  -- $setup -- >>> import Control.Concurrent (ThreadId, forkIOWithUnmask)+-- >>> import Control.Monad.IO.Class -- >>> import Effectful.Reader.Static

@@ -14,7 +14,9 @@   , runErrorNoCallStackWith      -- ** Operations+  , throwErrorWith   , throwError+  , throwError_   , catchError   , handleError   , tryError@@ -34,17 +36,19 @@  -- | Provide the ability to handle errors of type @e@. data Error e :: Effect where-  ThrowError :: e -> Error e m a+  -- | @since 2.4.0.0+  ThrowErrorWith :: (e -> String) -> e -> Error e m a   CatchError :: m a -> (E.CallStack -> e -> m a) -> Error e m a  type instance DispatchOf (Error e) = Dynamic  -- | Handle errors of type @e@ (via "Effectful.Error.Static"). runError-  :: Eff (Error e : es) a+  :: HasCallStack+  => Eff (Error e : es) a   -> Eff es (Either (E.CallStack, e) a) runError = reinterpret E.runError $ \env -> \case-  ThrowError e   -> E.throwError e+  ThrowErrorWith display e -> E.throwErrorWith display e   CatchError m h -> localSeqUnlift env $ \unlift -> do     E.catchError (unlift m) (\cs -> unlift . h cs) @@ -53,7 +57,8 @@ -- -- @since 2.3.0.0 runErrorWith-  :: (E.CallStack -> e -> Eff es a)+  :: HasCallStack+  => (E.CallStack -> e -> Eff es a)   -- ^ The error handler.   -> Eff (Error e : es) a   -> Eff es a@@ -66,14 +71,16 @@ -- -- @since 2.3.0.0 runErrorNoCallStack-  :: Eff (Error e : es) a+  :: HasCallStack+  => Eff (Error e : es) a   -> Eff es (Either e a) runErrorNoCallStack = fmap (either (Left . snd) Right) . runError  -- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific -- error handler. In case of an error discard the 'CallStack'. runErrorNoCallStackWith-  :: (e -> Eff es a)+  :: HasCallStack+  => (e -> Eff es a)   -- ^ The error handler.   -> Eff (Error e : es) a   -> Eff es a@@ -81,13 +88,36 @@   Left e -> handler e   Right a -> pure a --- | Throw an error of type @e@.+-- | Throw an error of type @e@ and specify a display function in case a+-- third-party code catches the internal exception and 'show's it.+--+-- @since 2.4.0.0+throwErrorWith+  :: (HasCallStack, Error e :> es)+  => (e -> String)+  -- ^ The display function.+  -> e+  -- ^ The error.+  -> Eff es a+throwErrorWith display = withFrozenCallStack send . ThrowErrorWith display++-- | Throw an error of type @e@ with 'show' as a display function. throwError+  :: (HasCallStack, Error e :> es, Show e)+  => e+  -- ^ The error.+  -> Eff es a+throwError = withFrozenCallStack throwErrorWith show++-- | Throw an error of type @e@ with no display function.+--+-- @since 2.4.0.0+throwError_   :: (HasCallStack, Error e :> es)   => e   -- ^ The error.   -> Eff es a-throwError e = withFrozenCallStack $ send (ThrowError e)+throwError_ = withFrozenCallStack throwErrorWith (const "<opaque>")  -- | Handle an error of type @e@. catchError@@ -102,7 +132,7 @@ -- | The same as @'flip' 'catchError'@, which is useful in situations where the -- code for the handler is shorter. handleError-  :: Error e :> es+  :: (HasCallStack, Error e :> es)   => (E.CallStack -> e -> Eff es a)   -- ^ A handler for errors in the inner computation.   -> Eff es a

@@ -1,13 +1,13 @@ -- | Support for handling errors of a particular type, i.e. checked exceptions. -- -- The 'Error' effect is __not__ a general mechanism for handling regular--- exceptions, that's what functions from the @exceptions@ library are for (see--- "Control.Monad.Catch" for more information).+-- exceptions, that's what functions from the "Effectful.Exception" module are+-- for. -- -- In particular, regular exceptions of type @e@ are distinct from errors of -- type @e@ and will __not__ be caught by functions from this module: ----- >>> import qualified Control.Monad.Catch as E+-- >>> import Effectful.Exception qualified as E -- -- >>> boom = error "BOOM!" --@@ -16,14 +16,14 @@ -- ... -- -- If you want to catch regular exceptions, you should use--- 'Control.Monad.Catch.catch' (or a similar function):+-- 'Effectful.Exception.catch' (or a similar function): -- -- >>> runEff $ boom `E.catch` \(_::ErrorCall) -> pure "caught" -- "caught" -- -- On the other hand, functions for safe finalization and management of--- resources such as 'Control.Monad.Catch.finally' and--- 'Control.Monad.Catch.bracket' work as expected:+-- resources such as 'Effectful.Exception.finally' and+-- 'Effectful.Exception.bracket' work as expected: -- -- >>> msg = liftIO . putStrLn --@@ -43,8 +43,8 @@ -- effect with regard to other stateful effects does not matter. Consider the -- following: ----- >>> import qualified Control.Monad.State.Strict as T--- >>> import qualified Control.Monad.Except as T+-- >>> import Control.Monad.State.Strict qualified as T+-- >>> import Control.Monad.Except qualified as T -- -- >>> m1 = (T.modify (++ " there!") >> T.throwError "oops") `T.catchError` \_ -> pure () --@@ -74,7 +74,7 @@ -- -- /Hint:/ if you'd like to reproduce the transactional behavior with the -- t'Effectful.State.Static.Local.State' effect, appropriate usage of--- 'Control.Monad.Catch.bracketOnError' will do the trick.+-- 'Effectful.Exception.bracketOnError' will do the trick. module Effectful.Error.Static   ( -- * Effect     Error@@ -86,7 +86,9 @@   , runErrorNoCallStackWith      -- ** Operations+  , throwErrorWith   , throwError+  , throwError_   , catchError   , handleError   , tryError@@ -99,6 +101,7 @@   ) where  import Control.Exception+import Data.Kind import GHC.Stack  import Effectful@@ -107,7 +110,7 @@ import Effectful.Internal.Utils  -- | Provide the ability to handle errors of type @e@.-data Error e :: Effect+data Error (e :: Type) :: Effect  type instance DispatchOf (Error e) = Static NoSideEffects newtype instance StaticRep (Error e) = Error ErrorId@@ -115,7 +118,8 @@ -- | Handle errors of type @e@. runError   :: forall e es a-  .  Eff (Error e : es) a+   . HasCallStack+  => Eff (Error e : es) a   -> Eff es (Either (CallStack, e) a) runError m = unsafeEff $ \es0 -> mask $ \unmask -> do   eid <- newErrorId@@ -133,7 +137,8 @@ -- -- @since 2.3.0.0 runErrorWith-  :: (CallStack -> e -> Eff es a)+  :: HasCallStack+  => (CallStack -> e -> Eff es a)   -- ^ The error handler.   -> Eff (Error e : es) a   -> Eff es a@@ -146,14 +151,16 @@ -- @since 2.3.0.0 runErrorNoCallStack   :: forall e es a-  .  Eff (Error e : es) a+   . HasCallStack+  => Eff (Error e : es) a   -> Eff es (Either e a) runErrorNoCallStack = fmap (either (Left . snd) Right) . runError  -- | Handle errors of type @e@ with a specific error handler. In case of an -- error discard the 'CallStack'. runErrorNoCallStackWith-  :: (e -> Eff es a)+  :: HasCallStack+  => (e -> Eff es a)   -- ^ The error handler.   -> Eff (Error e : es) a   -> Eff es a@@ -161,19 +168,42 @@   Left e -> handler e   Right a -> pure a --- | Throw an error of type @e@.+-- | Throw an error of type @e@ and specify a display function in case a+-- third-party code catches the internal exception and 'show's it.+--+-- @since 2.4.0.0+throwErrorWith+  :: forall e es a. (HasCallStack, Error e :> es)+  => (e -> String)+  -- ^ The display function.+  -> e+  -- ^ The error.+  -> Eff es a+throwErrorWith display e = unsafeEff $ \es -> do+  Error eid <- getEnv @(Error e) es+  throwIO $ ErrorWrapper eid callStack (display e) (toAny e)++-- | Throw an error of type @e@ with 'show' as a display function. throwError+  :: forall e es a. (HasCallStack, Error e :> es, Show e)+  => e+  -- ^ The error.+  -> Eff es a+throwError = withFrozenCallStack throwErrorWith show++-- | Throw an error of type @e@ with no display function.+--+-- @since 2.4.0.0+throwError_   :: forall e es a. (HasCallStack, Error e :> es)   => e   -- ^ The error.   -> Eff es a-throwError e = unsafeEff $ \es -> do-  Error eid <- getEnv @(Error e) es-  throwIO $ ErrorWrapper eid callStack (toAny e)+throwError_ = withFrozenCallStack throwErrorWith (const "<opaque>")  -- | Handle an error of type @e@. catchError-  :: forall e es a. Error e :> es+  :: forall e es a. (HasCallStack, Error e :> es)   => Eff es a   -- ^ The inner computation.   -> (CallStack -> e -> Eff es a)@@ -187,7 +217,7 @@ -- | The same as @'flip' 'catchError'@, which is useful in situations where the -- code for the handler is shorter. handleError-  :: forall e es a. Error e :> es+  :: forall e es a. (HasCallStack, Error e :> es)   => (CallStack -> e -> Eff es a)   -- ^ A handler for errors in the inner computation.   -> Eff es a@@ -198,7 +228,7 @@ -- | Similar to 'catchError', but returns an 'Either' result which is a 'Right' -- if no error was thrown and a 'Left' otherwise. tryError-  :: forall e es a. Error e :> es+  :: forall e es a. (HasCallStack, Error e :> es)   => Eff es a   -- ^ The inner computation.   -> Eff es (Either (CallStack, e) a)@@ -208,7 +238,7 @@ -- Helpers  newtype ErrorId = ErrorId Unique-  deriving Eq+  deriving newtype Eq  -- | A unique is picked so that distinct 'Error' handlers for the same type -- don't catch each other's exceptions.@@ -222,21 +252,25 @@   -> IO r   -> IO r tryHandler ex eid0 handler next = case fromException ex of-  Just (ErrorWrapper eid cs e)+  Just (ErrorWrapper eid cs _ e)     | eid0 == eid -> pure $ handler cs (fromAny e)     | otherwise   -> next   Nothing -> next -data ErrorWrapper = ErrorWrapper !ErrorId CallStack Any+data ErrorWrapper = ErrorWrapper !ErrorId CallStack String Any+ instance Show ErrorWrapper where-  showsPrec p (ErrorWrapper _ cs _)-    = ("Effectful.Error.Static.ErrorWrapper\n\n" ++)-    . showsPrec p (prettyCallStack cs)+  showsPrec _ (ErrorWrapper _ cs errRep _)+    = ("Effectful.Error.Static.ErrorWrapper: " ++)+    . (errRep ++)+    . ("\n" ++)+    . (prettyCallStack cs ++)+ instance Exception ErrorWrapper  catchErrorIO :: ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a catchErrorIO eid m handler = do-  m `catch` \err@(ErrorWrapper etag cs e) -> do+  m `catch` \err@(ErrorWrapper etag cs _ e) -> do     if eid == etag       then handler cs (fromAny e)       else throwIO err

@@ -0,0 +1,130 @@+-- | The 'Eff' monad comes with instances of 'MonadThrow', 'MonadCatch' and+-- 'MonadMask' from the+-- [@exceptions@](https://hackage.haskell.org/package/exceptions) library, so+-- this module simply re-exports the interface of the+-- [@safe-exceptions@](https://hackage.haskell.org/package/safe-exceptions)+-- library.+--+-- Why @safe-exceptions@ and not @exceptions@? Because the former makes it much+-- easier to correctly deal with asynchronous exceptions (for more information+-- see its [README](https://github.com/fpco/safe-exceptions#readme)) and+-- provides more convenience functions.+module Effectful.Exception+  ( -- * Throwing+    C.MonadThrow(..)+  , Safe.throwString+  , Safe.StringException(..)++    -- * Catching (with recovery)+  , C.MonadCatch(..)+  , Safe.catchIO+  , Safe.catchIOError+  , Safe.catchAny+  , Safe.catchDeep+  , Safe.catchAnyDeep+  , Safe.catchAsync+  , Safe.catchJust++  , Safe.handle+  , Safe.handleIO+  , Safe.handleIOError+  , Safe.handleAny+  , Safe.handleDeep+  , Safe.handleAnyDeep+  , Safe.handleAsync+  , Safe.handleJust++  , Safe.try+  , Safe.tryIO+  , Safe.tryAny+  , Safe.tryDeep+  , Safe.tryAnyDeep+  , Safe.tryAsync+  , Safe.tryJust++  , Safe.Handler(..)+  , Safe.catches+  , Safe.catchesDeep+  , Safe.catchesAsync++    -- * Cleanup (no recovery)+  , C.MonadMask(..)+  , C.ExitCase(..)+  , Safe.onException+  , Safe.bracket+  , Safe.bracket_+  , Safe.finally+  , Safe.withException+  , Safe.bracketOnError+  , Safe.bracketOnError_+  , Safe.bracketWithError++    -- * Utilities++    -- ** Coercion to sync and async+  , Safe.SyncExceptionWrapper(..)+  , Safe.toSyncException+  , Safe.AsyncExceptionWrapper(..)+  , Safe.toAsyncException++    -- ** Check exception type+  , Safe.isSyncException+  , Safe.isAsyncException++    -- ** Evaluation+  , evaluate+  , evaluateDeep++    -- * Re-exports from "Control.Exception"++    -- ** The 'SomeException' type+  , E.SomeException(..)++    -- ** The 'Exception' class+  , E.Exception(..)++    -- ** Concrete exception types+  , E.IOException+  , E.ArithException(..)+  , E.ArrayException(..)+  , E.AssertionFailed(..)+  , E.NoMethodError(..)+  , E.PatternMatchFail(..)+  , E.RecConError(..)+  , E.RecSelError(..)+  , E.RecUpdError(..)+  , E.ErrorCall(..)+  , E.TypeError(..)++    -- ** Asynchronous exceptions+  , E.SomeAsyncException(..)+  , E.AsyncException(..)+  , E.asyncExceptionToException+  , E.asyncExceptionFromException+  , E.NonTermination(..)+  , E.NestedAtomically(..)+  , E.BlockedIndefinitelyOnMVar(..)+  , E.BlockedIndefinitelyOnSTM(..)+  , E.AllocationLimitExceeded(..)+  , E.CompactionFailed(..)+  , E.Deadlock(..)++    -- ** Assertions+  , E.assert+  ) where++import Control.DeepSeq+import Control.Exception qualified as E+import Control.Exception.Safe qualified as Safe+import Control.Monad.Catch qualified as C++import Effectful+import Effectful.Dispatch.Static++-- | Lifted version of 'E.evaluate'.+evaluate :: a -> Eff es a+evaluate = unsafeEff_ . E.evaluate++-- | Deeply evaluate a value using 'evaluate' and 'NFData'.+evaluateDeep :: NFData a => a -> Eff es a+evaluateDeep = unsafeEff_ . E.evaluate . force

@@ -14,11 +14,11 @@ import Effectful.Internal.Monad (Fail(..))  -- | Run the 'Fail' effect via 'Error'.-runFail :: Eff (Fail : es) a -> Eff es (Either String a)-runFail = reinterpret runErrorNoCallStack $ \_ -> \case+runFail :: HasCallStack => Eff (Fail : es) a -> Eff es (Either String a)+runFail = reinterpret_ runErrorNoCallStack $ \case   Fail msg -> throwError msg  -- | Run the 'Fail' effect via the 'MonadFail' instance for 'IO'.-runFailIO :: IOE :> es => Eff (Fail : es) a -> Eff es a-runFailIO = interpret $ \_ -> \case+runFailIO :: (HasCallStack, IOE :> es) => Eff (Fail : es) a -> Eff es a+runFailIO = interpret_ $ \case   Fail msg -> liftIO $ fail msg

@@ -10,6 +10,7 @@   , (:>)(..)   , (:>>)   , Subset(..)+  , KnownSubset   , KnownPrefix(..)   , IsUnknownSuffixOf   , type (++)@@ -70,8 +71,8 @@  ---------------------------------------- --- | Provide evidence that @xs@ is a subset of @es@.-class KnownPrefix es => Subset (xs :: [Effect]) (es :: [Effect]) where+-- | Provide evidence that @subEs@ is a subset of @es@.+class KnownPrefix es => Subset (subEs :: [Effect]) (es :: [Effect]) where   subsetFullyKnown :: Bool   subsetFullyKnown =     -- Don't show "minimal complete definition" in haddock.@@ -86,8 +87,8 @@ -- have the same unknown suffix. instance {-# INCOHERENT #-}   ( KnownPrefix es-  , xs `IsUnknownSuffixOf` es-  ) => Subset xs es where+  , subEs `IsUnknownSuffixOf` es+  ) => Subset subEs es where   subsetFullyKnown = False   reifyIndices = [] @@ -96,12 +97,19 @@   subsetFullyKnown = True   reifyIndices = [] -instance (e :> es, Subset xs es) => Subset (e : xs) es where-  subsetFullyKnown = subsetFullyKnown @xs @es-  reifyIndices = reifyIndex @e @es : reifyIndices @xs @es+instance (e :> es, Subset subEs es) => Subset (e : subEs) es where+  subsetFullyKnown = subsetFullyKnown @subEs @es+  reifyIndices = reifyIndex @e @es : reifyIndices @subEs @es  ---- +-- | Provide evidence that @subEs@ is a known subset of @es@.+class Subset subEs es => KnownSubset (subEs :: [Effect]) (es :: [Effect])+instance KnownSubset '[] es+instance (e :> es, KnownSubset subEs es) => KnownSubset (e : subEs) es++----+ -- | Calculate length of a statically known prefix of @es@. class KnownPrefix (es :: [Effect]) where   prefixLength :: Int@@ -114,10 +122,10 @@  ---- --- | Require that @xs@ is the unknown suffix of @es@.-class (xs :: [Effect]) `IsUnknownSuffixOf` (es :: [Effect])-instance {-# INCOHERENT #-} xs ~ es => xs `IsUnknownSuffixOf` es-instance xs `IsUnknownSuffixOf` es => xs `IsUnknownSuffixOf` (e : es)+-- | Require that @subEs@ is the unknown suffix of @es@.+class (subEs :: [Effect]) `IsUnknownSuffixOf` (es :: [Effect])+instance {-# INCOHERENT #-} subEs ~ es => subEs `IsUnknownSuffixOf` es+instance subEs `IsUnknownSuffixOf` es => subEs `IsUnknownSuffixOf` (e : es)  ---- 

@@ -1,10 +1,20 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} module Effectful.Internal.Env   ( -- * The environment     Env(..)+  , Ref(..)+  , Version   , Storage(..)+  , AnyEffect+  , toAnyEffect+  , fromAnyEffect+  , AnyRelinker+  , toAnyRelinker+  , fromAnyRelinker      -- ** Relinker   , Relinker(..)@@ -40,9 +50,12 @@  import Control.Monad import Control.Monad.Primitive+import Data.IORef.Strict import Data.Primitive.PrimArray import Data.Primitive.SmallArray-import GHC.Stack (HasCallStack)+import Data.Primitive.Types+import GHC.Exts ((*#), (+#))+import GHC.Stack  import Effectful.Internal.Effect import Effectful.Internal.Utils@@ -74,19 +87,78 @@ -- data Env (es :: [Effect]) = Env   { envOffset  :: !Int-  , envRefs    :: !(PrimArray Int)+  , envRefs    :: !(PrimArray Ref)   , envStorage :: !(IORef' Storage)   } +-- | Reference to the effect in 'Storage'.+data Ref = Ref !Int !Version++instance Prim Ref where+  sizeOf# _ = 2# *# sizeOf# (undefined :: Int)+  alignment# _ = alignment# (undefined :: Int)+  indexByteArray# arr i =+    let n = 2# *# i+        ref = indexByteArray# arr n+        version = indexByteArray# arr (n +# 1#)+    in Ref ref version+  readByteArray# arr i s0 =+    let n = 2# *# i+        !(# s1, ref #) = readByteArray# arr n s0+        !(# s2, version #) = readByteArray# arr (n +# 1#) s1+    in (# s2, Ref ref version #)+  writeByteArray# arr i (Ref ref version) s0 =+    let n = 2# *# i+        s1 = writeByteArray# arr n ref s0+        s2 = writeByteArray# arr (n +# 1#) version s1+    in s2+  indexOffAddr# addr i =+    let n = 2# *# i+        ref = indexOffAddr# addr n+        version = indexOffAddr# addr (n +# 1#)+    in Ref ref version+  readOffAddr# addr i s0 =+    let n = 2# *# i+        !(# s1, ref #) = readOffAddr# addr n s0+        !(# s2, version #) = readOffAddr# addr (n +# 1#) s1+    in (# s2, Ref ref version #)+  writeOffAddr# addr i (Ref ref version) s0 =+    let n = 2# *# i+        s1 = writeOffAddr# addr n ref s0+        s2 = writeOffAddr# addr (n +# 1#) version s1+    in s2++-- | Version of the effect.+newtype Version = Version Int+  deriving newtype (Eq, Ord, Prim, Show)+ -- | A storage of effects. data Storage = Storage   { stSize      :: !Int-  , stVersion   :: !Int-  , stVersions  :: !(MutablePrimArray RealWorld Int)-  , stEffects   :: !(SmallMutableArray RealWorld Any)-  , stRelinkers :: !(SmallMutableArray RealWorld Any)+  , stVersion   :: !Version+  , stVersions  :: !(MutablePrimArray RealWorld Version)+  , stEffects   :: !(SmallMutableArray RealWorld AnyEffect)+  , stRelinkers :: !(SmallMutableArray RealWorld AnyRelinker)   } +-- | Effect in 'Storage'.+newtype AnyEffect = AnyEffect Any++toAnyEffect :: EffectRep (DispatchOf e) e -> AnyEffect+toAnyEffect = AnyEffect . toAny++fromAnyEffect :: AnyEffect -> EffectRep (DispatchOf e) e+fromAnyEffect (AnyEffect e) = fromAny e++-- | Relinker in 'Storage'.+newtype AnyRelinker = AnyRelinker Any++toAnyRelinker :: Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker+toAnyRelinker = AnyRelinker . toAny++fromAnyRelinker :: AnyRelinker -> Relinker (EffectRep (DispatchOf e)) e+fromAnyRelinker (AnyRelinker f) = fromAny f+ ---------------------------------------- -- Relinker @@ -94,7 +166,7 @@ -- a deep copy of the representation of the effect when cloning the environment. newtype Relinker :: (Effect -> Type) -> Effect -> Type where   Relinker-    :: ((forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e))+    :: (HasCallStack => (forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e))     -> Relinker rep e  -- | A dummy 'Relinker'.@@ -125,13 +197,13 @@ -- Operations  -- | Create an empty environment.-emptyEnv :: IO (Env '[])+emptyEnv :: HasCallStack => IO (Env '[]) emptyEnv = Env 0   <$> (unsafeFreezePrimArray =<< newPrimArray 0)   <*> (newIORef' =<< emptyStorage)  -- | Clone the environment to use it in a different thread.-cloneEnv :: Env es -> IO (Env es)+cloneEnv :: HasCallStack => Env es -> IO (Env es) cloneEnv (Env offset refs storage0) = do   Storage storageSize version vs0 es0 fs0 <- readIORef' storage0   vsSize <- getSizeofMutablePrimArray  vs0@@ -149,10 +221,10 @@         0 -> pure ()         k -> do           let i = k - 1-          Relinker f <- fromAny <$> readSmallArray fs i+          Relinker relinker <- fromAnyRelinker <$> readSmallArray fs i           readSmallArray es i-            >>= f (relinkEnv storage) . fromAny-            >>= writeSmallArray' es i . toAny+            >>= relinker (relinkEnv storage) . fromAnyEffect+            >>= writeSmallArray' es i . toAnyEffect           relinkEffects i   relinkEffects storageSize   pure $ Env offset refs storage@@ -162,7 +234,8 @@ -- -- @since 2.2.0.0 restoreEnv-  :: Env es -- ^ Destination.+  :: HasCallStack+  => Env es -- ^ Destination.   -> Env es -- ^ Source.   -> IO () restoreEnv dest src = do@@ -183,30 +256,30 @@ -- | Get the current size of the environment. sizeEnv :: Env es -> IO Int sizeEnv (Env offset refs _) = do-  pure $ (sizeofPrimArray refs - offset) `div` 2+  pure $ sizeofPrimArray refs - offset  -- | Access the tail of the environment. tailEnv :: Env (e : es) -> IO (Env es) tailEnv (Env offset refs storage) = do-  pure $ Env (offset + 2) refs storage+  pure $ Env (offset + 1) refs storage  ---------------------------------------- -- Extending and shrinking  -- | Extend the environment with a new data type. consEnv-  :: EffectRep (DispatchOf e) e+  :: HasCallStack+  => EffectRep (DispatchOf e) e   -- ^ The representation of the effect.   -> Relinker (EffectRep (DispatchOf e)) e   -> Env es   -> IO (Env (e : es)) consEnv e f (Env offset refs0 storage) = do   let size = sizeofPrimArray refs0 - offset-  mrefs <- newPrimArray (size + 2)-  copyPrimArray mrefs 2 refs0 offset size-  (ref, version) <- insertEffect storage e f+  mrefs <- newPrimArray (size + 1)+  copyPrimArray mrefs 1 refs0 offset size+  ref <- insertEffect storage e f   writePrimArray mrefs 0 ref-  writePrimArray mrefs 1 version   refs <- unsafeFreezePrimArray mrefs   pure $ Env 0 refs storage {-# NOINLINE consEnv #-}@@ -215,7 +288,7 @@ -- -- /Note:/ after calling this function @e@ from the input environment is no -- longer usable.-unconsEnv :: Env (e : es) -> IO ()+unconsEnv :: HasCallStack => Env (e : es) -> IO () unconsEnv (Env _ refs storage) = do   deleteEffect storage (indexPrimArray refs 0) {-# NOINLINE unconsEnv #-}@@ -227,7 +300,7 @@ -- /Note:/ unlike in 'putEnv' the value in not changed in place, so only the new -- environment will see it. replaceEnv-  :: forall e es. e :> es+  :: forall e es. (HasCallStack, e :> es)   => EffectRep (DispatchOf e) e   -- ^ The representation of the effect.   -> Relinker (EffectRep (DispatchOf e)) e@@ -237,10 +310,8 @@   let size = sizeofPrimArray refs0 - offset   mrefs <- newPrimArray size   copyPrimArray mrefs 0 refs0 offset size-  (ref, version) <- insertEffect storage e f-  let i = 2 * reifyIndex @e @es-  writePrimArray mrefs  i      ref-  writePrimArray mrefs (i + 1) version+  ref <- insertEffect storage e f+  writePrimArray mrefs (reifyIndex @e @es) ref   refs <- unsafeFreezePrimArray mrefs   pure $ Env 0 refs storage {-# NOINLINE replaceEnv #-}@@ -249,9 +320,9 @@ -- -- /Note:/ after calling this function the input environment is no longer -- usable.-unreplaceEnv :: forall e es. e :> es => Env es -> IO ()+unreplaceEnv :: forall e es. (HasCallStack, e :> es) => Env es -> IO () unreplaceEnv (Env offset refs storage) = do-  deleteEffect storage $ indexPrimArray refs (offset + 2 * reifyIndex @e @es)+  deleteEffect storage $ indexPrimArray refs (offset + reifyIndex @e @es) {-# NOINLINE unreplaceEnv #-}  ----------------------------------------@@ -260,11 +331,9 @@ subsumeEnv :: forall e es. e :> es => Env es -> IO (Env (e : es)) subsumeEnv (Env offset refs0 storage) = do   let size = sizeofPrimArray refs0 - offset-  mrefs <- newPrimArray (size + 2)-  copyPrimArray mrefs 2 refs0 offset size-  let ix = offset + 2 * reifyIndex @e @es-  writePrimArray mrefs 0 $ indexPrimArray refs0  ix-  writePrimArray mrefs 1 $ indexPrimArray refs0 (ix + 1)+  mrefs <- newPrimArray (size + 1)+  copyPrimArray mrefs 1 refs0 offset size+  writePrimArray mrefs 0 $ indexPrimArray refs0 (offset + reifyIndex @e @es)   refs <- unsafeFreezePrimArray mrefs   pure $ Env 0 refs storage {-# NOINLINE subsumeEnv #-}@@ -273,24 +342,22 @@  -- | Construct an environment containing a permutation (with possible -- duplicates) of a subset of effects from the input environment.-injectEnv :: forall xs es. Subset xs es => Env es -> IO (Env xs)+injectEnv :: forall subEs es. Subset subEs es => Env es -> IO (Env subEs) injectEnv (Env offset refs0 storage) = do-  let xs         = reifyIndices @xs @es-      permSize   = 2 * length xs-      prefixSize = 2 * prefixLength @es-      suffixSize = if subsetFullyKnown @xs @es+  let subEs      = reifyIndices @subEs @es+      subEsSize  = length subEs+      prefixSize = prefixLength @es+      suffixSize = if subsetFullyKnown @subEs @es                    then 0                    else sizeofPrimArray refs0 - offset - prefixSize-  mrefs <- newPrimArray (permSize + suffixSize)-  copyPrimArray mrefs permSize refs0 (offset + prefixSize) suffixSize-  let writePermRefs i = \case+  mrefs <- newPrimArray (subEsSize + suffixSize)+  copyPrimArray mrefs subEsSize refs0 (offset + prefixSize) suffixSize+  let writeRefs i = \case         []       -> pure ()-        (e : es) -> do-          let ix = offset + 2 * e-          writePrimArray mrefs  i      $ indexPrimArray refs0  ix-          writePrimArray mrefs (i + 1) $ indexPrimArray refs0 (ix + 1)-          writePermRefs (i + 2) es-  writePermRefs 0 xs+        (x : xs) -> do+          writePrimArray mrefs i $ indexPrimArray refs0 (offset + x)+          writeRefs (i + 1) xs+  writeRefs 0 subEs   refs <- unsafeFreezePrimArray mrefs   pure $ Env 0 refs storage {-# NOINLINE injectEnv #-}@@ -300,55 +367,52 @@  -- | Extract a specific data type from the environment. getEnv-  :: forall e es. e :> es+  :: forall e es. (HasCallStack, e :> es)   => Env es -- ^ The environment.   -> IO (EffectRep (DispatchOf e) e) getEnv env = do   (i, es) <- getLocation @e env-  fromAny <$> readSmallArray es i+  fromAnyEffect <$> readSmallArray es i  -- | Replace the data type in the environment with a new value (in place). putEnv-  :: forall e es. e :> es+  :: forall e es. (HasCallStack, e :> es)   => Env es -- ^ The environment.   -> EffectRep (DispatchOf e) e   -> IO () putEnv env e = do   (i, es) <- getLocation @e env-  writeSmallArray' es i (toAny e)+  writeSmallArray' es i (toAnyEffect e)  -- | Modify the data type in the environment and return a value (in place). stateEnv-  :: forall e es a. e :> es+  :: forall e es a. (HasCallStack, e :> es)   => Env es -- ^ The environment.-  -> (EffectRep (DispatchOf e) e -> IO (a, EffectRep (DispatchOf e) e))+  -> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e))   -> IO a stateEnv env f = do   (i, es) <- getLocation @e env-  (a, e) <- f . fromAny =<< readSmallArray es i-  writeSmallArray' es i (toAny e)+  (a, e) <- f . fromAnyEffect <$> readSmallArray es i+  writeSmallArray' es i (toAnyEffect e)   pure a  -- | Modify the data type in the environment (in place). modifyEnv-  :: forall e es. e :> es+  :: forall e es. (HasCallStack, e :> es)   => Env es -- ^ The environment.-  -> (EffectRep (DispatchOf e) e -> IO (EffectRep (DispatchOf e) e))+  -> (EffectRep (DispatchOf e) e -> (EffectRep (DispatchOf e) e))   -> IO () modifyEnv env f = do   (i, es) <- getLocation @e env-  e <- f . fromAny =<< readSmallArray es i-  writeSmallArray' es i (toAny e)+  e <- f . fromAnyEffect <$> readSmallArray es i+  writeSmallArray' es i (toAnyEffect e)  -- | Determine location of the effect in the environment. getLocation-  :: forall e es. e :> es+  :: forall e es. (HasCallStack, e :> es)   => Env es-  -> IO (Int, SmallMutableArray RealWorld Any)+  -> IO (Int, SmallMutableArray RealWorld AnyEffect) getLocation (Env offset refs storage) = do-  let i       = offset + 2 * reifyIndex @e @es-      ref     = indexPrimArray refs  i-      version = indexPrimArray refs (i + 1)   Storage _ _ vs es _ <- readIORef' storage   storageVersion <- readPrimArray vs ref   -- If version of the reference is different than version in the storage, it@@ -356,26 +420,32 @@   -- referenced.   when (version /= storageVersion) $ do     error $ "version (" ++ show version ++ ") /= storageVersion ("-         ++ show storageVersion ++ ")"+         ++ show storageVersion ++ ")\n"+         ++ "If you're attempting to run an unlifting function outside "+         ++ "of the scope of effects it captures, have a look at "+         ++ "UnliftingStrategy (SeqForkUnlift)."   pure (ref, es)+  where+    Ref ref version = indexPrimArray refs (offset + reifyIndex @e @es)  ---------------------------------------- -- Internal helpers  -- | Create an empty storage.-emptyStorage :: IO Storage-emptyStorage = Storage 0 (noVersion + 1)+emptyStorage :: HasCallStack => IO Storage+emptyStorage = Storage 0 initialVersion   <$> newPrimArray 0-  <*> newSmallArray 0 undefinedData-  <*> newSmallArray 0 undefinedData+  <*> newSmallArray 0 undefinedEffect+  <*> newSmallArray 0 undefinedRelinker  -- | Insert an effect into the storage and return its reference. insertEffect-  :: IORef' Storage+  :: HasCallStack+  => IORef' Storage   -> EffectRep (DispatchOf e) e   -- ^ The representation of the effect.   -> Relinker (EffectRep (DispatchOf e)) e-  -> IO (Int, Int)+  -> IO Ref insertEffect storage e f = do   Storage size version vs0 es0 fs0 <- readIORef' storage   len0 <- getSizeofSmallMutableArray es0@@ -383,35 +453,39 @@     GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"     LT -> do       writePrimArray   vs0 size version-      writeSmallArray' es0 size (toAny e)-      writeSmallArray' fs0 size (toAny f)-      writeIORef' storage $ Storage (size + 1) (version + 1) vs0 es0 fs0-      pure (size, version)+      writeSmallArray' es0 size (toAnyEffect e)+      writeSmallArray' fs0 size (toAnyRelinker f)+      writeIORef' storage $ Storage (size + 1) (bumpVersion version) vs0 es0 fs0+      pure $ Ref size version     EQ -> do       let len = doubleCapacity len0       vs <- newPrimArray len-      es <- newSmallArray len undefinedData-      fs <- newSmallArray len undefinedData+      es <- newSmallArray len undefinedEffect+      fs <- newSmallArray len undefinedRelinker       copyMutablePrimArray  vs 0 vs0 0 size       copySmallMutableArray es 0 es0 0 size       copySmallMutableArray fs 0 fs0 0 size       writePrimArray   vs size version-      writeSmallArray' es size (toAny e)-      writeSmallArray' fs size (toAny f)-      writeIORef' storage $ Storage (size + 1) (version + 1) vs es fs-      pure (size, version)+      writeSmallArray' es size (toAnyEffect e)+      writeSmallArray' fs size (toAnyRelinker f)+      writeIORef' storage $ Storage (size + 1) (bumpVersion version) vs es fs+      pure $ Ref size version  -- | Given a reference to an effect from the top of the stack, delete it from -- the storage.-deleteEffect :: IORef' Storage -> Int -> IO ()-deleteEffect storage ref = do-  Storage size version vs es fs <- readIORef' storage+deleteEffect :: HasCallStack => IORef' Storage -> Ref -> IO ()+deleteEffect storage (Ref ref version) = do+  Storage size currentVersion vs es fs <- readIORef' storage   when (ref /= size - 1) $ do     error $ "ref (" ++ show ref ++ ") /= size - 1 (" ++ show (size - 1) ++ ")"-  writePrimArray  vs ref noVersion-  writeSmallArray es ref undefinedData-  writeSmallArray fs ref undefinedData-  writeIORef' storage $ Storage (size - 1) version vs es fs+  storageVersion <- readPrimArray vs ref+  when (version /= storageVersion) $ do+    error $ "version (" ++ show version ++ ") /= storageVersion ("+         ++ show storageVersion ++ ")\n"+  writePrimArray  vs ref undefinedVersion+  writeSmallArray es ref undefinedEffect+  writeSmallArray fs ref undefinedRelinker+  writeIORef' storage $ Storage (size - 1) currentVersion vs es fs  -- | Relink the environment to use the new storage. relinkEnv :: IORef' Storage -> Env es -> IO (Env es)@@ -421,11 +495,30 @@ doubleCapacity :: Int -> Int doubleCapacity n = max 1 n * 2 -noVersion :: Int-noVersion = 0+undefinedVersion :: Version+undefinedVersion = Version 0 -undefinedData :: HasCallStack => a-undefinedData = error "undefined data"+initialVersion :: Version+initialVersion = Version 1++bumpVersion :: Version -> Version+bumpVersion (Version n) = Version (n + 1)++undefinedEffect :: HasCallStack => AnyEffect+undefinedEffect = toAnyEffect . errorWithoutStackTrace $ unlines+  [ "Undefined effect"+  , "Created at: " ++ prettyCallStack callStack+  ]++undefinedRelinker :: HasCallStack => AnyRelinker+undefinedRelinker = toAnyRelinker $ Relinker $ \_ _ -> do+  errorWithoutStackTrace $ unlines+    [ "Undefined relinker"+    , "Created at: " ++ prettyCallStack creationCallStack+    , "Called at: " ++ prettyCallStack callStack+    ]+  where+    creationCallStack = callStack  -- | A strict version of 'writeSmallArray'. writeSmallArray' :: SmallMutableArray RealWorld a -> Int -> a -> IO ()

@@ -50,6 +50,7 @@    -- ** Low-level unlifts   , seqUnliftIO+  , seqForkUnliftIO   , concUnliftIO    -- * Dispatch@@ -73,16 +74,10 @@   , stateStaticRep   , stateStaticRepM   , localStaticRep--  -- *** Primitive operations-  , consEnv-  , getEnv-  , putEnv-  , stateEnv-  , modifyEnv   ) where  import Control.Applicative+import Control.Concurrent (myThreadId) import Control.Exception qualified as E import Control.Monad import Control.Monad.Base@@ -124,12 +119,12 @@ -- -- - Allows the effects to be handled in any order. newtype Eff (es :: [Effect]) a = Eff (Env es -> IO a)-  deriving (Monoid, Semigroup)+  deriving newtype (Monoid, Semigroup)  -- | Run a pure 'Eff' computation. -- -- For running computations with side effects see 'runEff'.-runPureEff :: Eff '[] a -> a+runPureEff :: HasCallStack => Eff '[] a -> a runPureEff (Eff m) =   -- unsafeDupablePerformIO is safe here since IOE was not on the stack, so no   -- IO with side effects was performed (unless someone sneakily introduced side@@ -144,7 +139,7 @@  -- | Peel off the constructor of 'Eff'. unEff :: Eff es a -> Env es -> IO a-unEff = \(Eff m) -> m+unEff (Eff m) = m  -- | Access the underlying 'IO' monad along with the environment. --@@ -188,7 +183,8 @@   => ((forall r. Eff es r -> IO r) -> IO a)   -- ^ Continuation with the unlifting function in scope.   -> Eff es a-withSeqEffToIO f = unsafeEff $ \es -> seqUnliftIO es f+withSeqEffToIO k = unsafeEff $ \es -> seqUnliftIO es k+{-# INLINE withSeqEffToIO #-}  -- | Create an unlifting function with the given strategy. --@@ -202,6 +198,7 @@   -> Eff es a withEffToIO strategy k = case strategy of   SeqUnlift      -> unsafeEff $ \es -> seqUnliftIO es k+  SeqForkUnlift  -> unsafeEff $ \es -> seqForkUnliftIO es k   ConcUnlift p b -> unsafeEff $ \es -> concUnliftIO es p b k {-# INLINE withEffToIO #-} @@ -215,8 +212,8 @@   -> ((forall r. Eff es r -> IO r) -> IO a)   -- ^ Continuation with the unlifting function in scope.   -> Eff es a-withConcEffToIO persistence limit f = unsafeEff $ \es ->-  concUnliftIO es persistence limit f+withConcEffToIO persistence limit k = unsafeEff $ \es ->+  concUnliftIO es persistence limit k {-# DEPRECATED withConcEffToIO "Use withEffToIO with the appropriate strategy." #-}  -- | Create an unlifting function with the 'SeqUnlift' strategy.@@ -227,8 +224,27 @@   -> ((forall r. Eff es r -> IO r) -> IO a)   -- ^ Continuation with the unlifting function in scope.   -> IO a-seqUnliftIO es k = seqUnlift k es unEff+seqUnliftIO es k = do+  tid0 <- myThreadId+  k $ \m -> do+    tid <- myThreadId+    if tid `eqThreadId` tid0+      then unEff m es+      else error+         $ "If you want to use the unlifting function to run Eff computations "+        ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)." +-- | Create an unlifting function with the 'SeqForkUnlift' strategy.+seqForkUnliftIO+  :: HasCallStack+  => Env es+  -- ^ The environment.+  -> ((forall r. Eff es r -> IO r) -> IO a)+  -- ^ Continuation with the unlifting function in scope.+  -> IO a+seqForkUnliftIO es0 k = cloneEnv es0 >>= \es -> seqUnliftIO es k+{-# INLINE seqForkUnliftIO #-}+ -- | Create an unlifting function with the 'ConcUnlift' strategy. concUnliftIO   :: HasCallStack@@ -239,7 +255,10 @@   -> ((forall r. Eff es r -> IO r) -> IO a)   -- ^ Continuation with the unlifting function in scope.   -> IO a-concUnliftIO es persistence limit k = concUnlift persistence limit k es unEff+concUnliftIO es Ephemeral (Limited uses) = ephemeralConcUnlift es uses+concUnliftIO es Ephemeral Unlimited = ephemeralConcUnlift es maxBound+concUnliftIO es Persistent (Limited threads) = persistentConcUnlift es False threads+concUnliftIO es Persistent Unlimited = persistentConcUnlift es True maxBound  ---------------------------------------- -- Base@@ -279,7 +298,7 @@  -- | @since 2.2.0.0 instance NonDet :> es => Alternative (Eff es) where-  empty   = withFrozenCallStack (send Empty)+  empty   = send Empty   a <|> b = send (a :<|>: b)  -- | @since 2.2.0.0@@ -321,7 +340,7 @@ type instance DispatchOf Fail = Dynamic  instance Fail :> es => MonadFail (Eff es) where-  fail msg = withFrozenCallStack $ send (Fail msg)+  fail msg = send (Fail msg)  ---------------------------------------- -- IO@@ -339,7 +358,7 @@ -- | Run an 'Eff' computation with side effects. -- -- For running pure computations see 'runPureEff'.-runEff :: Eff '[IOE] a -> IO a+runEff :: HasCallStack => Eff '[IOE] a -> IO a runEff m = unEff m =<< consEnv (IOE SeqUnlift) dummyRelinker =<< emptyEnv  instance IOE :> es => MonadIO (Eff es) where@@ -387,7 +406,7 @@ data PrimStateEff  -- | Run an 'Eff' computation with primitive state-transformer actions.-runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a+runPrim :: (HasCallStack, IOE :> es) => Eff (Prim : es) a -> Eff es a runPrim = evalStaticRep Prim  instance Prim :> es => PrimMonad (Eff es) where@@ -411,23 +430,23 @@   -> ((forall r. Eff (e : es) r -> Eff es r) -> Eff es a)   -- ^ Continuation with the unlifting function in scope.   -> Eff (e : es) a-raiseWith strategy k = case strategy of-  SeqUnlift -> unsafeEff $ \ees -> do-    es <- tailEnv ees-    seqUnliftIO ees $ \unlift -> do+raiseWith strategy k = unsafeEff $ \ees -> do+  es <- tailEnv ees+  case strategy of+    SeqUnlift -> seqUnliftIO ees $ \unlift -> do       (`unEff` es) $ k $ unsafeEff_ . unlift-  ConcUnlift p l -> unsafeEff $ \ees -> do-    es <- tailEnv ees-    concUnliftIO ees p l $ \unlift -> do+    SeqForkUnlift -> seqForkUnliftIO ees $ \unlift -> do       (`unEff` es) $ k $ unsafeEff_ . unlift+    ConcUnlift p l -> concUnliftIO ees p l $ \unlift -> do+      (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE raiseWith #-}  -- | Eliminate a duplicate effect from the top of the effect stack. subsume :: e :> es => Eff (e : es) a -> Eff es a subsume m = unsafeEff $ \es -> unEff m =<< subsumeEnv es --- | Allow for running an effect stack @xs@ within @es@ as long as @xs@ is a--- permutation (with possible duplicates) of a subset of @es@.+-- | Allow for running an effect stack @subEs@ within @es@ as long as @subEs@ is+-- a permutation (with possible duplicates) of a subset of @es@. -- -- Generalizes 'raise' and 'subsume'. --@@ -476,7 +495,7 @@ -- ... -- ...Couldn't match type ‘es1’ with ‘es2’ -- ...-inject :: Subset xs es => Eff xs a -> Eff es a+inject :: Subset subEs es => Eff subEs a -> Eff es a inject m = unsafeEff $ \es -> unEff m =<< injectEnv es  ----------------------------------------@@ -494,13 +513,13 @@ newtype LocalEnv (localEs :: [Effect]) (handlerEs :: [Effect]) = LocalEnv (Env localEs)  -- | Type signature of the effect handler.-type EffectHandler e es+type EffectHandler (e :: Effect) (es :: [Effect])   = forall a localEs. (HasCallStack, e :> localEs)   => LocalEnv localEs es   -- ^ Capture of the local environment for handling local 'Eff' computations   -- when @e@ is a higher order effect.   -> e (Eff localEs) a-  -- ^ The effect performed in the local environment.+  -- ^ The operation.   -> Eff es a  -- | An internal representation of dynamically dispatched effects, i.e. the@@ -515,7 +534,11 @@   pure $ Handler newHandlerEs handler  -- | Run a dynamically dispatched effect with the given handler.-runHandler :: DispatchOf e ~ Dynamic => Handler e -> Eff (e : es) a -> Eff es a+runHandler+  :: (HasCallStack, DispatchOf e ~ Dynamic)+  => Handler e+  -> Eff (e : es) a+  -> Eff es a runHandler e m = unsafeEff $ \es0 -> do   inlineBracket     (consEnv e relinkHandler es0)@@ -553,7 +576,7 @@ -- | Run a statically dispatched effect with the given initial representation -- and return the final value along with the final representation. runStaticRep-  :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)+  :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)   => StaticRep e -- ^ The initial representation.   -> Eff (e : es) a   -> Eff es (a, StaticRep e)@@ -566,7 +589,7 @@ -- | Run a statically dispatched effect with the given initial representation -- and return the final value, discarding the final representation. evalStaticRep-  :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)+  :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)   => StaticRep e -- ^ The initial representation.   -> Eff (e : es) a   -> Eff es a@@ -579,7 +602,7 @@ -- | Run a statically dispatched effect with the given initial representation -- and return the final representation, discarding the final value. execStaticRep-  :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)+  :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)   => StaticRep e -- ^ The initial representation.   -> Eff (e : es) a   -> Eff es (StaticRep e)@@ -590,42 +613,48 @@     (\es -> unEff m es *> getEnv es)  -- | Fetch the current representation of the effect.-getStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => Eff es (StaticRep e)+getStaticRep+  :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es)+  => Eff es (StaticRep e) getStaticRep = unsafeEff $ \es -> getEnv es  -- | Set the current representation of the effect to the given value.-putStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => StaticRep e -> Eff es ()+putStaticRep+  :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es)+  => StaticRep e -> Eff es () putStaticRep s = unsafeEff $ \es -> putEnv es s  -- | Apply the function to the current representation of the effect and return a -- value. stateStaticRep-  :: (DispatchOf e ~ Static sideEffects, e :> es)+  :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es)   => (StaticRep e -> (a, StaticRep e))   -- ^ The function to modify the representation.   -> Eff es a-stateStaticRep f = unsafeEff $ \es -> stateEnv es (pure . f)+stateStaticRep f = unsafeEff $ \es -> stateEnv es f  -- | Apply the monadic function to the current representation of the effect and -- return a value. stateStaticRepM-  :: (DispatchOf e ~ Static sideEffects, e :> es)+  :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es)   => (StaticRep e -> Eff es (a, StaticRep e))   -- ^ The function to modify the representation.   -> Eff es a stateStaticRepM f = unsafeEff $ \es -> E.mask $ \unmask -> do-  stateEnv es $ unmask . (`unEff` es) . f+  (a, e) <- unmask . (`unEff` es) . f =<< getEnv es+  putEnv es e+  pure a  -- | Execute a computation with a temporarily modified representation of the -- effect. localStaticRep-  :: (DispatchOf e ~ Static sideEffects, e :> es)+  :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es)   => (StaticRep e -> StaticRep e)   -- ^ The function to temporarily modify the representation.   -> Eff es a   -> Eff es a localStaticRep f m = unsafeEff $ \es -> do   inlineBracket-    (stateEnv es $ \s -> pure (s, f s))+    (stateEnv es $ \s -> (s, f s))     (\s -> putEnv es s)     (\_ -> unEff m es)

@@ -1,4 +1,5 @@ {-# LANGUAGE MagicHash #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} -- | Implementation of sequential and concurrent unlifts.@@ -12,12 +13,14 @@   , Limit(..)      -- * Unlifting functions-  , seqUnlift-  , concUnlift+  , ephemeralConcUnlift+  , persistentConcUnlift   ) where  import Control.Concurrent+import Control.Concurrent.MVar.Strict import Control.Monad+import Data.Coerce import Data.IntMap.Strict qualified as IM import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)@@ -41,11 +44,59 @@   -- ^ The sequential strategy is the fastest and a default setting for   -- t'Effectful.IOE'. Any attempt of calling the unlifting function in threads   -- distinct from its creator will result in a runtime error.+  | SeqForkUnlift+  -- ^ Like 'SeqUnlift', but all unlifted actions will be executed in a cloned+  -- environment.+  --+  -- The main consequence is that thread local state is forked at the point of+  -- creation of the unlifting function and its modifications in unlifted+  -- actions will not affect the main thread of execution (and vice versa):+  --+  -- >>> import Effectful+  -- >>> import Effectful.State.Dynamic+  -- >>> :{+  --  action :: (IOE :> es, State Int :> es) => Eff es ()+  --  action = do+  --    modify @Int (+1)+  --    withEffToIO SeqForkUnlift $ \unlift -> unlift $ modify @Int (+2)+  --    modify @Int (+4)+  -- :}+  --+  -- >>> runEff . execStateLocal @Int 0 $ action+  -- 5+  --+  -- >>> runEff . execStateShared @Int 0 $ action+  -- 7+  --+  -- Because of this it's possible to safely use the unlifting function outside+  -- of the scope of effects it captures, e.g. by creating an @IO@ action that+  -- executes effectful operations and running it later:+  --+  -- >>> :{+  --   delayed :: UnliftStrategy -> IO (IO String)+  --   delayed strategy = runEff . evalStateLocal "Hey" $ do+  --     r <- withEffToIO strategy $ \unlift -> pure $ unlift get+  --     modify (++ "!!!")+  --     pure r+  -- :}+  --+  -- This doesn't work with the 'SeqUnlift' strategy because when the returned+  -- action runs, @State@ is no longer in scope:+  --+  -- >>> join $ delayed SeqUnlift+  -- *** Exception: version (...) /= storageVersion (0)+  -- ...+  --+  -- However, it does with the 'SeqForkUnlift' strategy:+  --+  -- >>> join $ delayed SeqForkUnlift+  -- "Hey"+  --   | ConcUnlift !Persistence !Limit   -- ^ The concurrent strategy makes it possible for the unlifting function to   -- be called in threads distinct from its creator. See 'Persistence' and   -- 'Limit' settings for more information.-  deriving (Eq, Generic, Ord, Show)+  deriving stock (Eq, Generic, Ord, Show)  -- | Persistence setting for the 'ConcUnlift' strategy. --@@ -65,7 +116,7 @@   | Persistent   -- ^ Persist the environment between calls to the unlifting function within a   -- particular thread.-  deriving (Eq, Generic, Ord, Show)+  deriving stock (Eq, Generic, Ord, Show)  -- | Limit setting for the 'ConcUnlift' strategy. data Limit@@ -84,60 +135,21 @@   -- when called in @N@ threads and @K+1@ copies when called in @K < N@ threads.   | Unlimited   -- ^ Unlimited use of the unlifting function.-  deriving (Eq, Generic, Ord, Show)+  deriving stock (Eq, Generic, Ord, Show)  ---------------------------------------- -- Unlift functions --- | Sequential unlift.-seqUnlift-  :: HasCallStack-  => ((forall r. m r -> IO r) -> IO a)-  -> Env es-  -> (forall r. m r -> Env es -> IO r)-  -> IO a-seqUnlift k es unEff = do-  tid0 <- myThreadId-  k $ \m -> do-    tid <- myThreadId-    if tid `eqThreadId` tid0-      then unEff m es-      else error-         $ "If you want to use the unlifting function to run Eff computations "-        ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)."---- | Concurrent unlift.-concUnlift-  :: HasCallStack-  => Persistence-  -> Limit-  -> ((forall r. m r -> IO r) -> IO a)-  -> Env es-  -> (forall r. m r -> Env es -> IO r)-  -> IO a-concUnlift Ephemeral (Limited uses) k =-  ephemeralConcUnlift uses k-concUnlift Ephemeral Unlimited k =-  ephemeralConcUnlift maxBound k-concUnlift Persistent (Limited threads) k =-  persistentConcUnlift False threads k-concUnlift Persistent Unlimited k =-  persistentConcUnlift True maxBound k--------------------------------------------- Internal- -- | Concurrent unlift that doesn't preserve the environment between calls to -- the unlifting function in threads other than its creator. ephemeralConcUnlift-  :: HasCallStack-  => Int+  :: (HasCallStack, forall r. Coercible (m r) (Env es -> IO r))+  => Env es+  -> Int   -- ^ Number of permitted uses of the unlift function.   -> ((forall r. m r -> IO r) -> IO a)-  -> Env es-  -> (forall r. m r -> Env es -> IO r)   -> IO a-ephemeralConcUnlift uses k es0 unEff = do+ephemeralConcUnlift es0 uses k = do   unless (uses > 0) $ do     error $ "Invalid number of uses: " ++ show uses   tid0 <- myThreadId@@ -158,21 +170,20 @@         n -> do           es <- cloneEnv esTemplate           pure (n - 1, es)-    unEff m es+    coerce m es {-# NOINLINE ephemeralConcUnlift #-}  -- | Concurrent unlift that preserves the environment between calls to the -- unlifting function within a particular thread. persistentConcUnlift-  :: HasCallStack-  => Bool+  :: (HasCallStack, forall r. Coercible (m r) (Env es -> IO r))+  => Env es+  -> Bool   -> Int   -- ^ Number of threads that are allowed to use the unlift function.   -> ((forall r. m r -> IO r) -> IO a)-  -> Env es-  -> (forall r. m r -> Env es -> IO r)   -> IO a-persistentConcUnlift cleanUp threads k es0 unEff = do+persistentConcUnlift es0 cleanUp threads k = do   unless (threads > 0) $ do     error $ "Invalid number of threads: " ++ show threads   tid0 <- myThreadId@@ -211,14 +222,14 @@                     , teEntries  = addThreadData wkTid i wkTidEs $ teEntries te                     }               pure (newEntries, es)-    unEff m es+    coerce m es {-# NOINLINE persistentConcUnlift #-}  ---------------------------------------- -- Data types  newtype EntryId = EntryId Int-  deriving Eq+  deriving newtype Eq  newEntryId :: EntryId newEntryId = EntryId 0@@ -295,7 +306,7 @@ ----------------------------------------  deleteThreadData :: Int -> EntryId -> MVar' (ThreadEntries es) -> IO ()-deleteThreadData wkTid i v = modifyMVar_' v $ \te -> do+deleteThreadData wkTid i v = modifyMVar'_ v $ \te -> do   pure ThreadEntries     { teCapacity = case teCapacity te of         -- If the template copy of the environment hasn't been consumed

@@ -14,20 +14,6 @@   , toAny   , fromAny -    -- * Strict 'IORef'-  , IORef'-  , newIORef'-  , readIORef'-  , writeIORef'--    -- * Strict 'MVar'-  , MVar'-  , toMVar'-  , newMVar'-  , readMVar'-  , modifyMVar'-  , modifyMVar_'-     -- * Unique   , Unique   , newUnique@@ -36,9 +22,7 @@   , thawCallStack   ) where -import Control.Concurrent.MVar import Control.Exception-import Data.IORef import Data.Primitive.ByteArray import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (Any, RealWorld)@@ -125,49 +109,6 @@  fromAny :: Any -> a fromAny = unsafeCoerce---------------------------------------------- | A strict variant of 'IORef'.-newtype IORef' a = IORef' (IORef a)-  deriving Eq--newIORef' :: a -> IO (IORef' a)-newIORef' a = a `seq` (IORef' <$> newIORef a)--readIORef' :: IORef' a -> IO a-readIORef' (IORef' var) = readIORef var--writeIORef' :: IORef' a -> a -> IO ()-writeIORef' (IORef' var) a = a `seq` writeIORef var a---------------------------------------------- | A strict variant of 'MVar'.-newtype MVar' a = MVar' (MVar a)-  deriving Eq--toMVar' :: MVar a -> IO (MVar' a)-toMVar' var = do-  let var' = MVar' var-  modifyMVar_' var' pure-  pure var'--newMVar' :: a -> IO (MVar' a)-newMVar' a = a `seq` (MVar' <$> newMVar a)--readMVar' :: MVar' a -> IO a-readMVar' (MVar' var) = readMVar var--modifyMVar' :: MVar' a -> (a -> IO (a, r)) -> IO r-modifyMVar' (MVar' var) action = modifyMVar var $ \a0 -> do-  (a, r) <- action a0-  a `seq` pure (a, r)--modifyMVar_' :: MVar' a -> (a -> IO a) -> IO ()-modifyMVar_' (MVar' var) action = modifyMVar_ var $ \a0 -> do-  a <- action a0-  a `seq` pure a  ---------------------------------------- 

@@ -1,14 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE PolyKinds #-} -- | Labeled effects. --+-- Any effect can be assigned multiple labels so you have more than one+-- available simultaneously.+-- -- @since 2.3.0.0 module Effectful.Labeled-  ( -- * Example-    -- $example--    -- * Effect-    Labeled+  ( -- * Effect+    Labeled(..)      -- ** Handlers   , runLabeled@@ -22,58 +21,49 @@ import Effectful import Effectful.Dispatch.Static --- $example+-- | Assign a label to an effect. ----- An effect can be assigned multiple labels and you can have all of them--- available at the same time.+-- The constructor is for sending labeled operations of a dynamically dispatched+-- effect to the handler: ----- >>> import Effectful.Reader.Static+-- >>> import Effectful.Dispatch.Dynamic -- -- >>> :{---  action---    :: ( Labeled "a" (Reader String) :> es---       , Labeled "b" (Reader String) :> es---       , Reader String :> es---       )---    => Eff es String---  action = do---    a <- labeled @"b" @(Reader String) $ do---      labeled @"a" @(Reader String) $ do---        ask---    b <- labeled @"b" @(Reader String) $ do---      ask---    pure $ a ++ b+--   data X :: Effect where+--     X :: X m Int+--   type instance DispatchOf X = Dynamic -- :} -- -- >>> :{---  runPureEff @String---    . runLabeled @"a" (runReader "a")---    . runLabeled @"b" (runReader "b")---    . runReader "c"---    $ action+--   runPureEff . runLabeled @"x" (interpret_ $ \X -> pure 333) $ do+--     send $ Labeled @"x" X -- :}--- "ab"---- | Assign a label to an effect.-data Labeled (label :: k) (e :: Effect) :: Effect+-- 333+--+newtype Labeled (label :: k) (e :: Effect) :: Effect where+  -- | @since 2.4.0.0+  Labeled :: forall label e m a. e m a -> Labeled label e m a -type instance DispatchOf (Labeled label e) = Static NoSideEffects+type instance DispatchOf (Labeled label e) = DispatchOf e  data instance StaticRep (Labeled label e)  -- | Run a 'Labeled' effect with a given effect handler. runLabeled   :: forall label e es a b-   . (Eff (e : es) a -> Eff es b)+   . HasCallStack+  => (Eff (e : es) a -> Eff es b)   -- ^ The effect handler.   -> Eff (Labeled label e : es) a   -> Eff es b runLabeled runE m = runE (fromLabeled m) --- | Bring an effect into scope to be able to run its operations.+-- | Bring an effect into scope without a label.+--+-- Useful for running code written with the non-labeled effect in mind. labeled   :: forall label e es a-   . Labeled label e :> es+   . (HasCallStack, Labeled label e :> es)   => Eff (e : es) a   -- ^ The action using the effect.   -> Eff es a

@@ -0,0 +1,139 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Error' effect.+--+-- @since 2.4.0.0+module Effectful.Labeled.Error+  ( -- * Effect+    Error(..)++    -- ** Handlers+  , runError+  , runErrorWith+  , runErrorNoCallStack+  , runErrorNoCallStackWith++    -- ** Operations+  , throwErrorWith+  , throwError+  , throwError_+  , catchError+  , handleError+  , tryError++    -- * Re-exports+  , E.HasCallStack+  , E.CallStack+  , E.getCallStack+  , E.prettyCallStack+  ) where++import GHC.Stack (withFrozenCallStack)++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Error.Dynamic (Error(..))+import Effectful.Error.Dynamic qualified as E++-- | Handle errors of type @e@ (via "Effectful.Error.Static").+runError+  :: forall label e es a+   . HasCallStack+  => Eff (Labeled label (Error e) : es) a+  -> Eff es (Either (E.CallStack, e) a)+runError = runLabeled @label E.runError++-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific+-- error handler.+runErrorWith+  :: forall label e es a+   . HasCallStack+  => (E.CallStack -> e -> Eff es a)+  -- ^ The error handler.+  -> Eff (Labeled label (Error e) : es) a+  -> Eff es a+runErrorWith = runLabeled @label . E.runErrorWith++-- | Handle errors of type @e@ (via "Effectful.Error.Static"). In case of an+-- error discard the 'E.CallStack'.+runErrorNoCallStack+  :: forall label e es a+   . HasCallStack+  => Eff (Labeled label (Error e) : es) a+  -> Eff es (Either e a)+runErrorNoCallStack = runLabeled @label E.runErrorNoCallStack++-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific+-- error handler. In case of an error discard the 'CallStack'.+runErrorNoCallStackWith+  :: forall label e es a+   . HasCallStack+  => (e -> Eff es a)+  -- ^ The error handler.+  -> Eff (Labeled label (Error e) : es) a+  -> Eff es a+runErrorNoCallStackWith = runLabeled @label . E.runErrorNoCallStackWith++-- | Throw an error of type @e@ and specify a display function in case a+-- third-party code catches the internal exception and 'show's it.+throwErrorWith+  :: forall label e es a+   . (HasCallStack, Labeled label (Error e) :> es)+  => (e -> String)+  -- ^ The display function.+  -> e+  -- ^ The error.+  -> Eff es a+throwErrorWith display =+  withFrozenCallStack send . Labeled @label . ThrowErrorWith display++-- | Throw an error of type @e@ with 'show' as a display function.+throwError+  :: forall label e es a+   . (HasCallStack, Labeled label (Error e) :> es, Show e)+  => e+  -- ^ The error.+  -> Eff es a+throwError = withFrozenCallStack (throwErrorWith @label) show++-- | Throw an error of type @e@ with no display function.+throwError_+  :: forall label e es a+   . (HasCallStack, Labeled label (Error e) :> es)+  => e+  -- ^ The error.+  -> Eff es a+throwError_ = withFrozenCallStack (throwErrorWith @label) (const "<opaque>")++-- | Handle an error of type @e@.+catchError+  :: forall label e es a+   . (HasCallStack, Labeled label (Error e) :> es)+  => Eff es a+  -- ^ The inner computation.+  -> (E.CallStack -> e -> Eff es a)+  -- ^ A handler for errors in the inner computation.+  -> Eff es a+catchError m = send . Labeled @label . CatchError m++-- | The same as @'flip' 'catchError'@, which is useful in situations where the+-- code for the handler is shorter.+handleError+  :: forall label e es a+   . (HasCallStack, Labeled label (Error e) :> es)+  => (E.CallStack -> e -> Eff es a)+  -- ^ A handler for errors in the inner computation.+  -> Eff es a+  -- ^ The inner computation.+  -> Eff es a+handleError = flip (catchError @label)++-- | Similar to 'catchError', but returns an 'Either' result which is a 'Right'+-- if no error was thrown and a 'Left' otherwise.+tryError+  :: forall label e es a+   . (HasCallStack, Labeled label (Error e) :> es)+  => Eff es a+  -- ^ The inner computation.+  -> Eff es (Either (E.CallStack, e) a)+tryError m = catchError @label (Right <$> m) (\es e -> pure $ Left (es, e))

@@ -0,0 +1,67 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Reader' effect.+--+-- @since 2.4.0.0+module Effectful.Labeled.Reader+  ( -- * Effect+    Reader(..)++    -- ** Handlers+  , runReader++    -- ** Operations+  , ask+  , asks+  , local+  ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Reader.Dynamic (Reader(..))+import Effectful.Reader.Dynamic qualified as R++-- | Run the 'Reader' effect with the given initial environment (via+-- "Effectful.Reader.Static").+runReader+  :: forall label r es a+   . HasCallStack+  => r+  -- ^ The initial environment.+  -> Eff (Labeled label (Reader r) : es) a+  -> Eff es a+runReader = runLabeled @label . R.runReader++----------------------------------------+-- Operations++-- | Fetch the value of the environment.+ask+  :: forall label r es+  . (HasCallStack, Labeled label (Reader r) :> es)+  => Eff es r+ask = send $ Labeled @label Ask++-- | Retrieve a function of the current environment.+--+-- @'asks' f ≡ f '<$>' 'ask'@+asks+  :: forall label r es a+   . (HasCallStack, Labeled label (Reader r) :> es)+  => (r -> a)+  -- ^ The function to apply to the environment.+  -> Eff es a+asks f = f <$> ask @label++-- | Execute a computation in a modified environment.+--+-- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@+--+local+  :: forall label r es a+   . (HasCallStack, Labeled label (Reader r) :> es)+  => (r -> r)+  -- ^ The function to modify the environment.+  -> Eff es a+  -> Eff es a+local f = send . Labeled @label . Local f

@@ -0,0 +1,177 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'State' effect.+--+-- @since 2.4.0.0+module Effectful.Labeled.State+  ( -- * Effect+    State(..)++    -- ** Handlers++    -- *** Local+  , runStateLocal+  , evalStateLocal+  , execStateLocal++    -- *** Shared+  , runStateShared+  , evalStateShared+  , execStateShared++    -- ** Operations+  , get+  , gets+  , put+  , state+  , modify+  , stateM+  , modifyM+  ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.State.Dynamic (State(..))+import Effectful.State.Dynamic qualified as S++----------------------------------------+-- Local++-- | Run the 'State' effect with the given initial state and return the final+-- value along with the final state (via "Effectful.State.Static.Local").+runStateLocal+  :: forall label s es a+   . HasCallStack+  => s+   -- ^ The initial state.+  -> Eff (Labeled label (State s) : es) a+  -> Eff es (a, s)+runStateLocal = runLabeled @label . S.runStateLocal++-- | Run the 'State' effect with the given initial state and return the final+-- value, discarding the final state (via "Effectful.State.Static.Local").+evalStateLocal+  :: forall label s es a+   . HasCallStack+  => s+   -- ^ The initial state.+  -> Eff (Labeled label (State s) : es) a+  -> Eff es a+evalStateLocal = runLabeled @label . S.evalStateLocal++-- | Run the 'State' effect with the given initial state and return the final+-- state, discarding the final value (via "Effectful.State.Static.Local").+execStateLocal+  :: forall label s es a+   . HasCallStack+  => s+   -- ^ The initial state.+  -> Eff (Labeled label (State s) : es) a+  -> Eff es s+execStateLocal = runLabeled @label . S.execStateLocal++----------------------------------------+-- Shared++-- | Run the 'State' effect with the given initial state and return the final+-- value along with the final state (via "Effectful.State.Static.Shared").+runStateShared+  :: forall label s es a+   . HasCallStack+  => s+   -- ^ The initial state.+  -> Eff (Labeled label (State s) : es) a+  -> Eff es (a, s)+runStateShared = runLabeled @label . S.runStateShared++-- | Run the 'State' effect with the given initial state and return the final+-- value, discarding the final state (via "Effectful.State.Static.Shared").+evalStateShared+  :: forall label s es a+   . HasCallStack+  => s+   -- ^ The initial state.+  -> Eff (Labeled label (State s) : es) a+  -> Eff es a+evalStateShared = runLabeled @label . S.evalStateShared++-- | Run the 'State' effect with the given initial state and return the final+-- state, discarding the final value (via "Effectful.State.Static.Shared").+execStateShared+  :: forall label s es a+   . HasCallStack+  => s+   -- ^ The initial state.+  -> Eff (Labeled label (State s) : es) a+  -> Eff es s+execStateShared = runLabeled @label . S.execStateShared++----------------------------------------+-- Operations++-- | Fetch the current value of the state.+get+  :: forall label s es+   . (HasCallStack, Labeled label (State s) :> es)+  => Eff es s+get = send $ Labeled @label Get++-- | Get a function of the current state.+--+-- @'gets' f ≡ f '<$>' 'get'@+gets+  :: forall label s es a+   . (HasCallStack, Labeled label (State s) :> es)+  => (s -> a)+  -- ^ .+  -> Eff es a+gets f = f <$> get @label++-- | Set the current state to the given value.+put+  :: forall label s es+   . (HasCallStack, Labeled label (State s) :> es)+  => s+  -- ^ .+  -> Eff es ()+put = send . Labeled @label . Put++-- | Apply the function to the current state and return a value.+state+  :: forall label s es a+   . (HasCallStack, Labeled label (State s) :> es)+  => (s -> (a, s))+  -- ^ .+  -> Eff es a+state = send . Labeled @label . State++-- | Apply the function to the current state.+--+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@+modify+  :: forall label s es+   . (HasCallStack, Labeled label (State s) :> es)+  => (s -> s)+  -- ^ .+  -> Eff es ()+modify f = state @label (\s -> ((), f s))++-- | Apply the monadic function to the current state and return a value.+stateM+  :: forall label s es a+   . (HasCallStack, Labeled label (State s) :> es)+  => (s -> Eff es (a, s))+  -- ^ .+  -> Eff es a+stateM = send . Labeled @label . StateM++-- | Apply the monadic function to the current state.+--+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@+modifyM+  :: forall label s es+   . (HasCallStack, Labeled label (State s) :> es)+  => (s -> Eff es s)+  -- ^ .+  -> Eff es ()+modifyM f = stateM @label (\s -> ((), ) <$> f s)

@@ -0,0 +1,106 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Writer' effect.+--+-- @since 2.4.0.0+module Effectful.Labeled.Writer+  ( -- * Effect+    Writer(..)++    -- ** Handlers++    -- *** Local+  , runWriterLocal+  , execWriterLocal++    -- *** Shared+  , runWriterShared+  , execWriterShared++    -- * Operations+  , tell+  , listen+  , listens+  ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Writer.Dynamic (Writer(..))+import Effectful.Writer.Dynamic qualified as W++----------------------------------------+-- Local++-- | Run the 'Writer' effect and return the final value along with the final+-- output (via "Effectful.Writer.Static.Local").+runWriterLocal+  :: forall label w es a+   . (HasCallStack, Monoid w)+  => Eff (Labeled label (Writer w) : es)+  a -> Eff es (a, w)+runWriterLocal = runLabeled @label W.runWriterLocal++-- | Run a 'Writer' effect and return the final output, discarding the final+-- value (via "Effectful.Writer.Static.Local").+execWriterLocal+  :: forall label w es a+   . (HasCallStack, Monoid w)+  => Eff (Labeled label (Writer w) : es) a+  -> Eff es w+execWriterLocal = runLabeled @label W.execWriterLocal++----------------------------------------+-- Shared++-- | Run the 'Writer' effect and return the final value along with the final+-- output (via "Effectful.Writer.Static.Shared").+runWriterShared+  :: forall label w es a+   . (HasCallStack, Monoid w)+  => Eff (Labeled label (Writer w) : es) a+  -> Eff es (a, w)+runWriterShared = runLabeled @label W.runWriterShared++-- | Run the 'Writer' effect and return the final output, discarding the final+-- value (via "Effectful.Writer.Static.Shared").+execWriterShared+  :: forall label w es a+   . (HasCallStack, Monoid w)+  => Eff (Labeled label (Writer w) : es) a+  -> Eff es w+execWriterShared = runLabeled @label W.execWriterShared++----------------------------------------+-- Operations++-- | Append the given output to the overall output of the 'Writer'.+tell+  :: forall label w es+   . (HasCallStack, Labeled label (Writer w) :> es)+  => w+  -> Eff es ()+tell = send . Labeled @label . Tell++-- | Execute an action and append its output to the overall output of the+-- 'Writer'.+listen+  :: forall label w es a+   . (HasCallStack, Labeled label (Writer w) :> es)+  => Eff es a+  -> Eff es (a, w)+listen = send . Labeled @label . Listen++-- | 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+-- output.+--+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@+listens+  :: forall label w es a b+   . (HasCallStack, Labeled label (Writer w) :> es)+  => (w -> b)+  -> Eff es a+  -> Eff es (a, b)+listens f m = do+  (a, w) <- listen @label m+  pure (a, f w)

@@ -40,9 +40,14 @@ -- -- @since 2.2.0.0 data OnEmptyPolicy-  = OnEmptyKeep     -- ^ Keep modifications on 'Empty'.-  | OnEmptyRollback -- ^ Rollback modifications on 'Empty'.-  deriving (Eq, Generic, Ord, Show)+  = OnEmptyKeep+  -- ^ Keep modifications on 'Empty'.+  | OnEmptyRollback+  -- ^ Rollback modifications on 'Empty'.+  --+  -- /Note:/ state modifications are rolled back on 'Empty' only. In particular,+  -- they are __not__ rolled back on exceptions.+  deriving stock (Eq, Generic, Ord, Show)  -- | Run the 'NonDet' effect with a given 'OnEmptyPolicy'. --@@ -50,33 +55,52 @@ -- computation calls 'Empty'. -- -- @since 2.2.0.0-runNonDet :: OnEmptyPolicy -> Eff (NonDet : es) a -> Eff es (Either CallStack a)+runNonDet+  :: HasCallStack+  => OnEmptyPolicy+  -> Eff (NonDet : es) a+  -> Eff es (Either CallStack a) runNonDet = \case   OnEmptyKeep     -> runNonDetKeep   OnEmptyRollback -> runNonDetRollback -runNonDetKeep :: Eff (NonDet : es) a -> Eff es (Either CallStack a)-runNonDetKeep = reinterpret (fmap noError . runError @()) $ \env -> \case-  Empty       -> throwError ()+runNonDetKeep+  :: HasCallStack+  => Eff (NonDet : es) a+  -> Eff es (Either CallStack a)+runNonDetKeep = reinterpret (fmap noError . runError @ErrorEmpty) $ \env -> \case+  Empty       -> throwError ErrorEmpty   m1 :<|>: m2 -> localSeqUnlift env $ \unlift -> do-    mr <- (Just <$> unlift m1) `catchError` \_ () -> pure Nothing+    mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> pure Nothing     case mr of       Just r  -> pure r       Nothing -> unlift m2 -runNonDetRollback :: Eff (NonDet : es) a -> Eff es (Either CallStack a)-runNonDetRollback = reinterpret (fmap noError . runError @()) $ \env -> \case-  Empty       -> throwError ()+runNonDetRollback+  :: HasCallStack+  => Eff (NonDet : es) a+  -> Eff es (Either CallStack a)+runNonDetRollback = reinterpret setup $ \env -> \case+  Empty       -> throwError ErrorEmpty   m1 :<|>: m2 -> do     backupEnv <- cloneLocalEnv env     localSeqUnlift env $ \unlift -> do-      mr <- (Just <$> unlift m1) `catchError` \_ () -> do+      mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> do         -- If m1 failed, roll back the environment.         restoreLocalEnv env backupEnv         pure Nothing       case mr of         Just r  -> pure r         Nothing -> unlift m2+  where+    setup action = do+      backupEs <- unsafeEff cloneEnv+      runError @ErrorEmpty action >>= \case+        Right r -> pure $ Right r+        Left (cs, _) -> do+          -- If the whole action failed, roll back the environment.+          unsafeEff $ \es -> restoreEnv es backupEs+          pure $ Left cs  ---------------------------------------- @@ -85,7 +109,7 @@ -- -- @since 2.2.0.0 emptyEff :: (HasCallStack, NonDet :> es) => Eff es a-emptyEff = withFrozenCallStack $ send Empty+emptyEff = withFrozenCallStack send Empty  -- | Specialized version of 'asum' with the 'HasCallStack' constraint for -- tracking purposes.@@ -97,16 +121,24 @@ ---------------------------------------- -- Internal helpers +-- | Internal error type for the Empty action. Better than '()' in case it+-- escapes the scope of 'runNonDet' and shows up in error messages.+data ErrorEmpty = ErrorEmpty+instance Show ErrorEmpty where+  show ErrorEmpty = "Effectful.NonDet.ErrorEmpty"+ noError :: Either (cs, e) a -> Either cs a noError = either (Left . fst) Right  cloneLocalEnv-  :: LocalEnv localEs handlerEs+  :: HasCallStack+  => LocalEnv localEs handlerEs   -> Eff es (LocalEnv localEs handlerEs) cloneLocalEnv = coerce . unsafeEff_ . cloneEnv . coerce  restoreLocalEnv-  :: LocalEnv localEs handlerEs+  :: HasCallStack+  => LocalEnv localEs handlerEs   -> LocalEnv localEs handlerEs   -> Eff es () restoreLocalEnv dest src = unsafeEff_ $ restoreEnv (coerce dest) (coerce src)

@@ -1,3 +1,4 @@+{-# LANGUAGE ImplicitParams #-} -- | Turn an effect handler into an effectful operation. -- -- @since 2.3.0.0@@ -25,6 +26,7 @@ import Data.Functor.Identity import Data.Kind (Type) import Data.Primitive.PrimArray+import GHC.Stack  import Effectful import Effectful.Dispatch.Static@@ -35,9 +37,9 @@ -- $example -- -- >>> import Control.Monad.IO.Class+-- >>> import Data.Map.Strict qualified as M -- >>> import Effectful.Dispatch.Dynamic -- >>> import Effectful.State.Static.Local--- >>> import qualified Data.Map.Strict as M -- -- Given an effect: --@@ -74,7 +76,7 @@ --     => FilePath --     -> Eff (Write : es) a --     -> Eff es a---   runWriteIO fp = interpret $ \_ -> \case+--   runWriteIO fp = interpret_ $ \case --     Write msg -> liftIO . putStrLn $ fp ++ ": " ++ msg -- :} --@@ -84,7 +86,7 @@ --     => FilePath --     -> Eff (Write : es) a --     -> Eff es a---   runWritePure fp = interpret $ \_ -> \case+--   runWritePure fp = interpret_ $ \case --     Write msg -> modify $ M.insertWith (++) fp [msg] -- :} --@@ -122,55 +124,64 @@ type instance DispatchOf (Provider e input f) = Static NoSideEffects  data instance StaticRep (Provider e input f) where-  Provider :: !(Env handlerEs)-           -> !(forall r. input -> Eff (e : handlerEs) r -> Eff handlerEs (f r))-           -> StaticRep (Provider e input f)+  Provider+    :: !(Env handlerEs)+    -> !(forall r. HasCallStack => input -> Eff (e : handlerEs) r -> Eff handlerEs (f r))+    -> StaticRep (Provider e input f)  -- | Run the 'Provider' effect with a given effect handler. runProvider-  :: (forall r. input -> Eff (e : es) r -> Eff es (f r))+  :: HasCallStack+  => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r))   -- ^ The effect handler.   -> Eff (Provider e input f : es) a   -> Eff es a-runProvider run m = unsafeEff $ \es0 -> do+runProvider provider m = unsafeEff $ \es0 -> do   inlineBracket-    (consEnv (Provider es0 run) relinkProvider es0)+    (consEnv (mkProvider es0) relinkProvider es0)     unconsEnv     (\es -> unEff m es)+  where+    -- Corresponds to withFrozenCallStack in provideWith.+    mkProvider es = Provider es (let ?callStack = thawCallStack ?callStack in provider)  -- | Run the 'Provider' effect with a given effect handler that doesn't change -- its return type. runProvider_-  :: (forall r. input -> Eff (e : es) r -> Eff es r)+  :: HasCallStack+  => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r)   -- ^ The effect handler.   -> Eff (Provider_ e input : es) a   -> Eff es a-runProvider_ run = runProvider $ \input -> coerce . run input+runProvider_ provider = runProvider $ \input -> coerce . provider input  -- | Run the effect handler.-provide :: Provider e () f :> es => Eff (e : es) a -> Eff es (f a)+provide :: (HasCallStack, Provider e () f :> es) => Eff (e : es) a -> Eff es (f a) provide = provideWith ()  -- | Run the effect handler with unchanged return type.-provide_ :: Provider_ e () :> es => Eff (e : es) a -> Eff es a+provide_ :: (HasCallStack, Provider_ e () :> es) => Eff (e : es) a -> Eff es a provide_ = provideWith_ ()  -- | Run the effect handler with a given input. provideWith-  :: Provider e input f :> es+  :: (HasCallStack, Provider e input f :> es)   => input   -- ^ The input to the effect handler.   -> Eff (e : es) a   -> Eff es (f a) provideWith input action = unsafeEff $ \es -> do-  Provider handlerEs run <- getEnv es-  (`unEff` handlerEs) . run input . unsafeEff $ \eHandlerEs -> do-    unEff action =<< copyRef eHandlerEs es+  Provider handlerEs handler <- getEnv es+  (`unEff` handlerEs)+    -- Corresponds to thawCallStack in runProvider.+    . withFrozenCallStack handler input+    . unsafeEff $ \eProviderEs -> do+    unEff action =<< copyRef eProviderEs es  -- | Run the effect handler that doesn't change its return type with a given -- input. provideWith_-  :: Provider_ e input :> es+  :: (HasCallStack, Provider_ e input :> es)   => input   -- ^ The input to the effect handler.   -> Eff (e : es) a@@ -188,13 +199,17 @@   newHandlerEs <- relink handlerEs   pure $ Provider newHandlerEs run -copyRef :: Env (e : handlerEs) -> Env es -> IO (Env (e : es))+copyRef+  :: HasCallStack+  => Env (e : handlerEs)+  -> Env es+  -> IO (Env (e : es)) copyRef (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do   when (hstorage /= storage) $ do     error "storages do not match"   let size = sizeofPrimArray refs0 - offset-  mrefs <- newPrimArray (size + 2)-  copyPrimArray mrefs 0 hrefs hoffset 2-  copyPrimArray mrefs 2 refs0 offset size+  mrefs <- newPrimArray (size + 1)+  writePrimArray mrefs 0 $ indexPrimArray hrefs hoffset+  copyPrimArray mrefs 1 refs0 offset size   refs <- unsafeFreezePrimArray mrefs   pure $ Env 0 refs storage

@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ImplicitParams #-} -- | Turn a handler of multiple effects into an effectful operation. -- -- Generalizes "Effectful.Provider".@@ -28,6 +29,7 @@ import Data.Coerce import Data.Functor.Identity import Data.Primitive.PrimArray+import GHC.Stack  import Effectful import Effectful.Dispatch.Static@@ -36,86 +38,95 @@ import Effectful.Internal.Env (Env(..)) import Effectful.Internal.Utils --- | Provide a way to run a handler of multiple @effects@ with a given @input@.+-- | Provide a way to run a handler of multiple @providedEs@ with a given+-- @input@. -- -- /Note:/ @f@ can be used to alter the return type of the handler. If that's -- unnecessary, use 'ProviderList_'.-data ProviderList (effects :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect+data ProviderList (providedEs :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect  -- | A restricted variant of 'ProviderList' with unchanged return type of the -- handler.-type ProviderList_ effs input = ProviderList effs input Identity+type ProviderList_ providedEs input = ProviderList providedEs input Identity -type instance DispatchOf (ProviderList effs input f) = Static NoSideEffects+type instance DispatchOf (ProviderList providedEs input f) = Static NoSideEffects -data instance StaticRep (ProviderList effs input f) where+data instance StaticRep (ProviderList providedEs input f) where   ProviderList-    :: KnownEffects effs+    :: KnownEffects providedEs     => !(Env handlerEs)-    -> !(forall r. input -> Eff (effs ++ handlerEs) r -> Eff handlerEs (f r))-    -> StaticRep (ProviderList effs input f)+    -> !(forall r. HasCallStack => input -> Eff (providedEs ++ handlerEs) r -> Eff handlerEs (f r))+    -> StaticRep (ProviderList providedEs input f)  -- | Run the 'ProviderList' effect with a given handler. runProviderList-  :: KnownEffects effs-  => (forall r. input -> Eff (effs ++ es) r -> Eff es (f r))+  :: (HasCallStack, KnownEffects providedEs)+  => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r))   -- ^ The handler.-  -> Eff (ProviderList effs input f : es) a+  -> Eff (ProviderList providedEs input f : es) a   -> Eff es a-runProviderList run m = unsafeEff $ \es0 -> do+runProviderList providerList m = unsafeEff $ \es0 -> do   inlineBracket-    (consEnv (ProviderList es0 run) relinkProviderList es0)+    (consEnv (mkProviderList es0) relinkProviderList es0)     unconsEnv     (\es -> unEff m es)+  where+    -- Corresponds to withFrozenCallStack in provideListWith.+    mkProviderList es =+      ProviderList es (let ?callStack = thawCallStack ?callStack in providerList)  -- | Run the 'Provider' effect with a given handler that doesn't change its -- return type. runProviderList_-  :: KnownEffects effs-  => (forall r. input -> Eff (effs ++ es) r -> Eff es r)+  :: (HasCallStack, KnownEffects providedEs)+  => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r)   -- ^ The handler.-  -> Eff (ProviderList_ effs input : es) a+  -> Eff (ProviderList_ providedEs input : es) a   -> Eff es a-runProviderList_ run = runProviderList $ \input -> coerce . run input+runProviderList_ providerList = runProviderList $ \input -> coerce . providerList input  -- | Run the handler. provideList-  :: forall effs f es a-   . ProviderList effs () f :> es-  => Eff (effs ++ es) a+  :: forall providedEs f es a+   . (HasCallStack, ProviderList providedEs () f :> es)+  => Eff (providedEs ++ es) a   -> Eff es (f a)-provideList = provideListWith @effs ()+provideList = provideListWith @providedEs ()  -- | Run the handler with unchanged return type. provideList_-  :: forall effs es a-   . ProviderList_ effs () :> es-  => Eff (effs ++ es) a+  :: forall providedEs es a+   . (HasCallStack, ProviderList_ providedEs () :> es)+  => Eff (providedEs ++ es) a   -> Eff es a-provideList_ = provideListWith_ @effs ()+provideList_ = provideListWith_ @providedEs ()  -- | Run the handler with a given input. provideListWith-  :: forall effs input f es a-   . ProviderList effs input f :> es+  :: forall providedEs input f es a+   . (HasCallStack, ProviderList providedEs input f :> es)   => input   -- ^ The input to the handler.-  -> Eff (effs ++ es) a+  -> Eff (providedEs ++ es) a   -> Eff es (f a) provideListWith input action = unsafeEff $ \es -> do-  ProviderList (handlerEs :: Env handlerEs) run <- getEnv @(ProviderList effs input f) es-  (`unEff` handlerEs) . run input . unsafeEff $ \eHandlerEs -> do-    unEff action =<< copyRefs @effs @handlerEs eHandlerEs es+  ProviderList (handlerEs :: Env handlerEs) providerList <- do+    getEnv @(ProviderList providedEs input f) es+  (`unEff` handlerEs)+    -- Corresponds to a thawCallStack in runProviderList.+    . withFrozenCallStack providerList input+    . unsafeEff $ \eHandlerEs -> do+    unEff action =<< copyRefs @providedEs @handlerEs eHandlerEs es  -- | Run the handler that doesn't change its return type with a given input. provideListWith_-  :: forall effs input es a-   . ProviderList_ effs input :> es+  :: forall providedEs input es a+   . (HasCallStack, ProviderList_ providedEs input :> es)   => input   -- ^ The input to the handler.-  -> Eff (effs ++ es) a+  -> Eff (providedEs ++ es) a   -> Eff es a-provideListWith_ input = adapt . provideListWith @effs input+provideListWith_ input = adapt . provideListWith @providedEs input   where     adapt :: Eff es (Identity a) -> Eff es a     adapt = coerce@@ -129,18 +140,18 @@   pure $ ProviderList newHandlerEs run  copyRefs-  :: forall effs handlerEs es-   . KnownEffects effs-  => Env (effs ++ handlerEs)+  :: forall providedEs handlerEs es+   . (HasCallStack, KnownEffects providedEs)+  => Env (providedEs ++ handlerEs)   -> Env es-  -> IO (Env (effs ++ es))+  -> IO (Env (providedEs ++ es)) copyRefs (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do   when (hstorage /= storage) $ do     error "storages do not match"-  let size = sizeofPrimArray refs0 - offset-      effsSize = 2 * knownEffectsLength @effs-  mrefs <- newPrimArray (size + effsSize)-  copyPrimArray mrefs 0 hrefs hoffset effsSize-  copyPrimArray mrefs effsSize refs0 offset size+  let providedEsSize = knownEffectsLength @providedEs+      esSize = sizeofPrimArray refs0 - offset+  mrefs <- newPrimArray (providedEsSize + esSize)+  copyPrimArray mrefs 0 hrefs hoffset providedEsSize+  copyPrimArray mrefs providedEsSize refs0 offset esSize   refs <- unsafeFreezePrimArray mrefs   pure $ Env 0 refs storage

@@ -30,7 +30,8 @@ -- | Run the 'Reader' effect with the given initial environment (via -- "Effectful.Reader.Static"). runReader-  :: r -- ^ The initial environment.+  :: HasCallStack+  => r -- ^ The initial environment.   -> Eff (Reader r : es) a   -> Eff es a runReader r = reinterpret (R.runReader r) $ \env -> \case@@ -41,7 +42,8 @@ -- -- @since 1.1.0.0 withReader-  :: (r1 -> r2)+  :: HasCallStack+  => (r1 -> r2)   -- ^ The function to modify the environment.   -> Eff (Reader r2 : es) a   -- ^ Computation to run in the modified environment.

@@ -13,19 +13,22 @@   , local   ) where +import Data.Kind+ import Effectful import Effectful.Dispatch.Static  -- | Provide access to a strict (WHNF), thread local, read only value of type -- @r@.-data Reader r :: Effect+data Reader (r :: Type) :: Effect  type instance DispatchOf (Reader r) = Static NoSideEffects newtype instance StaticRep (Reader r) = Reader r  -- | Run a 'Reader' effect with the given initial environment. runReader-  :: r -- ^ The initial environment.+  :: HasCallStack+  => r -- ^ The initial environment.   -> Eff (Reader r : es) a   -> Eff es a runReader r = evalStaticRep (Reader r)@@ -34,7 +37,8 @@ -- -- @since 1.1.0.0 withReader-  :: (r1 -> r2)+  :: HasCallStack+  => (r1 -> r2)   -- ^ The function to modify the environment.   -> Eff (Reader r2 : es) a   -- ^ Computation to run in the modified environment.@@ -44,7 +48,7 @@   raise $ runReader (f r) m  -- | Fetch the value of the environment.-ask :: Reader r :> es => Eff es r+ask :: (HasCallStack, Reader r :> es) => Eff es r ask = do   Reader r <- getStaticRep   pure r@@ -53,7 +57,7 @@ -- -- @'asks' f ≡ f '<$>' 'ask'@ asks-  :: Reader r :> es+  :: (HasCallStack, Reader r :> es)   => (r -> a) -- ^ The function to apply to the environment.   -> Eff es a asks f = f <$> ask@@ -63,7 +67,7 @@ -- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@ -- local-  :: Reader r :> es+  :: (HasCallStack, Reader r :> es)   => (r -> r) -- ^ The function to modify the environment.   -> Eff es a   -> Eff es a

@@ -48,24 +48,20 @@  -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state (via "Effectful.State.Static.Local").-runStateLocal :: s -> Eff (State s : es) a -> Eff es (a, s)+runStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runStateLocal s0 = reinterpret (L.runState s0) localState  -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state (via "Effectful.State.Static.Local").-evalStateLocal :: s -> Eff (State s : es) a -> Eff es a+evalStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalStateLocal s0 = reinterpret (L.evalState s0) localState  -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value (via "Effectful.State.Static.Local").-execStateLocal :: s -> Eff (State s : es) a -> Eff es s+execStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execStateLocal s0 = reinterpret (L.execState s0) localState -localState-  :: L.State s :> es-  => LocalEnv localEs es-  -> State s (Eff localEs) a-  -> Eff es a+localState :: L.State s :> es => EffectHandler (State s) es localState env = \case   Get      -> L.get   Put s    -> L.put s@@ -77,24 +73,20 @@  -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state (via "Effectful.State.Static.Shared").-runStateShared :: s -> Eff (State s : es) a -> Eff es (a, s)+runStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runStateShared s0 = reinterpret (S.runState s0) sharedState  -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state (via "Effectful.State.Static.Shared").-evalStateShared :: s -> Eff (State s : es) a -> Eff es a+evalStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalStateShared s0 = reinterpret (S.evalState s0) sharedState  -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value (via "Effectful.State.Static.Shared").-execStateShared :: s -> Eff (State s : es) a -> Eff es s+execStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execStateShared s0 = reinterpret (S.execState s0) sharedState -sharedState-  :: S.State s :> es-  => LocalEnv localEs es-  -> State s (Eff localEs) a-  -> Eff es a+sharedState :: S.State s :> es => EffectHandler (State s) es sharedState env = \case   Get      -> S.get   Put s    -> S.put s

@@ -7,7 +7,7 @@ -- the @transformers@ library, the 'State' effect doesn't discard state updates -- when an exception is received: ----- >>> import qualified Control.Monad.Trans.State.Strict as S+-- >>> import Control.Monad.Trans.State.Strict qualified as S -- -- >>> :{ --   (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do@@ -41,11 +41,13 @@   , modifyM   ) where +import Data.Kind+ import Effectful import Effectful.Dispatch.Static  -- | Provide access to a strict (WHNF), thread local, mutable value of type @s@.-data State s :: Effect+data State (s :: Type) :: Effect  type instance DispatchOf (State s) = Static NoSideEffects newtype instance StaticRep (State s) = State s@@ -53,7 +55,8 @@ -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state. runState-  :: s -- ^ The initial state.+  :: HasCallStack+  => s -- ^ The initial state.   -> Eff (State s : es) a   -> Eff es (a, s) runState s0 m = do@@ -63,7 +66,8 @@ -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state. evalState-  :: s -- ^ The initial state.+  :: HasCallStack+  => s -- ^ The initial state.   -> Eff (State s : es) a   -> Eff es a evalState s = evalStaticRep (State s)@@ -71,7 +75,8 @@ -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value. execState-  :: s -- ^ The initial state.+  :: HasCallStack+  => s -- ^ The initial state.   -> Eff (State s : es) a   -> Eff es s execState s0 m = do@@ -79,7 +84,7 @@   pure s  -- | Fetch the current value of the state.-get :: State s :> es => Eff es s+get :: (HasCallStack, State s :> es) => Eff es s get = do   State s <- getStaticRep   pure s@@ -88,18 +93,18 @@ -- -- @'gets' f ≡ f '<$>' 'get'@ gets-  :: State s :> es+  :: (HasCallStack, State s :> es)   => (s -> a) -- ^ The function to apply to the state.   -> Eff es a gets f = f <$> get  -- | Set the current state to the given value.-put :: State s :> es => s -> Eff es ()+put :: (HasCallStack, State s :> es) => s -> Eff es () put s = putStaticRep (State s)  -- | Apply the function to the current state and return a value. state-  :: State s :> es+  :: (HasCallStack, State s :> es)   => (s -> (a, s)) -- ^ The function to modify the state.   -> Eff es a state f = stateStaticRep $ \(State s0) -> let (a, s) = f s0 in (a, State s)@@ -108,14 +113,14 @@ -- -- @'modify' f ≡ 'state' (\\s -> ((), f s))@ modify-  :: State s :> es+  :: (HasCallStack, State s :> es)   => (s -> s) -- ^ The function to modify the state.   -> Eff es () modify f = state $ \s -> ((), f s)  -- | Apply the monadic function to the current state and return a value. stateM-  :: State s :> es+  :: (HasCallStack, State s :> es)   => (s -> Eff es (a, s)) -- ^ The function to modify the state.   -> Eff es a stateM f = stateStaticRepM $ \(State s0) -> do@@ -126,11 +131,10 @@ -- -- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ modifyM-  :: State s :> es+  :: (HasCallStack, State s :> es)   => (s -> Eff es s) -- ^ The monadic function to modify the state.   -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s)  -- $setup--- >>> import Control.Exception (ErrorCall)--- >>> import Control.Monad.Catch+-- >>> import Effectful.Exception

@@ -7,7 +7,7 @@ -- the @transformers@ library, the 'State' effect doesn't discard state updates -- when an exception is received: ----- >>> import qualified Control.Monad.Trans.State.Strict as S+-- >>> import Control.Monad.Trans.State.Strict qualified as S -- -- >>> :{ --   (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do@@ -45,22 +45,22 @@   , modifyM   ) where -import Control.Concurrent.MVar+import Control.Concurrent.MVar.Strict+import Data.Kind  import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive-import Effectful.Internal.Utils  -- | Provide access to a strict (WHNF), shared, mutable value of type @s@.-data State s :: Effect+data State (s :: Type) :: Effect  type instance DispatchOf (State s) = Static NoSideEffects newtype instance StaticRep (State s) = State (MVar' s)  -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state.-runState :: s -> Eff (State s : es) a -> Eff es (a, s)+runState :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runState s m = do   v <- unsafeEff_ $ newMVar' s   a <- evalStaticRep (State v) m@@ -68,44 +68,40 @@  -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state.-evalState :: s -> Eff (State s : es) a -> Eff es a+evalState :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalState s m = do   v <- unsafeEff_ $ newMVar' s   evalStaticRep (State v) m  -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value.-execState :: s -> Eff (State s : es) a -> Eff es s+execState :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execState s m = do   v <- unsafeEff_ $ newMVar' s   _ <- evalStaticRep (State v) m   unsafeEff_ $ readMVar' v --- | Run the 'State' effect with the given initial state 'MVar' and return the+-- | Run the 'State' effect with the given initial state 'MVar'' and return the -- final value along with the final state.-runStateMVar :: MVar s -> Eff (State s : es) a -> Eff es (a, s)+runStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es (a, s) runStateMVar v m = do-  v' <- unsafeEff_ $ toMVar' v-  a <- evalStaticRep (State v') m-  (a, ) <$> unsafeEff_ (readMVar v)+  a <- evalStaticRep (State v) m+  (a, ) <$> unsafeEff_ (readMVar' v) --- | Run the 'State' effect with the given initial state 'MVar' and return the+-- | Run the 'State' effect with the given initial state 'MVar'' and return the -- final value, discarding the final state.-evalStateMVar :: MVar s -> Eff (State s : es) a -> Eff es a-evalStateMVar v m = do-  v' <- unsafeEff_ $ toMVar' v-  evalStaticRep (State v') m+evalStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es a+evalStateMVar v = evalStaticRep (State v) --- | Run the 'State' effect with the given initial state 'MVar' and return the+-- | Run the 'State' effect with the given initial state 'MVar'' and return the -- final state, discarding the final value.-execStateMVar :: MVar s -> Eff (State s : es) a -> Eff es s+execStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es s execStateMVar v m = do-  v' <- unsafeEff_ $ toMVar' v-  _ <- evalStaticRep (State v') m-  unsafeEff_ $ readMVar v+  _ <- evalStaticRep (State v) m+  unsafeEff_ $ readMVar' v  -- | Fetch the current value of the state.-get :: State s :> es => Eff es s+get :: (HasCallStack, State s :> es) => Eff es s get = unsafeEff $ \es -> do   State v <- getEnv es   readMVar' v@@ -113,19 +109,19 @@ -- | Get a function of the current state. -- -- @'gets' f ≡ f '<$>' 'get'@-gets :: State s :> es => (s -> a) -> Eff es a+gets :: (HasCallStack, State s :> es) => (s -> a) -> Eff es a gets f = f <$> get  -- | Set the current state to the given value.-put :: State s :> es => s -> Eff es ()+put :: (HasCallStack, State s :> es) => s -> Eff es () put s = unsafeEff $ \es -> do   State v <- getEnv es-  modifyMVar_' v $ \_ -> pure s+  modifyMVar'_ v $ \_ -> pure s  -- | Apply the function to the current state and return a value. -- -- /Note:/ this function gets an exclusive access to the state for its duration.-state :: State s :> es => (s -> (a, s)) -> Eff es a+state :: (HasCallStack, State s :> es) => (s -> (a, s)) -> Eff es a state f = unsafeEff $ \es -> do   State v <- getEnv es   modifyMVar' v $ \s0 -> let (a, s) = f s0 in pure (s, a)@@ -135,13 +131,13 @@ -- @'modify' f ≡ 'state' (\\s -> ((), f s))@ -- -- /Note:/ this function gets an exclusive access to the state for its duration.-modify :: State s :> es => (s -> s) -> Eff es ()+modify :: (HasCallStack, State s :> es) => (s -> s) -> Eff es () modify f = state (\s -> ((), f s))  -- | Apply the monadic function to the current state and return a value. -- -- /Note:/ this function gets an exclusive access to the state for its duration.-stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a+stateM :: (HasCallStack, State s :> es) => (s -> Eff es (a, s)) -> Eff es a stateM f = unsafeEff $ \es -> do   State v <- getEnv es   modifyMVar' v $ \s0 -> do@@ -153,9 +149,8 @@ -- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ -- -- /Note:/ this function gets an exclusive access to the state for its duration.-modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()+modifyM :: (HasCallStack, State s :> es) => (s -> Eff es s) -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s)  -- $setup--- >>> import Control.Exception (ErrorCall)--- >>> import Control.Monad.Catch+-- >>> import Effectful.Exception

@@ -40,19 +40,15 @@  -- | Run the 'Writer' effect and return the final value along with the final -- output (via "Effectful.Writer.Static.Local").-runWriterLocal :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriterLocal :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriterLocal = reinterpret L.runWriter localWriter  -- | Run a 'Writer' effect and return the final output, discarding the final -- value (via "Effectful.Writer.Static.Local").-execWriterLocal :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriterLocal :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriterLocal = reinterpret L.execWriter localWriter -localWriter-  :: (L.Writer w :> es, Monoid w)-  => LocalEnv localEs es-  -> Writer w (Eff localEs) a-  -> Eff es a+localWriter :: (L.Writer w :> es, Monoid w) => EffectHandler (Writer w) es localWriter env = \case   Tell w   -> L.tell w   Listen m -> localSeqUnlift env $ \unlift -> L.listen (unlift m)@@ -62,19 +58,15 @@  -- | Run the 'Writer' effect and return the final value along with the final -- output (via "Effectful.Writer.Static.Shared").-runWriterShared :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriterShared :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriterShared = reinterpret S.runWriter sharedWriter  -- | Run the 'Writer' effect and return the final output, discarding the final -- value (via "Effectful.Writer.Static.Shared").-execWriterShared :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriterShared :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriterShared = reinterpret S.execWriter sharedWriter -sharedWriter-  :: (S.Writer w :> es, Monoid w)-  => LocalEnv localEs es-  -> Writer w (Eff localEs) a-  -> Eff es a+sharedWriter :: (S.Writer w :> es, Monoid w) => EffectHandler (Writer w) es sharedWriter env = \case   Tell w    -> S.tell w   Listen m  -> localSeqUnlift env $ \unlift -> S.listen (unlift m)

@@ -28,6 +28,7 @@   ) where  import Control.Exception (onException, mask)+import Data.Kind  import Effectful import Effectful.Dispatch.Static@@ -35,27 +36,27 @@  -- | Provide access to a strict (WHNF), thread local, write only value of type -- @w@.-data Writer w :: Effect+data Writer (w :: Type) :: Effect  type instance DispatchOf (Writer w) = Static NoSideEffects newtype instance StaticRep (Writer w) = Writer w  -- | Run a 'Writer' effect and return the final value along with the final -- output.-runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriter m = do   (a, Writer w) <- runStaticRep (Writer mempty) m   pure (a, w)  -- | Run a 'Writer' effect and return the final output, discarding the final -- value.-execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriter m = do   Writer w <- execStaticRep (Writer mempty) m   pure w  -- | Append the given output to the overall output of the 'Writer'.-tell :: (Writer w :> es, Monoid w) => w -> Eff es ()+tell :: (HasCallStack, Writer w :> es, Monoid w) => w -> Eff es () tell w = stateStaticRep $ \(Writer w0) -> ((), Writer (w0 <> w))  -- | Execute an action and append its output to the overall output of the@@ -75,26 +76,30 @@ --         error "oops" -- :} -- "Hi there!"-listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)+listen :: (HasCallStack, Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) listen m = unsafeEff $ \es -> mask $ \unmask -> do-  w0 <- stateEnv es $ \(Writer w) -> pure (w, Writer mempty)+  w0 <- stateEnv es $ \(Writer w) -> (w, Writer mempty)   a <- unmask (unEff m es) `onException` merge es w0   (a, ) <$> merge es w0   where     merge es w0 =       -- If an exception is thrown, restore w0 and keep parts of w1.-      stateEnv es $ \(Writer w1) -> pure (w1, Writer (w0 <> w1))+      stateEnv es $ \(Writer w1) -> (w1, Writer (w0 <> w1))  -- | 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 -- output. -- -- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@-listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)+listens+  :: (HasCallStack, Writer w :> es, Monoid w)+  => (w -> b)+  -> Eff es a+  -> Eff es (a, b) listens f m = do   (a, w) <- listen m   pure (a, f w)  -- $setup -- >>> import Control.Exception (ErrorCall)--- >>> import Control.Monad.Catch+-- >>> import Effectful.Exception

@@ -27,22 +27,23 @@   , listens   ) where +import Control.Concurrent.MVar.Strict import Control.Exception (onException, uninterruptibleMask)+import Data.Kind  import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive-import Effectful.Internal.Utils  -- | Provide access to a strict (WHNF), shared, write only value of type @w@.-data Writer w :: Effect+data Writer (w :: Type) :: Effect  type instance DispatchOf (Writer w) = Static NoSideEffects newtype instance StaticRep (Writer w) = Writer (MVar' w)  -- | Run a 'Writer' effect and return the final value along with the final -- output.-runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriter m = do   v <- unsafeEff_ $ newMVar' mempty   a <- evalStaticRep (Writer v) m@@ -50,17 +51,17 @@  -- | Run a 'Writer' effect and return the final output, discarding the final -- value.-execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriter m = do   v <- unsafeEff_ $ newMVar' mempty   _ <- evalStaticRep (Writer v) m   unsafeEff_ $ readMVar' v  -- | Append the given output to the overall output of the 'Writer'.-tell :: (Writer w :> es, Monoid w) => w -> Eff es ()+tell :: (HasCallStack, Writer w :> es, Monoid w) => w -> Eff es () tell w1 = unsafeEff $ \es -> do   Writer v <- getEnv es-  modifyMVar_' v $ \w0 -> let w = w0 <> w1 in pure w+  modifyMVar'_ v $ \w0 -> let w = w0 <> w1 in pure w  -- | Execute an action and append its output to the overall output of the -- 'Writer'.@@ -79,7 +80,7 @@ --         error "oops" -- :} -- "Hi there!"-listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)+listen :: (HasCallStack, Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) listen m = unsafeEff $ \es -> do   -- The mask is uninterruptible because modifyMVar_ v0 in the merge function   -- might block and if an async exception is received while waiting, w1 will be@@ -87,7 +88,7 @@   uninterruptibleMask $ \unmask -> do     v1 <- newMVar' mempty     -- Replace thread local MVar with a fresh one for isolated listening.-    v0 <- stateEnv es $ \(Writer v) -> pure (v, Writer v1)+    v0 <- stateEnv es $ \(Writer v) -> (v, Writer v1)     a <- unmask (unEff m es) `onException` merge es v0 v1     (a, ) <$> merge es v0 v1   where@@ -96,7 +97,7 @@     merge es v0 v1 = do       putEnv es $ Writer v0       w1 <- readMVar' v1-      modifyMVar_' v0 $ \w0 -> let w = w0 <> w1 in pure w+      modifyMVar'_ v0 $ \w0 -> let w = w0 <> w1 in pure w       pure w1  -- | Execute an action and append its output to the overall output of the@@ -104,11 +105,15 @@ -- output. -- -- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@-listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)+listens+  :: (HasCallStack, Writer w :> es, Monoid w)+  => (w -> b)+  -> Eff es a+  -> Eff es (a, b) listens f m = do   (a, w) <- listen m   pure (a, f w)  -- $setup -- >>> import Control.Exception (ErrorCall)--- >>> import Control.Monad.Catch+-- >>> import Effectful.Exception