effectful-core 2.4.0.0 → 2.5.0.0

raw patch · 10 files changed

+693/−190 lines, 10 filesdep −safe-exceptionsdep ~primitivePVP ok

version bump matches the API change (PVP)

Dependencies removed: safe-exceptions

Dependency ranges changed: primitive

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• effectful-core.cabal +1/−2
• src/Effectful/Dispatch/Static/Primitive.hs +0/−1
• src/Effectful/Error/Static.hs +20/−41
• src/Effectful/Exception.hs +554/−62
• src/Effectful/Internal/Env.hs +74/−54
• src/Effectful/Internal/Monad.hs +2/−0
• src/Effectful/NonDet.hs +24/−24
• src/Effectful/State/Static/Local.hs +2/−3
• src/Effectful/State/Static/Shared.hs +2/−3

@@ -1,3 +1,17 @@+# effectful-core-2.5.0.0 (2024-10-23)+* Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make+  `emptyEff` and `sumEff` generate better call stacks.+* Explicitly define `setByteArray#` and `setOffAddr#` in the `Prim` instance of+  `Ref` for `primitive` < 0.9.0.0.+* **Bugfixes**:+  - `OnEmptyRollback` strategy of the `NonDet` effect is no longer broken.+* **Breaking changes**:+  - Remove `restoreEnv` function from `Effectful.Dispatch.Static.Primitive`+    since it was broken.+  - Base `Effectful.Exception` on `Control.Exception` instead of the+    `safe-exceptions` library for consistency with provided `MonadThrow` and+    `MonadCatch` instances.+ # 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`.

@@ -1,7 +1,7 @@ cabal-version:      3.0 build-type:         Simple name:               effectful-core-version:            2.4.0.0+version:            2.5.0.0 license:            BSD-3-Clause license-file:       LICENSE category:           Control@@ -72,7 +72,6 @@                     , 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

@@ -31,7 +31,6 @@     -- ** Utils   , emptyEnv   , cloneEnv-  , restoreEnv   , sizeEnv   , tailEnv   ) where

@@ -100,13 +100,12 @@   , prettyCallStack   ) where -import Control.Exception import Data.Kind import GHC.Stack  import Effectful import Effectful.Dispatch.Static-import Effectful.Dispatch.Static.Primitive+import Effectful.Exception import Effectful.Internal.Utils  -- | Provide the ability to handle errors of type @e@.@@ -121,17 +120,10 @@    . HasCallStack   => Eff (Error e : es) a   -> Eff es (Either (CallStack, e) a)-runError m = unsafeEff $ \es0 -> mask $ \unmask -> do-  eid <- newErrorId-  es <- consEnv (Error @e eid) dummyRelinker es0-  r <- tryErrorIO unmask eid es `onException` unconsEnv es-  unconsEnv es-  pure r-  where-    tryErrorIO unmask eid es = try (unmask $ unEff m es) >>= \case-      Right a -> pure $ Right a-      Left ex -> tryHandler ex eid (\cs e -> Left (cs, e))-               $ throwIO ex+runError action = do+  eid <- unsafeEff_ newErrorId+  evalStaticRep (Error @e eid) $ do+    tryJust (matchError eid) action  -- | Handle errors of type @e@ with a specific error handler. --@@ -142,7 +134,7 @@   -- ^ The error handler.   -> Eff (Error e : es) a   -> Eff es a-runErrorWith handler m = runError m >>= \case+runErrorWith handler action = runError action >>= \case   Left (cs, e) -> handler cs e   Right a -> pure a @@ -164,7 +156,7 @@   -- ^ The error handler.   -> Eff (Error e : es) a   -> Eff es a-runErrorNoCallStackWith handler m = runErrorNoCallStack m >>= \case+runErrorNoCallStackWith handler action = runErrorNoCallStack action >>= \case   Left e -> handler e   Right a -> pure a @@ -179,9 +171,9 @@   -> 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)+throwErrorWith display e = do+  Error eid <- getStaticRep @(Error e)+  withFrozenCallStack throwIO $ ErrorWrapper eid callStack (display e) (toAny e)  -- | Throw an error of type @e@ with 'show' as a display function. throwError@@ -209,10 +201,9 @@   -> (CallStack -> e -> Eff es a)   -- ^ A handler for errors in the inner computation.   -> Eff es a-catchError m handler = unsafeEff $ \es -> do-  Error eid <- getEnv @(Error e) es-  catchErrorIO eid (unEff m es) $ \cs e -> do-    unEff (handler cs e) es+catchError action handler = do+  Error eid <- getStaticRep @(Error e)+  catchJust (matchError eid) action $ \(cs, e) -> handler cs e  -- | The same as @'flip' 'catchError'@, which is useful in situations where the -- code for the handler is shorter.@@ -232,7 +223,9 @@   => Eff es a   -- ^ The inner computation.   -> Eff es (Either (CallStack, e) a)-tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)+tryError action = do+  Error eid <- getStaticRep @(Error e)+  tryJust (matchError eid) action  ---------------------------------------- -- Helpers@@ -245,18 +238,6 @@ newErrorId :: IO ErrorId newErrorId = ErrorId <$> newUnique -tryHandler-  :: SomeException-  -> ErrorId-  -> (CallStack -> e -> r)-  -> IO r-  -> IO r-tryHandler ex eid0 handler next = case fromException ex of-  Just (ErrorWrapper eid cs _ e)-    | eid0 == eid -> pure $ handler cs (fromAny e)-    | otherwise   -> next-  Nothing -> next- data ErrorWrapper = ErrorWrapper !ErrorId CallStack String Any  instance Show ErrorWrapper where@@ -268,9 +249,7 @@  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-    if eid == etag-      then handler cs (fromAny e)-      else throwIO err+matchError :: ErrorId -> ErrorWrapper -> Maybe (CallStack, e)+matchError eid (ErrorWrapper etag cs _ e)+  | eid == etag = Just (cs, fromAny e)+  | otherwise = Nothing

@@ -1,80 +1,93 @@--- | 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.+{-# LANGUAGE CPP #-}+-- | Support for runtime exceptions. ----- 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.+-- This module supplies thin wrappers over functions from "Control.Exception" as+-- well as several utility functions for convenience.+--+-- /Note:/ the 'Eff' monad provides instances for 'C.MonadThrow', 'C.MonadCatch'+-- and 'C.MonadMask', so any existing code that uses them remains compatible. module Effectful.Exception   ( -- * Throwing-    C.MonadThrow(..)-  , Safe.throwString-  , Safe.StringException(..)+    throwIO+#if MIN_VERSION_base(4,21,0)+  , rethrowIO+#endif      -- * Catching (with recovery)-  , C.MonadCatch(..)-  , Safe.catchIO-  , Safe.catchIOError-  , Safe.catchAny-  , Safe.catchDeep-  , Safe.catchAnyDeep-  , Safe.catchAsync-  , Safe.catchJust+    -- $catchAll+  , catch+#if MIN_VERSION_base(4,21,0)+  , catchNoPropagate+#endif+  , catchDeep+  , catchJust+  , catchIf+  , catchIO+  , catchSync+  , catchSyncDeep -  , Safe.handle-  , Safe.handleIO-  , Safe.handleIOError-  , Safe.handleAny-  , Safe.handleDeep-  , Safe.handleAnyDeep-  , Safe.handleAsync-  , Safe.handleJust+  , handle+  , handleDeep+  , handleJust+  , handleIf+  , handleIO+  , handleSync+  , handleSyncDeep -  , Safe.try-  , Safe.tryIO-  , Safe.tryAny-  , Safe.tryDeep-  , Safe.tryAnyDeep-  , Safe.tryAsync-  , Safe.tryJust+  , try+#if MIN_VERSION_base(4,21,0)+  , tryWithContext+#endif+  , tryDeep+  , tryJust+  , tryIf+  , tryIO+  , trySync+  , trySyncDeep -  , Safe.Handler(..)-  , Safe.catches-  , Safe.catchesDeep-  , Safe.catchesAsync+  , C.Handler(..)+  , catches+  , catchesDeep +    -- | #cleanup#+     -- * Cleanup (no recovery)-  , C.MonadMask(..)+  , bracket+  , bracket_+  , bracketOnError+  , generalBracket   , 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+  , finally+  , onException -    -- ** Check exception type-  , Safe.isSyncException-  , Safe.isAsyncException+    -- * Utils      -- ** Evaluation   , evaluate   , evaluateDeep +#if MIN_VERSION_base(4,20,0)+    -- ** Annotations+  , annotateIO+#endif++    -- | #checkExceptionType#++    -- ** Check exception type+    -- $syncVsAsync+  , isSyncException+  , isAsyncException++    -- * Low-level API+  , mask+  , mask_+  , uninterruptibleMask+  , uninterruptibleMask_+  , E.MaskingState(..)+  , getMaskingState+  , interruptible+  , allowInterrupt+     -- * Re-exports from "Control.Exception"      -- ** The 'SomeException' type@@ -82,7 +95,26 @@      -- ** The 'Exception' class   , E.Exception(..)+  , E.mapException +#if MIN_VERSION_base(4,20,0)+    -- ** Exception context and annotation+  , E.addExceptionContext+  , E.someExceptionContext+  , E.ExceptionWithContext(..)+#if MIN_VERSION_base(4,21,0)+  , E.WhileHandling(..)+#endif+  , E.ExceptionContext(..)+  , E.emptyExceptionContext+  , E.addExceptionAnnotation+  , E.getExceptionAnnotations+  , E.getAllExceptionAnnotations+  , E.displayExceptionContext+  , E.SomeExceptionAnnotation(..)+  , E.ExceptionAnnotation(..)+#endif+     -- ** Concrete exception types   , E.IOException   , E.ArithException(..)@@ -113,18 +145,478 @@   , E.assert   ) where +#if MIN_VERSION_base(4,20,0)+import Control.Exception.Annotation qualified as E+import Control.Exception.Context qualified as E+#endif+ import Control.DeepSeq import Control.Exception qualified as E-import Control.Exception.Safe qualified as Safe import Control.Monad.Catch qualified as C+import GHC.Stack (withFrozenCallStack)  import Effectful import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Unsafe --- | Lifted version of 'E.evaluate'.+----------------------------------------+-- Throwing++-- | Lifted 'E.throwIO'.+throwIO+  :: (HasCallStack, E.Exception e)+  => e+  -- ^ The error.+  -> Eff es a+throwIO = unsafeEff_ . withFrozenCallStack E.throwIO++#if MIN_VERSION_base(4,21,0)+-- | Lifted 'E.rethrowIO'.+rethrowIO+  :: E.Exception e+  => E.ExceptionWithContext e+  -> Eff es a+rethrowIO = unsafeEff_ . E.rethrowIO+#endif++----------------------------------------+-- Catching++-- $catchAll+--+-- /Note:/ __do not use 'catch', 'handle' or 'try' to catch 'E.SomeException'__+-- unless you're really sure you want to catch __all__ exceptions (including+-- asynchronous ones). Instead:+--+-- - If you want to catch all exceptions, run a cleanup action and rethrow, use+--   one of the functions from the [cleanup](#cleanup) section.+--+-- - If you want to catch all synchronous exceptions, use 'catchSync',+--   'handleSync' or 'trySync'.++-- | Lifted 'E.catch'.+catch+  :: E.Exception e+  => Eff es a+  -> (e -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+catch action handler = reallyUnsafeUnliftIO $ \unlift -> do+  E.catch (unlift action) (unlift . handler)++-- | A variant of 'catch' that fully forces evaluation of the result value to+-- find all impure exceptions.+catchDeep+  :: (E.Exception e, NFData a)+  => Eff es a+  -> (e -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+catchDeep action = catch (evaluateDeep =<< action)++#if MIN_VERSION_base(4,21,0)+-- | Lifted 'E.catchNoPropagate'.+catchNoPropagate+  :: E.Exception e+  => Eff es a+  -> (E.ExceptionWithContext e -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+catchNoPropagate action handler = reallyUnsafeUnliftIO $ \unlift -> do+  E.catchNoPropagate (unlift action) (unlift . handler)+#endif++-- | Lifted 'E.catchJust'.+catchJust+  :: E.Exception e+  => (e -> Maybe b)+  -- ^ The predicate.+  -> Eff es a+  -> (b -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+catchJust f action handler = reallyUnsafeUnliftIO $ \unlift -> do+  E.catchJust f (unlift action) (unlift . handler)++-- | Catch an exception only if it satisfies a specific predicate.+catchIf+  :: E.Exception e+  => (e -> Bool)+  -- ^ The predicate.+  -> Eff es a+  -> (e -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+catchIf p = catchJust (\e -> if p e then Just e else Nothing)++-- | 'catch' specialized to catch 'IOException'.+catchIO+  :: Eff es a+  -> (E.IOException -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+catchIO = catch++-- | 'catch' specialized to catch all exceptions considered to be synchronous.+--+-- @'catchSync' ≡ 'catchIf' \@'E.SomeException' 'isSyncException'@+--+-- See the [check exception type](#checkExceptionType) section for more+-- information.+catchSync+  :: Eff es a+  -> (E.SomeException -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+catchSync = catchIf @E.SomeException isSyncException++-- | A variant of 'catchSync' that fully forces evaluation of the result value+-- to find all impure exceptions.+catchSyncDeep+  :: NFData a+  => Eff es a+  -> (E.SomeException -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+catchSyncDeep action = catchSync (evaluateDeep =<< action)++-- | Flipped version of 'catch'.+handle+  :: E.Exception e+  => (e -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+  -> Eff es a+handle = flip catch++-- | Flipped version of 'catchDeep'.+handleDeep+  :: (E.Exception e, NFData a)+  => (e -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+  -> Eff es a+handleDeep = flip catchDeep++-- | Flipped version of 'catchJust'.+handleJust+  :: (HasCallStack, E.Exception e)+  => (e -> Maybe b)+  -- ^ The predicate.+  -> (b -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+  -> Eff es a+handleJust f = flip (catchJust f)++-- | Flipped version of 'catchIf'.+handleIf+  :: E.Exception e+  => (e -> Bool)+  -- ^ The predicate.+  -> (e -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+  -> Eff es a+handleIf p = flip (catchIf p)++-- | Flipped version of 'catchIO'.+handleIO+  :: (E.IOException -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+  -> Eff es a+handleIO = flip catchIO++-- | Flipped version of 'catchSync'.+handleSync+  :: (E.SomeException -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+  -> Eff es a+handleSync = flip catchSync++-- | Flipped version of 'catchSyncDeep'.+handleSyncDeep+  :: NFData a+  => (E.SomeException -> Eff es a)+  -- ^ The exception handler.+  -> Eff es a+  -> Eff es a+handleSyncDeep = flip catchSyncDeep++-- | Lifted 'E.try'.+try+  :: E.Exception e+  => Eff es a+  -- ^ The action.+  -> Eff es (Either e a)+try action = reallyUnsafeUnliftIO $ \unlift -> do+  E.try (unlift action)++#if MIN_VERSION_base(4,21,0)+-- | Lifted 'E.tryWithContext'.+tryWithContext+  :: E.Exception e+  => Eff es a+  -> Eff es (Either (E.ExceptionWithContext e) a)+tryWithContext action = reallyUnsafeUnliftIO $ \unlift -> do+  E.tryWithContext (unlift action)+#endif++-- | A variant of 'try' that fully forces evaluation of the result value to find+-- all impure exceptions.+tryDeep+  :: (E.Exception e, NFData a)+  => Eff es a+  -- ^ The action.+  -> Eff es (Either e a)+tryDeep action = try (evaluateDeep =<< action)++-- | Lifted 'E.tryJust'.+tryJust+  :: E.Exception e+  => (e -> Maybe b)+  -- ^ The predicate.+  -> Eff es a+  -> Eff es (Either b a)+tryJust f action = reallyUnsafeUnliftIO $ \unlift -> do+  E.tryJust f (unlift action)++-- | Catch an exception only if it satisfies a specific predicate.+tryIf+  :: E.Exception e+  => (e -> Bool)+  -- ^ The predicate.+  -> Eff es a+  -> Eff es (Either e a)+tryIf p = tryJust (\e -> if p e then Just e else Nothing)++-- | 'try' specialized to catch 'IOException'.+tryIO+  :: Eff es a+  -- ^ The action.+  -> Eff es (Either E.IOException a)+tryIO = try++-- | 'try' specialized to catch all exceptions considered to be synchronous.+--+-- @'trySync' ≡ 'tryIf' \@'E.SomeException' 'isSyncException'@+--+-- See the [check exception type](#checkExceptionType) section for more+-- information.+trySync+  :: Eff es a+  -- ^ The action.+  -> Eff es (Either E.SomeException a)+trySync = tryIf @E.SomeException isSyncException++-- | A variant of 'trySync' that fully forces evaluation of the result value to+-- find all impure exceptions.+trySyncDeep+  :: NFData a+  => Eff es a+  -- ^ The action.+  -> Eff es (Either E.SomeException a)+trySyncDeep action = trySync (evaluateDeep =<< action)++-- | Lifted 'E.catches'.+catches+  :: Eff es a+  -> [C.Handler (Eff es) a]+  -- ^ The exception handlers.+  -> Eff es a+catches action handlers = reallyUnsafeUnliftIO $ \unlift -> do+  let unliftHandler (C.Handler handler) = E.Handler (unlift . handler)+  E.catches (unlift action) (map unliftHandler handlers)++-- | A variant of 'catches' that fully forces evaluation of the result value to+-- find all impure exceptions.+catchesDeep+  :: NFData a+  => Eff es a+  -> [C.Handler (Eff es) a]+  -- ^ The exception handlers.+  -> Eff es a+catchesDeep action = catches (evaluateDeep =<< action)++----------------------------------------+-- Cleanup++-- | Lifted 'E.bracket'.+bracket+  :: Eff es a+  -- ^ Computation to run first.+  -> (a -> Eff es b)+  -- ^ Computation to run last.+  -> (a -> Eff es c)+  -- ^ Computation to run in-between.+  -> Eff es c+bracket before after action = reallyUnsafeUnliftIO $ \unlift -> do+  E.bracket (unlift before) (unlift . after) (unlift . action)++-- | Lifted 'E.bracket_'.+bracket_+  :: Eff es a+  -- ^ Computation to run first.+  -> Eff es b+  -- ^ Computation to run last.+  -> Eff es c+  -- ^ Computation to run in-between.+  -> Eff es c+bracket_ before after action = reallyUnsafeUnliftIO $ \unlift -> do+  E.bracket_ (unlift before) (unlift after) (unlift action)++-- | Lifted 'E.bracketOnError'.+bracketOnError+  :: Eff es a+  -- ^ Computation to run first.+  -> (a -> Eff es b)+  -- ^ Computation to run last when an exception or+  -- t'Effectful.Error.Static.Error' was thrown.+  -> (a -> Eff es c)+  -- ^ Computation to run in-between.+  -> Eff es c+bracketOnError before after action = reallyUnsafeUnliftIO $ \unlift -> do+  E.bracketOnError (unlift before) (unlift . after) (unlift . action)++-- | Generalization of 'bracket'.+--+-- See 'C.generalBracket' for more information.+generalBracket+  :: Eff es a+  -- ^ Computation to run first.+  -> (a -> C.ExitCase c -> Eff es b)+  -- ^ Computation to run last.+  -> (a -> Eff es c)+  -- ^ Computation to run in-between.+  -> Eff es (c, b)+generalBracket = C.generalBracket++-- | Lifted 'E.finally'.+finally+  :: Eff es a+  -> Eff es b+  -- ^ Computation to run last.+  -> Eff es a+finally action handler = reallyUnsafeUnliftIO $ \unlift -> do+  E.finally (unlift action) (unlift handler)++-- | Lifted 'E.onException'.+onException+  :: Eff es a+  -> Eff es b+  -- ^ Computation to run last when an exception or+  -- t'Effectful.Error.Static.Error' was thrown.+  -> Eff es a+onException action handler = reallyUnsafeUnliftIO $ \unlift -> do+  E.onException (unlift action) (unlift handler)++----------------------------------------+-- Utils++-- | Lifted '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++#if MIN_VERSION_base(4,20,0)+-- | Lifted 'E.annotateIO'.+annotateIO :: E.ExceptionAnnotation e => e -> Eff es a -> Eff es a+annotateIO e action = reallyUnsafeUnliftIO $ \unlift -> do+  E.annotateIO e (unlift action)+#endif++----------------------------------------+-- Check exception type++-- $syncVsAsync+--+-- /Note:/ there's no way to determine whether an exception was thrown+-- synchronously or asynchronously, so these functions rely on a+-- heuristic. Namely, an exception type is determined by its 'E.Exception'+-- instance.+--+-- Exception types with the default 'E.Exception' instance are considered+-- synchronous:+--+-- >>> data SyncEx = SyncEx deriving (Show)+-- >>> instance Exception SyncEx+--+-- >>> isSyncException SyncEx+-- True+--+-- >>> isAsyncException SyncEx+-- False+--+-- Whereas for asynchronous exceptions you need to define their 'E.Exception'+-- instance as follows:+--+-- >>> data AsyncEx = AsyncEx deriving (Show)+-- >>> :{+--   instance Exception AsyncEx where+--     toException = asyncExceptionToException+--     fromException = asyncExceptionFromException+-- :}+--+-- >>> isSyncException AsyncEx+-- False+--+-- >>> isAsyncException AsyncEx+-- True++-- | Check if the given exception is considered synchronous.+isSyncException :: E.Exception e => e -> Bool+isSyncException e = case E.fromException (E.toException e) of+  Just E.SomeAsyncException{} -> False+  Nothing -> True++-- | Check if the given exception is considered asynchronous.+isAsyncException :: E.Exception e => e -> Bool+isAsyncException e = case E.fromException (E.toException e) of+  Just E.SomeAsyncException{} -> True+  Nothing -> False++----------------------------------------+-- Low-level API++-- | Lifted 'E.mask'.+mask :: ((forall r. Eff es r -> Eff es r) -> Eff es a) -> Eff es a+mask k = reallyUnsafeUnliftIO $ \unlift -> do+  E.mask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release)++-- | Lifted 'E.mask_'.+mask_ :: Eff es a -> Eff es a+mask_ action = reallyUnsafeUnliftIO $ \unlift -> do+  E.mask_ (unlift action)++-- | Lifted 'E.uninterruptibleMask'.+uninterruptibleMask :: ((forall r. Eff es r -> Eff es r) -> Eff es a) -> Eff es a+uninterruptibleMask k = reallyUnsafeUnliftIO $ \unlift -> do+  E.uninterruptibleMask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release)++-- | Lifted 'E.uninterruptibleMask_'.+uninterruptibleMask_ :: Eff es a -> Eff es a+uninterruptibleMask_ action = reallyUnsafeUnliftIO $ \unlift -> do+  E.uninterruptibleMask_ (unlift action)++-- | Lifted 'E.getMaskingState'.+getMaskingState :: Eff es E.MaskingState+getMaskingState = unsafeEff_ E.getMaskingState++-- | Lifted 'E.interruptible'.+interruptible :: Eff es a -> Eff es a+interruptible action = reallyUnsafeUnliftIO $ \unlift -> do+  E.interruptible (unlift action)++-- | Lifted 'E.allowInterrupt'.+allowInterrupt :: Eff es ()+allowInterrupt = unsafeEff_ E.allowInterrupt++-- $setup+-- >>> import Control.Exception (Exception)+-- >>> import Control.Exception (asyncExceptionFromException)+-- >>> import Control.Exception (asyncExceptionToException)

@@ -9,12 +9,19 @@   , Ref(..)   , Version   , Storage(..)-  , AnyEffect-  , toAnyEffect-  , fromAnyEffect++    -- ** StorageData+  , StorageData(..)+  , copyStorageData+  , restoreStorageData++    -- *** Utils   , AnyRelinker   , toAnyRelinker   , fromAnyRelinker+  , AnyEffect+  , toAnyEffect+  , fromAnyEffect      -- ** Relinker   , Relinker(..)@@ -29,7 +36,6 @@     -- * Operations   , emptyEnv   , cloneEnv-  , restoreEnv   , sizeEnv   , tailEnv @@ -112,6 +118,7 @@         s1 = writeByteArray# arr n ref s0         s2 = writeByteArray# arr (n +# 1#) version s1     in s2+  setByteArray# = defaultSetByteArray#   indexOffAddr# addr i =     let n = 2# *# i         ref = indexOffAddr# addr n@@ -127,6 +134,7 @@         s1 = writeOffAddr# addr n ref s0         s2 = writeOffAddr# addr (n +# 1#) version s1     in s2+  setOffAddr# = defaultSetOffAddr#  -- | Version of the effect. newtype Version = Version Int@@ -134,13 +142,13 @@  -- | A storage of effects. data Storage = Storage-  { stSize      :: !Int-  , stVersion   :: !Version-  , stVersions  :: !(MutablePrimArray RealWorld Version)-  , stEffects   :: !(SmallMutableArray RealWorld AnyEffect)-  , stRelinkers :: !(SmallMutableArray RealWorld AnyRelinker)+  { stVersion :: !Version+  , stData    :: {-# UNPACK #-} !StorageData   } +----------------------------------------+-- StorageData+ -- | Effect in 'Storage'. newtype AnyEffect = AnyEffect Any @@ -160,6 +168,46 @@ fromAnyRelinker (AnyRelinker f) = fromAny f  ----------------------------------------++data StorageData = StorageData+  { sdSize      :: !Int+  , sdVersions  :: !(MutablePrimArray RealWorld Version)+  , sdEffects   :: !(SmallMutableArray RealWorld AnyEffect)+  , sdRelinkers :: !(SmallMutableArray RealWorld AnyRelinker)+  }++-- | Make a shallow copy of the 'StorageData'.+--+-- @since 2.5.0.0+copyStorageData :: HasCallStack => StorageData -> IO StorageData+copyStorageData (StorageData storageSize vs0 es0 fs0) = do+  vsSize <- getSizeofMutablePrimArray  vs0+  esSize <- getSizeofSmallMutableArray es0+  fsSize <- getSizeofSmallMutableArray fs0+  when (vsSize /= esSize) $ do+    error $ "vsSize (" ++ show vsSize ++ ") /= esSize (" ++ show esSize ++ ")"+  when (esSize /= fsSize) $ do+    error $ "esSize (" ++ show esSize ++ ") /= fsSize (" ++ show fsSize ++ ")"+  vs <- cloneMutablePrimArray  vs0 0 vsSize+  es <- cloneSmallMutableArray es0 0 esSize+  fs <- cloneSmallMutableArray fs0 0 fsSize+  pure $ StorageData storageSize vs es fs++-- | Restore a shallow copy of the 'StorageData'.+--+-- The copy needs to be from the same 'Env' as the target.+--+-- @since 2.5.0.0+restoreStorageData :: HasCallStack => StorageData -> Env es -> IO ()+restoreStorageData newStorageData env = do+  modifyIORef' (envStorage env) $ \(Storage version oldStorageData) ->+    let oldSize = sdSize oldStorageData+        newSize = sdSize newStorageData+    in if newSize /= oldSize+    then error $ "newSize (" ++ show newSize ++ ") /= oldSize (" ++ show oldSize ++ ")"+    else Storage version newStorageData++---------------------------------------- -- Relinker  -- | A function for relinking 'Env' objects stored in the handlers and/or making@@ -205,18 +253,9 @@ -- | Clone the environment to use it in a different thread. cloneEnv :: HasCallStack => Env es -> IO (Env es) cloneEnv (Env offset refs storage0) = do-  Storage storageSize version vs0 es0 fs0 <- readIORef' storage0-  vsSize <- getSizeofMutablePrimArray  vs0-  esSize <- getSizeofSmallMutableArray es0-  fsSize <- getSizeofSmallMutableArray fs0-  when (vsSize /= esSize) $ do-    error $ "vsSize (" ++ show vsSize ++ ") /= esSize (" ++ show esSize ++ ")"-  when (esSize /= fsSize) $ do-    error $ "esSize (" ++ show esSize ++ ") /= fsSize (" ++ show fsSize ++ ")"-  vs <- cloneMutablePrimArray  vs0 0 vsSize-  es <- cloneSmallMutableArray es0 0 esSize-  fs <- cloneSmallMutableArray fs0 0 fsSize-  storage <- newIORef' $ Storage storageSize version vs es fs+  Storage version storageData0 <- readIORef' storage0+  storageData@(StorageData storageSize _ es fs) <- copyStorageData storageData0+  storage <- newIORef' $ Storage version storageData   let relinkEffects = \case         0 -> pure ()         k -> do@@ -230,29 +269,6 @@   pure $ Env offset refs storage {-# NOINLINE cloneEnv #-} --- | Restore the environment from its clone.------ @since 2.2.0.0-restoreEnv-  :: HasCallStack-  => Env es -- ^ Destination.-  -> Env es -- ^ Source.-  -> IO ()-restoreEnv dest src = do-  destStorage <- readIORef' (envStorage dest)-  srcStorage  <- readIORef' (envStorage src)-  let destStorageSize = stSize destStorage-      srcStorageSize  = stSize srcStorage-  when (destStorageSize /= srcStorageSize) $ do-    error $ "destStorageSize (" ++ show destStorageSize-         ++ ") /= srcStorageSize (" ++ show srcStorageSize ++ ")"-  writeIORef' (envStorage dest) $ srcStorage-    -- Decreasing the counter allows leakage of unsafeCoerce (see unsafeCoerce2-    -- in the EnvTests module).-    { stVersion = max (stVersion destStorage) (stVersion srcStorage)-    }-{-# NOINLINE restoreEnv #-}- -- | Get the current size of the environment. sizeEnv :: Env es -> IO Int sizeEnv (Env offset refs _) = do@@ -413,7 +429,7 @@   => Env es   -> IO (Int, SmallMutableArray RealWorld AnyEffect) getLocation (Env offset refs storage) = do-  Storage _ _ vs es _ <- readIORef' storage+  Storage _ (StorageData _ vs es _) <- readIORef' storage   storageVersion <- readPrimArray vs ref   -- If version of the reference is different than version in the storage, it   -- means that the effect in the storage is not the one that was initially@@ -433,10 +449,12 @@  -- | Create an empty storage. emptyStorage :: HasCallStack => IO Storage-emptyStorage = Storage 0 initialVersion-  <$> newPrimArray 0-  <*> newSmallArray 0 undefinedEffect-  <*> newSmallArray 0 undefinedRelinker+emptyStorage = Storage initialVersion <$> storageData+  where+    storageData = StorageData 0+      <$> newPrimArray 0+      <*> newSmallArray 0 undefinedEffect+      <*> newSmallArray 0 undefinedRelinker  -- | Insert an effect into the storage and return its reference. insertEffect@@ -447,7 +465,7 @@   -> Relinker (EffectRep (DispatchOf e)) e   -> IO Ref insertEffect storage e f = do-  Storage size version vs0 es0 fs0 <- readIORef' storage+  Storage version (StorageData size vs0 es0 fs0) <- readIORef' storage   len0 <- getSizeofSmallMutableArray es0   case size `compare` len0 of     GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"@@ -455,7 +473,8 @@       writePrimArray   vs0 size version       writeSmallArray' es0 size (toAnyEffect e)       writeSmallArray' fs0 size (toAnyRelinker f)-      writeIORef' storage $ Storage (size + 1) (bumpVersion version) vs0 es0 fs0+      writeIORef' storage $+        Storage (bumpVersion version) (StorageData (size + 1) vs0 es0 fs0)       pure $ Ref size version     EQ -> do       let len = doubleCapacity len0@@ -468,14 +487,15 @@       writePrimArray   vs size version       writeSmallArray' es size (toAnyEffect e)       writeSmallArray' fs size (toAnyRelinker f)-      writeIORef' storage $ Storage (size + 1) (bumpVersion version) vs es fs+      writeIORef' storage $+        Storage (bumpVersion version) (StorageData (size + 1) 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 :: HasCallStack => IORef' Storage -> Ref -> IO () deleteEffect storage (Ref ref version) = do-  Storage size currentVersion vs es fs <- readIORef' storage+  Storage currentVersion (StorageData size vs es fs) <- readIORef' storage   when (ref /= size - 1) $ do     error $ "ref (" ++ show ref ++ ") /= size - 1 (" ++ show (size - 1) ++ ")"   storageVersion <- readPrimArray vs ref@@ -485,7 +505,7 @@   writePrimArray  vs ref undefinedVersion   writeSmallArray es ref undefinedEffect   writeSmallArray fs ref undefinedRelinker-  writeIORef' storage $ Storage (size - 1) currentVersion vs es fs+  writeIORef' storage $ Storage currentVersion (StorageData (size - 1) vs es fs)  -- | Relink the environment to use the new storage. relinkEnv :: IORef' Storage -> Env es -> IO (Env es)

@@ -553,6 +553,8 @@   -> Eff es a send op = unsafeEff $ \es -> do   Handler handlerEs handler <- getEnv es+  when (envStorage es /= envStorage handlerEs) $ do+    error "es and handlerEs point to different Storages"   -- Prevent internal functions that rebind the effect handler from polluting   -- its call stack by freezing it. Note that functions 'interpret',   -- 'reinterpret', 'interpose' and 'impose' need to thaw it so that useful

@@ -8,8 +8,9 @@     -- ** Handlers   , runNonDet -  -- * Utils+  -- * Operations   , emptyEff+  , plusEff   , sumEff      -- * Re-exports@@ -21,7 +22,7 @@   ) where  import Control.Applicative-import Data.Coerce+import Data.IORef.Strict import GHC.Generics import GHC.Stack @@ -30,13 +31,14 @@ import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive import Effectful.Error.Static-import Effectful.Internal.Monad (LocalEnv(..), NonDet(..))+import Effectful.Internal.Env qualified as I+import Effectful.Internal.Monad (NonDet(..))  -- | Policy of dealing with modifications to __thread local__ state in the -- environment in branches that end up calling the 'Empty' operation. ----- /Note:/ 'OnEmptyKeep' is significantly faster as there is no need to back up--- the environment on each call to ':<|>:'.+-- /Note:/ 'OnEmptyKeep' is faster as there is no need to back up the+-- environment on each call to ':<|>:'. -- -- @since 2.2.0.0 data OnEmptyPolicy@@ -83,23 +85,23 @@ runNonDetRollback = reinterpret setup $ \env -> \case   Empty       -> throwError ErrorEmpty   m1 :<|>: m2 -> do-    backupEnv <- cloneLocalEnv env+    backupData <- unsafeEff backupStorageData     localSeqUnlift env $ \unlift -> do       mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> do-        -- If m1 failed, roll back the environment.-        restoreLocalEnv env backupEnv+        -- If m1 failed, restore the data.+        unsafeEff $ I.restoreStorageData backupData         pure Nothing       case mr of         Just r  -> pure r         Nothing -> unlift m2   where     setup action = do-      backupEs <- unsafeEff cloneEnv+      backupData <- unsafeEff backupStorageData       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+          -- If the whole action failed, restore the data.+          unsafeEff $ I.restoreStorageData backupData           pure $ Left cs  ----------------------------------------@@ -111,12 +113,20 @@ emptyEff :: (HasCallStack, NonDet :> es) => Eff es a emptyEff = withFrozenCallStack send Empty +-- | Specialized version of '<|>' with the `HasCallStack` constraint for+-- tracking purposes.+--+-- @since 2.5.0.0+plusEff :: (HasCallStack, NonDet :> es) => Eff es a -> Eff es a -> Eff es a+plusEff m1 m2 = send (m1 :<|>: m2)+infixl 3 `plusEff` -- same as <|>+ -- | Specialized version of 'asum' with the 'HasCallStack' constraint for -- tracking purposes. -- -- @since 2.2.0.0 sumEff :: (HasCallStack, Foldable t, NonDet :> es) => t (Eff es a) -> Eff es a-sumEff = foldr (<|>) emptyEff+sumEff = foldr plusEff emptyEff  ---------------------------------------- -- Internal helpers@@ -130,15 +140,5 @@ noError :: Either (cs, e) a -> Either cs a noError = either (Left . fst) Right -cloneLocalEnv-  :: HasCallStack-  => LocalEnv localEs handlerEs-  -> Eff es (LocalEnv localEs handlerEs)-cloneLocalEnv = coerce . unsafeEff_ . cloneEnv . coerce--restoreLocalEnv-  :: HasCallStack-  => LocalEnv localEs handlerEs-  -> LocalEnv localEs handlerEs-  -> Eff es ()-restoreLocalEnv dest src = unsafeEff_ $ restoreEnv (coerce dest) (coerce src)+backupStorageData :: HasCallStack => Env es -> IO I.StorageData+backupStorageData env = I.copyStorageData . I.stData =<< readIORef' (I.envStorage env)

@@ -7,6 +7,8 @@ -- the @transformers@ library, the 'State' effect doesn't discard state updates -- when an exception is received: --+-- >>> import Control.Exception (ErrorCall)+-- >>> import Control.Monad.Catch -- >>> import Control.Monad.Trans.State.Strict qualified as S -- -- >>> :{@@ -135,6 +137,3 @@   => (s -> Eff es s) -- ^ The monadic function to modify the state.   -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s)---- $setup--- >>> import Effectful.Exception

@@ -7,6 +7,8 @@ -- the @transformers@ library, the 'State' effect doesn't discard state updates -- when an exception is received: --+-- >>> import Control.Exception (ErrorCall)+-- >>> import Control.Monad.Catch -- >>> import Control.Monad.Trans.State.Strict qualified as S -- -- >>> :{@@ -151,6 +153,3 @@ -- /Note:/ this function gets an exclusive access to the state for its duration. modifyM :: (HasCallStack, State s :> es) => (s -> Eff es s) -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s)---- $setup--- >>> import Effectful.Exception