effectful-core 2.3.1.0 → 2.6.1.0
raw patch · 33 files changed
Files
- CHANGELOG.md +73/−0
- README.md +2/−3
- effectful-core.cabal +18/−3
- src/Effectful.hs +4/−4
- src/Effectful/Dispatch/Dynamic.hs +505/−167
- src/Effectful/Dispatch/Static/Primitive.hs +0/−1
- src/Effectful/Dispatch/Static/Unsafe.hs +0/−47
- src/Effectful/Error/Dynamic.hs +41/−17
- src/Effectful/Error/Static.hs +80/−64
- src/Effectful/Exception.hs +644/−0
- src/Effectful/Fail.hs +4/−4
- src/Effectful/Internal/Effect.hs +19/−12
- src/Effectful/Internal/Env.hs +243/−134
- src/Effectful/Internal/MTL.hs +90/−0
- src/Effectful/Internal/Monad.hs +166/−81
- src/Effectful/Internal/Unlift.hs +68/−57
- src/Effectful/Internal/Utils.hs +12/−60
- 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 +64/−32
- src/Effectful/Provider.hs +55/−25
- src/Effectful/Provider/List.hs +72/−47
- src/Effectful/Reader/Dynamic.hs +17/−16
- src/Effectful/Reader/Static.hs +10/−6
- src/Effectful/State/Dynamic.hs +12/−27
- src/Effectful/State/Static/Local.hs +19/−16
- src/Effectful/State/Static/Shared.hs +28/−34
- src/Effectful/Writer/Dynamic.hs +11/−23
- src/Effectful/Writer/Static/Local.hs +14/−9
- src/Effectful/Writer/Static/Shared.hs +16/−11
CHANGELOG.md view
@@ -1,3 +1,76 @@+# effectful-core-2.6.1.0 (2025-08-30)+* Add `MonadError`, `MonadReader`, `MonadState` and `MonadWriter` instances for+ `Eff` for compatibility with existing code.++# effectful-core-2.6.0.0 (2025-06-13)+* Adjust `generalBracket` with `base >= 4.21` to make use of the new exception+ annotation mechanism.+* Add `withException` to `Effectful.Exception`.+* Deprecate `Effectful.Reader.Dynamic.withReader` as it doesn't work correctly+ for all potential interpreters.+* **Breaking changes**:+ - Change the order of type parameters in `raise` for better usability.+ - `Effectful.Error.Static.ErrorWrapper` is no longer caught by `catchSync`.+ - Remove deprecated function `Effectful.withConcEffToIO`.++# effectful-core-2.5.1.0 (2024-11-27)+* Add `passthrough` to `Effectful.Dispatch.Dynamic` for passing operations to+ the upstream handler within `interpose` and `impose` without having to fully+ pattern match on them.+* **Bugfixes**:+ - Fix a potential space leak related to `HasCallStack` quirks (see+ https://gitlab.haskell.org/ghc/ghc/-/issues/25520 for more information).++# 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`.+* 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`.
README.md view
@@ -1,13 +1,12 @@ # effectful -[](https://github.com/haskell-effectful/effectful/actions?query=branch%3Amaster)+[](https://github.com/haskell-effectful/effectful/actions/workflows/haskell-ci.yml) [](https://hackage.haskell.org/package/effectful)-[](https://packdeps.haskellers.com/feed?needle=andrzej@rybczak.net) [](https://www.stackage.org/lts/package/effectful) [](https://www.stackage.org/nightly/package/effectful) -<img src="https://user-images.githubusercontent.com/387658/127747903-f728437f-2ee4-47b8-9f0c-5102fd44c8e4.png" width="128">+<img src="https://raw.githubusercontent.com/haskell-effectful/effectful/master/logo.svg" width="150"> An easy to use, fast extensible effects library with seamless integration with the existing Haskell ecosystem.
effectful-core.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: effectful-core-version: 2.3.1.0+version: 2.6.1.0 license: BSD-3-Clause license-file: LICENSE category: Control@@ -21,7 +21,7 @@ CHANGELOG.md README.md -tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.5, 9.8.2, 9.10.1 }+tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.2, 9.12.2, 9.14.1 } bug-reports: https://github.com/haskell-effectful/effectful/issues source-repository head@@ -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@@ -55,6 +60,7 @@ TypeApplications TypeFamilies TypeOperators+ UndecidableInstances library import: language@@ -63,9 +69,12 @@ build-depends: base >= 4.14 && < 5 , containers >= 0.6+ , deepseq >= 1.2 , exceptions >= 0.10.4+ , mtl >= 2.2.1 , monad-control >= 1.0.3 , primitive >= 0.7.3.0+ , strict-mutable-base >= 1.1.0.0 , transformers-base >= 0.4.6 , unliftio-core >= 0.2.0.1 @@ -81,13 +90,19 @@ Effectful.Dispatch.Static.Unsafe Effectful.Error.Dynamic Effectful.Error.Static+ Effectful.Exception Effectful.Fail Effectful.Internal.Effect Effectful.Internal.Env+ Effectful.Internal.MTL Effectful.Internal.Monad 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
src/Effectful.hs view
@@ -46,7 +46,6 @@ , withUnliftStrategy , withSeqEffToIO , withEffToIO- , withConcEffToIO -- ** Lifting , raise@@ -65,6 +64,7 @@ import Effectful.Internal.Effect import Effectful.Internal.Env+import Effectful.Internal.MTL () import Effectful.Internal.Monad -- $intro@@ -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
src/Effectful/Dispatch/Dynamic.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE UndecidableInstances #-} -- | Dynamically dispatched effects. module Effectful.Dispatch.Dynamic ( -- * Introduction@@ -19,13 +19,18 @@ -- * Sending operations to the handler send+ , passthrough -- * Handling effects , EffectHandler , interpret+ , interpretWith , reinterpret+ , reinterpretWith , interpose+ , interposeWith , impose+ , imposeWith -- ** Handling local 'Eff' computations , LocalEnv@@ -52,15 +57,26 @@ , 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.Stack import GHC.TypeLits import Effectful.Internal.Effect@@ -138,11 +154,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 +169,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 +178,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 +225,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:@@ -248,8 +264,8 @@ -- -- The problem is that @action@ has a type @Eff localEs a@, while the monad of -- the effect handler is @Eff es@. @localEs@ represents the /local environment/--- in which the @Profile@ operation was called, which is opaque as the effect--- handler cannot possibly know how it looks like.+-- in which the @Profile@ operation was called, which is more or less opaque to+-- the effect handler. -- -- The solution is to use the 'LocalEnv' that an 'EffectHandler' is given to run -- the action using one of the functions from the 'localUnlift' family:@@ -332,8 +348,6 @@ -- __orphan__, __canonical__ instance of @MonadRNG@ for 'Eff' that delegates to -- the @RNG@ effect: ----- >>> :set -XUndecidableInstances--- -- >>> :{ -- instance RNG :> es => MonadRNG (Eff es) where -- randomInt = send RandomInt@@ -343,7 +357,7 @@ -- -- >>> :{ -- runDummyRNG :: Eff (RNG : es) a -> Eff es a--- runDummyRNG = interpret $ \_ -> \case+-- runDummyRNG = interpret_ $ \case -- RandomInt -> pure 55 -- :} --@@ -381,9 +395,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@@ -400,41 +413,116 @@ -- >>> runPureEff . runReader @Int 3 $ double -- 6 +-- | A variant of 'send' for passing operations to the upstream handler within+-- 'interpose' and 'impose' without having to fully pattern match on them.+passthrough+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es, e :> localEs, SharedSuffix es handlerEs)+ => LocalEnv localEs handlerEs+ -> e (Eff localEs) a+ -- ^ The operation.+ -> Eff es a+passthrough (LocalEnv les) op = unsafeEff $ \es -> do+ Handler handlerEs (HandlerImpl handler) <- getEnv es+ when (envStorage les /= envStorage handlerEs) $ do+ error "les and handlerEs point to different Storages"+ -- Prevent the addition of unnecessary 'handler' stack frame to the call+ -- stack. Note that functions 'interpret', 'reinterpret', 'interpose' and+ -- 'impose' need to thaw the call stack so that useful stack frames from+ -- inside the effect handler continue to be added.+ unEff (withFrozenCallStack handler (LocalEnv les) op) handlerEs+{-# NOINLINE passthrough #-}+ ---------------------------------------- -- Handling effects -- | Interpret an effect. ----- /Note:/ 'interpret' can be turned into a 'reinterpret' with the use of--- 'inject'.+-- /Note:/ if you want to use intermediate effects in multiple handlers, then+-- hide them from downstream, have a look at 'inject'. interpret- :: DispatchOf e ~ Dynamic+ :: (HasCallStack, DispatchOf e ~ Dynamic) => EffectHandler e es -- ^ The effect handler. -> Eff (e : es) a -> Eff es a-interpret handler m = unsafeEff $ \es -> do- (`unEff` es) $ runHandler (mkHandler es) m- where- mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)+interpret handler action = interpretImpl action $+ HandlerImpl (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 action handler = interpretImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler)+ -- | Interpret an effect using other, private effects. -- -- @'interpret' ≡ 'reinterpret' 'id'@+--+-- /Note:/ If you want to interpret multiple effects using other, private+-- effects, you can do so with a combination of 'interpret' and 'inject'.+--+-- This is in particular useful for splitting a large effect into smaller+-- ones. For example, let's say you want to split a+-- t'Effectful.State.Static.Local.State' into a read only and read write+-- component:+--+-- >>> :{+-- data Get s :: Effect where+-- Get :: Get s m s+-- type instance DispatchOf (Get s) = Dynamic+-- :}+--+-- >>> :{+-- data Put s :: Effect where+-- Put :: s -> Put s m ()+-- type instance DispatchOf (Put s) = Dynamic+-- :}+--+-- >>> import Effectful.State.Static.Local qualified as S+--+-- >>> :{+-- runGetPut :: forall s es a. s -> Eff (Get s : Put s : es) a -> Eff es (a, s)+-- runGetPut s0+-- = S.runState s0+-- . interpret_ @(Put s) (\(Put s) -> S.put s)+-- . interpret_ @(Get s) (\Get -> S.get)+-- . inject+-- :}+--+-- Here, a t'Effectful.State.Static.Local.State' effect is introduced, then+-- @Put@ and @Get@ effects that use it underneath and finally 'inject' hides the+-- original state from downstream code. reinterpret- :: DispatchOf e ~ Dynamic+ :: (HasCallStack, DispatchOf e ~ Dynamic) => (Eff handlerEs a -> Eff es b)- -- ^ Introduction of effects encapsulated within the handler.+ -- ^ Setup of effects encapsulated in the handler. -> EffectHandler e handlerEs -- ^ The effect handler. -> Eff (e : es) a -> Eff es b-reinterpret runHandlerEs handler m = unsafeEff $ \es -> do- (`unEff` es) . runHandlerEs . unsafeEff $ \handlerEs -> do- (`unEff` es) $ runHandler (mkHandler handlerEs) m- where- mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)+reinterpret runSetup handler action = reinterpretImpl runSetup action $+ HandlerImpl (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)+ -- ^ Setup of effects encapsulated in the handler.+ -> Eff (e : es) a+ -> EffectHandler e handlerEs+ -- ^ The effect handler.+ -> Eff es b+reinterpretWith runSetup action handler = reinterpretImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler)+ -- | Replace the handler of an existing effect with a new one. -- -- /Note:/ this function allows for augmenting handlers with a new functionality@@ -442,88 +530,220 @@ -- -- >>> :{ -- data E :: Effect where--- Op :: E m ()+-- Op1 :: E m ()+-- Op2 :: E m ()+-- Op3 :: 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")+-- Op3 -> error "Op3 not implemented" -- :} ----- >>> runEff . runE $ send Op--- op+-- >>> let action = send Op1 >> send Op2 --+-- >>> runEff . runE $ action+-- op1+-- op2+--+-- You can modify only specific operations and send the rest to the upstream+-- handler with 'passthrough':+-- -- >>> :{--- 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 $ \env -> \case+-- Op2 -> liftIO (putStrLn "augmented op2") >> send Op2+-- op -> passthrough env op -- :} ----- >>> runEff . runE . augmentE $ send Op--- augmented op--- op+-- >>> runEff . runE . augmentOp2 $ action+-- op1+-- augmented op2+-- op2 --+-- /Note:/ when an exception is raised while handling an operation, good+-- debugging experience is ensured by strategically placed 'HasCallStack'+-- constraints:+--+-- >>> runEff . runE . augmentOp2 $ send Op3+-- *** Exception: Op3 not implemented+-- ...+-- error, called at <interactive>:...+-- handler, called at src/Effectful/Dispatch/Dynamic.hs:...+-- passthrough, called at <interactive>:...+-- handler, called at src/Effectful/Dispatch/Dynamic.hs:...+-- send, called at <interactive>:... interpose- :: forall e es a. (DispatchOf e ~ Dynamic, e :> es)+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => EffectHandler e es -- ^ The effect handler. -> Eff es a -> Eff es a-interpose handler m = unsafeEff $ \es -> do- inlineBracket- (do- origHandler <- getEnv @e es- replaceEnv origHandler relinkHandler es- )- (\newEs -> do- -- Restore the original handler.- putEnv es =<< getEnv @e newEs- unreplaceEnv @e newEs- )- (\newEs -> do- -- Replace the original handler with a new one. Note that 'newEs'- -- will still see the original handler.- putEnv es $ mkHandler newEs- unEff m es- )- where- mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)+interpose handler action = interposeImpl action $+ HandlerImpl (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 action handler = interposeImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler)+ -- | 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)+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => (Eff handlerEs a -> Eff es b)- -- ^ Introduction of effects encapsulated within the handler.+ -- ^ Setup of effects encapsulated in the handler. -> EffectHandler e handlerEs -- ^ The effect handler. -> Eff es a -> Eff es b-impose runHandlerEs handler m = unsafeEff $ \es -> do- inlineBracket- (do- origHandler <- getEnv @e es- replaceEnv origHandler relinkHandler es- )- (\newEs -> do- -- Restore the original handler.- putEnv es =<< getEnv @e newEs- unreplaceEnv @e newEs- )- (\newEs -> do- (`unEff` newEs) . runHandlerEs . unsafeEff $ \handlerEs -> do- -- Replace the original handler with a new one. Note that- -- 'newEs' (and thus 'handlerEs') wil still see the original- -- handler.- putEnv es $ mkHandler handlerEs- unEff m es- )- where- mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)+impose runSetup handler action = imposeImpl runSetup action $+ HandlerImpl (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)+ -- ^ Setup of effects encapsulated in the handler.+ -> Eff es a+ -> EffectHandler e handlerEs+ -- ^ The effect handler.+ -> Eff es b+imposeWith runSetup action handler = imposeImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler)+ ----------------------------------------+-- 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 action = interpretImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in 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_ action handler = interpretImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | 'reinterpret' for first order effects.+--+-- @since 2.4.0.0+reinterpret_+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => (Eff handlerEs a -> Eff es b)+ -- ^ Setup of effects encapsulated in the handler.+ -> EffectHandler_ e handlerEs+ -- ^ The effect handler.+ -> Eff (e : es) a+ -> Eff es b+reinterpret_ runSetup handler action = reinterpretImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | 'reinterpretWith' for first order effects.+--+-- @since 2.4.0.0+reinterpretWith_+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => (Eff handlerEs a -> Eff es b)+ -- ^ Setup of effects encapsulated in the handler.+ -> Eff (e : es) a+ -> EffectHandler_ e handlerEs+ -- ^ The effect handler.+ -> Eff es b+reinterpretWith_ runSetup action handler = reinterpretImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | '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 action = interposeImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in 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_ action handler = interposeImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | 'impose' for first order effects.+--+-- @since 2.4.0.0+impose_+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => (Eff handlerEs a -> Eff es b)+ -- ^ Setup of effects encapsulated in the handler.+ -> EffectHandler_ e handlerEs+ -- ^ The effect handler.+ -> Eff es a+ -> Eff es b+impose_ runSetup handler action = imposeImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in 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)+ -- ^ Setup of effects encapsulated in the handler.+ -> Eff es a+ -> EffectHandler_ e handlerEs+ -- ^ The effect handler.+ -> Eff es b+imposeWith_ runSetup action handler = imposeImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++---------------------------------------- -- Unlifts -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the@@ -536,8 +756,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 +770,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 +784,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 +804,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 +826,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 +843,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 +871,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 +911,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 +935,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 +965,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 +1014,87 @@ -- 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- => 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- refs <- unsafeFreezePrimArray mrefs- pure $ Env 0 refs storage- -- | Require that both effect stacks share an opaque suffix. -- -- Functions from the 'localUnlift' family utilize this constraint to guarantee@@ -935,6 +1166,113 @@ Text "As a solution simply change the stack to have a polymorphic suffix." ) => SharedSuffix '[] '[] +----------------------------------------+-- Helpers++interpretImpl+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => Eff (e : es) a+ -> HandlerImpl e es+ -> Eff es a+interpretImpl action handlerImpl = unsafeEff $ \es -> do+ (`unEff` es) $ runHandler (Handler es handlerImpl) action+{-# INLINE interpretImpl #-}++reinterpretImpl+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => (Eff handlerEs a -> Eff es b)+ -> Eff (e : es) a+ -> HandlerImpl e handlerEs+ -> Eff es b+reinterpretImpl runSetup action handlerImpl = unsafeEff $ \es -> do+ (`unEff` es) . runSetup . unsafeEff $ \handlerEs -> do+ (`unEff` es) $ runHandler (Handler handlerEs handlerImpl) action+{-# INLINE reinterpretImpl #-}++interposeImpl+ :: forall e es a. (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => Eff es a+ -> HandlerImpl e es+ -> Eff es a+interposeImpl action handlerImpl = unsafeEff $ \es -> do+ inlineBracket+ (do+ origHandler <- getEnv @e es+ replaceEnv origHandler relinkHandler es+ )+ (\newEs -> do+ -- Restore the original handler.+ putEnv es =<< getEnv @e newEs+ unreplaceEnv @e newEs+ )+ (\newEs -> do+ -- Replace the original handler with a new one. Note that 'newEs'+ -- will still see the original handler.+ putEnv es $ Handler newEs handlerImpl+ unEff action es+ )+{-# INLINE interposeImpl #-}++imposeImpl+ :: forall e es handlerEs a b. (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => (Eff handlerEs a -> Eff es b)+ -> Eff es a+ -> HandlerImpl e handlerEs+ -> Eff es b+imposeImpl runSetup action handlerImpl = unsafeEff $ \es -> do+ inlineBracket+ (do+ origHandler <- getEnv @e es+ replaceEnv origHandler relinkHandler es+ )+ (\newEs -> do+ -- Restore the original handler.+ putEnv es =<< getEnv @e newEs+ unreplaceEnv @e newEs+ )+ (\newEs -> do+ (`unEff` newEs) . runSetup . unsafeEff $ \handlerEs -> do+ -- Replace the original handler with a new one. Note that+ -- 'newEs' (and thus 'handlerEs') wil still see the original+ -- handler.+ putEnv es $ Handler handlerEs handlerImpl+ unEff action es+ )+{-# INLINE imposeImpl #-}++copyRefs+ :: forall es srcEs destEs+ . (HasCallStack, KnownSubset es srcEs)+ => Env srcEs+ -> Env destEs+ -> 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 ()+ -- $setup -- >>> import Control.Concurrent (ThreadId, forkIOWithUnmask)+-- >>> import Control.Monad.IO.Class -- >>> import Effectful.Reader.Static
src/Effectful/Dispatch/Static/Primitive.hs view
@@ -31,7 +31,6 @@ -- ** Utils , emptyEnv , cloneEnv- , restoreEnv , sizeEnv , tailEnv ) where
src/Effectful/Dispatch/Static/Unsafe.hs view
@@ -5,50 +5,3 @@ ) where import Effectful.Internal.Monad---- | Utility for lifting 'IO' computations of type------ @'IO' a -> 'IO' b@------ to------ @'Eff' es a -> 'Eff' es b@------ This function is __really unsafe__ because:------ - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'--- computations.------ - The 'IO' computation must run its argument in a way that's perceived as--- sequential to the outside observer, e.g. in the same thread or in a worker--- thread that finishes before the argument is run again.------ __Warning:__ if you disregard the second point, you will experience weird--- bugs, data races or internal consistency check failures.------ When in doubt, use 'Effectful.Dispatch.Static.unsafeLiftMapIO', especially--- since this version saves only a simple safety check per call of--- @reallyUnsafeLiftMapIO f@.-reallyUnsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b-reallyUnsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es)---- | Create an unlifting function.------ This function is __really unsafe__ because:------ - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'--- computations.------ - Unlifted 'Eff' computations must be run in a way that's perceived as--- sequential to the outside observer, e.g. in the same thread as the caller--- of 'reallyUnsafeUnliftIO' or in a worker thread that finishes before--- another unlifted computation is run.------ __Warning:__ if you disregard the second point, you will experience weird--- bugs, data races or internal consistency check failures.------ When in doubt, use 'Effectful.Dispatch.Static.unsafeSeqUnliftIO', especially--- since this version saves only a simple safety check per call of the unlifting--- function.-reallyUnsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a-reallyUnsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es)
src/Effectful/Error/Dynamic.hs view
@@ -1,7 +1,8 @@ -- | The dynamically dispatched variant of the 'Error' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use the statically dispatched variant,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.Except.MonadError' instance for compatibility with existing+-- code, it's recommended to use the statically dispatched variant, -- i.e. "Effectful.Error.Static". module Effectful.Error.Dynamic ( -- * Effect@@ -14,7 +15,9 @@ , runErrorNoCallStackWith -- ** Operations+ , throwErrorWith , throwError+ , throwError_ , catchError , handleError , tryError@@ -31,20 +34,15 @@ import Effectful import Effectful.Dispatch.Dynamic import Effectful.Error.Static qualified as E---- | Provide the ability to handle errors of type @e@.-data Error e :: Effect where- ThrowError :: e -> Error e m a- CatchError :: m a -> (E.CallStack -> e -> m a) -> Error e m a--type instance DispatchOf (Error e) = Dynamic+import Effectful.Internal.MTL (Error(..)) -- | 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 +51,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 +65,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 +82,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 +126,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
src/Effectful/Error/Static.hs view
@@ -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@@ -98,16 +100,16 @@ , 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@.-data Error e :: Effect+data Error (e :: Type) :: Effect type instance DispatchOf (Error e) = Static NoSideEffects newtype instance StaticRep (Error e) = Error ErrorId@@ -115,29 +117,24 @@ -- | 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- 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. -- -- @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-runErrorWith handler m = runError m >>= \case+runErrorWith handler action = runError action >>= \case Left (cs, e) -> handler cs e Right a -> pure a @@ -146,48 +143,72 @@ -- @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-runErrorNoCallStackWith handler m = runErrorNoCallStack m >>= \case+runErrorNoCallStackWith handler action = runErrorNoCallStack action >>= \case 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 = 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+ :: 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) -- ^ 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. 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,45 +219,40 @@ -- | 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)-tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)+tryError action = do+ Error eid <- getStaticRep @(Error e)+ tryJust (matchError eid) action ---------------------------------------- -- 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. 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 -data ErrorWrapper = ErrorWrapper !ErrorId CallStack Any instance Show ErrorWrapper where- showsPrec p (ErrorWrapper _ cs _)- = ("Effectful.Error.Static.ErrorWrapper\n\n" ++)- . showsPrec p (prettyCallStack cs)-instance Exception ErrorWrapper+ showsPrec _ (ErrorWrapper _ cs errRep _)+ = ("Effectful.Error.Static.ErrorWrapper: " ++)+ . (errRep ++)+ . ("\n" ++)+ . (prettyCallStack cs ++) -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+instance Exception ErrorWrapper where+ -- See discussion in https://github.com/haskell-effectful/effectful/pull/232.+ toException = asyncExceptionToException+ fromException = asyncExceptionFromException++matchError :: ErrorId -> ErrorWrapper -> Maybe (CallStack, e)+matchError eid (ErrorWrapper etag cs _ e)+ | eid == etag = Just (cs, fromAny e)+ | otherwise = Nothing
+ src/Effectful/Exception.hs view
@@ -0,0 +1,644 @@+{-# LANGUAGE CPP #-}+-- | Support for runtime exceptions.+--+-- 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+ throwIO+#if MIN_VERSION_base(4,21,0)+ , rethrowIO+#endif++ -- * Catching (with recovery)+ -- $catchAll+ , catch+#if MIN_VERSION_base(4,21,0)+ , catchNoPropagate+#endif+ , catchDeep+ , catchJust+ , catchIf+ , catchIO+ , catchSync+ , catchSyncDeep++ , handle+ , handleDeep+ , handleJust+ , handleIf+ , handleIO+ , handleSync+ , handleSyncDeep++ , try+#if MIN_VERSION_base(4,21,0)+ , tryWithContext+#endif+ , tryDeep+ , tryJust+ , tryIf+ , tryIO+ , trySync+ , trySyncDeep++ , C.Handler(..)+ , catches+ , catchesDeep++ -- | #cleanup#++ -- * Cleanup (no recovery)+ , bracket+ , bracket_+ , bracketOnError+ , generalBracket+ , C.ExitCase(..)+ , finally+ , onException+ , withException++ -- * 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+ , E.SomeException(..)++ -- ** 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(..)+ , 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++#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.Monad.Catch qualified as C+import GHC.Stack (withFrozenCallStack)++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Unsafe++----------------------------------------+-- 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)++-- | A variant of 'onException' that gives access to the exception.+--+-- @since 2.6.0.0+withException+ :: E.Exception e+ => Eff es a+ -> (e -> Eff es b)+ -- ^ Computation to run last when an exception or+ -- t'Effectful.Error.Static.Error' was thrown.+ -> Eff es a+withException action cleanup = do+#if MIN_VERSION_base(4,21,0)+ action `catchNoPropagate` \ec@(E.ExceptionWithContext _ e) -> do+ _ <- annotateIO (E.WhileHandling (E.toException ec)) (cleanup e)+ rethrowIO ec+#else+ action `catch` \e -> do+ _ <- cleanup e+ throwIO e+#endif++----------------------------------------+-- 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)
src/Effectful/Fail.hs view
@@ -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
src/Effectful/Internal/Effect.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | Type-safe indexing for 'Effectful.Internal.Monad.Env'. --@@ -10,6 +9,7 @@ , (:>)(..) , (:>>) , Subset(..)+ , KnownSubset , KnownPrefix(..) , IsUnknownSuffixOf , type (++)@@ -70,8 +70,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 +86,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 +96,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 +121,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) ----
src/Effectful/Internal/Env.hs view
@@ -1,11 +1,28 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} module Effectful.Internal.Env ( -- * The environment Env(..)+ , Ref(..)+ , Version , Storage(..) + -- ** StorageData+ , StorageData(..)+ , copyStorageData+ , restoreStorageData++ -- *** Utils+ , AnyRelinker+ , toAnyRelinker+ , fromAnyRelinker+ , AnyEffect+ , toAnyEffect+ , fromAnyEffect+ -- ** Relinker , Relinker(..) , dummyRelinker@@ -19,7 +36,6 @@ -- * Operations , emptyEnv , cloneEnv- , restoreEnv , sizeEnv , tailEnv @@ -40,9 +56,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,27 +93,128 @@ -- 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+ setByteArray# = defaultSetByteArray#+ 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+ setOffAddr# = defaultSetOffAddr#++-- | 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+ , stData :: {-# UNPACK #-} !StorageData } ----------------------------------------+-- StorageData++-- | 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++----------------------------------------++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 -- 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,88 +245,57 @@ -- 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- 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 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 {-# NOINLINE cloneEnv #-} --- | Restore the environment from its clone.------ @since 2.2.0.0-restoreEnv- :: 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- 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 +304,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 +316,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 +326,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 +336,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 +347,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 +358,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,132 +383,158 @@ -- | 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+ 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 -- 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 "+ ++ "UnliftStrategy (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)- <$> newPrimArray 0- <*> newSmallArray 0 undefinedData- <*> newSmallArray 0 undefinedData+emptyStorage :: HasCallStack => IO Storage+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- :: 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+ 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 ++ ")" 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 (bumpVersion version) (StorageData (size + 1) vs0 es0 fs0)+ pure $ Ref size version EQ -> do- let len = doubleCapacity len0+ let len = growCapacity 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 (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 :: 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 currentVersion (StorageData size 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 currentVersion (StorageData (size - 1) vs es fs) -- | Relink the environment to use the new storage. relinkEnv :: IORef' Storage -> Env es -> IO (Env es) relinkEnv storage (Env offset refs _) = pure $ Env offset refs storage --- | Double the capacity of an array.-doubleCapacity :: Int -> Int-doubleCapacity n = max 1 n * 2+undefinedVersion :: Version+undefinedVersion = Version 0 -noVersion :: Int-noVersion = 0+initialVersion :: Version+initialVersion = Version 1 -undefinedData :: HasCallStack => a-undefinedData = error "undefined data"+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 ()
+ src/Effectful/Internal/MTL.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -Wno-orphans #-}+-- | Definitions and instances for MTL compatibility.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.MTL where++import Control.Monad.Except qualified as MTL+import Control.Monad.Reader qualified as MTL+import Control.Monad.State qualified as MTL+import Control.Monad.Writer qualified as MTL+import GHC.Stack (CallStack)++import Effectful.Internal.Effect+import Effectful.Internal.Env+import Effectful.Internal.Monad++-- | Provide the ability to handle errors of type @e@.+data Error e :: Effect where+ -- | @since 2.4.0.0+ ThrowErrorWith :: (e -> String) -> e -> Error e m a+ CatchError :: m a -> (CallStack -> e -> m a) -> Error e m a++type instance DispatchOf (Error e) = Dynamic++-- | Instance included for compatibility with existing code.+instance+ ( Show e+ , Error e :> es+ , MTL.MonadError e (Eff es)+ ) => MTL.MonadError e (Eff es) where+ throwError = send . ThrowErrorWith show+ catchError action = send . CatchError action . const++----------------------------------------++data Reader r :: Effect where+ Ask :: Reader r m r+ Local :: (r -> r) -> m a -> Reader r m a++type instance DispatchOf (Reader r) = Dynamic++-- | Instance included for compatibility with existing code.+instance+ ( Reader r :> es+ , MTL.MonadReader r (Eff es)+ ) => MTL.MonadReader r (Eff es) where+ ask = send Ask+ local f = send . Local f+ reader f = f <$> send Ask++----------------------------------------++-- | Provide access to a mutable value of type @s@.+data State s :: Effect where+ Get :: State s m s+ Put :: s -> State s m ()+ State :: (s -> (a, s)) -> State s m a+ StateM :: (s -> m (a, s)) -> State s m a++type instance DispatchOf (State s) = Dynamic++-- | Instance included for compatibility with existing code.+instance+ ( State s :> es+ , MTL.MonadState s (Eff es)+ ) => MTL.MonadState s (Eff es) where+ get = send Get+ put = send . Put+ state = send . State++----------------------------------------++-- | Provide access to a write only value of type @w@.+data Writer w :: Effect where+ Tell :: w -> Writer w m ()+ Listen :: m a -> Writer w m (a, w)++type instance DispatchOf (Writer w) = Dynamic++-- | Instance included for compatibility with existing code.+instance+ ( Monoid w+ , Writer w :> es+ , MTL.MonadWriter w (Eff es)+ ) => MTL.MonadWriter w (Eff es) where+ writer (a, w) = a <$ send (Tell w)+ tell = send . Tell+ listen = send . Listen+ pass = error "pass is not implemented due to ambiguous semantics in presence of runtime exceptions"
src/Effectful/Internal/Monad.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_HADDOCK not-home #-} -- | The 'Eff' monad.@@ -46,10 +45,12 @@ , withUnliftStrategy , withSeqEffToIO , withEffToIO- , withConcEffToIO+ , reallyUnsafeLiftMapIO+ , reallyUnsafeUnliftIO -- ** Low-level unlifts , seqUnliftIO+ , seqForkUnliftIO , concUnliftIO -- * Dispatch@@ -58,6 +59,7 @@ , EffectHandler , LocalEnv(..) , Handler(..)+ , HandlerImpl(..) , relinkHandler , runHandler , send@@ -73,16 +75,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 +120,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 +140,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 +184,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,32 +199,38 @@ -> 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 #-} --- | Create an unlifting function with the 'ConcUnlift' strategy.------ @since 2.2.2.0-withConcEffToIO- :: (HasCallStack, IOE :> es)- => Persistence- -> Limit+-- | Create an unlifting function with the 'SeqUnlift' strategy.+seqUnliftIO+ :: HasCallStack+ => Env es+ -- ^ The environment. -> ((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-{-# DEPRECATED withConcEffToIO "Use withEffToIO with the appropriate strategy." #-}+ -> IO a+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 'SeqUnlift' strategy.-seqUnliftIO+-- | 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-seqUnliftIO es k = seqUnlift k es unEff+seqForkUnliftIO es0 k = cloneEnv es0 >>= \es -> seqUnliftIO es k+{-# INLINE seqForkUnliftIO #-} -- | Create an unlifting function with the 'ConcUnlift' strategy. concUnliftIO@@ -239,8 +242,58 @@ -> ((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 +-- | Utility for lifting 'IO' computations of type+--+-- @'IO' a -> 'IO' b@+--+-- to+--+-- @'Eff' es a -> 'Eff' es b@+--+-- This function is __really unsafe__ because:+--+-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'+-- computations.+--+-- - The 'IO' computation must run its argument in a way that's perceived as+-- sequential to the outside observer, e.g. in the same thread or in a worker+-- thread that finishes before the argument is run again.+--+-- __Warning:__ if you disregard the second point, you will experience weird+-- bugs, data races or internal consistency check failures.+--+-- When in doubt, use 'Effectful.Dispatch.Static.unsafeLiftMapIO', especially+-- since this version saves only a simple safety check per call of+-- @reallyUnsafeLiftMapIO f@.+reallyUnsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b+reallyUnsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es)++-- | Create an unlifting function.+--+-- This function is __really unsafe__ because:+--+-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'+-- computations.+--+-- - Unlifted 'Eff' computations must be run in a way that's perceived as+-- sequential to the outside observer, e.g. in the same thread as the caller+-- of 'reallyUnsafeUnliftIO' or in a worker thread that finishes before+-- another unlifted computation is run.+--+-- __Warning:__ if you disregard the second point, you will experience weird+-- bugs, data races or internal consistency check failures.+--+-- When in doubt, use 'Effectful.Dispatch.Static.unsafeSeqUnliftIO', especially+-- since this version saves only a simple safety check per call of the unlifting+-- function.+reallyUnsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a+reallyUnsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es)+ ---------------------------------------- -- Base @@ -256,10 +309,9 @@ liftA2 f (Eff ma) (Eff mb) = unsafeEff $ \es -> liftA2 f (ma es) (mb es) instance Monad (Eff es) where- return = unsafeEff_ . pure Eff m >>= k = unsafeEff $ \es -> m es >>= \a -> unEff (k a) es -- https://gitlab.haskell.org/ghc/ghc/-/issues/20008- Eff ma >> Eff mb = unsafeEff $ \es -> ma es >> mb es+ {-# INLINE (>>=) #-} instance MonadFix (Eff es) where mfix f = unsafeEff $ \es -> mfix $ \a -> unEff (f a) es@@ -270,6 +322,10 @@ -- | Provide the ability to use the 'Alternative' and 'MonadPlus' instance for -- 'Eff'. --+-- /Note:/ 'NonDet' does not backtrack. Formally, it obeys the "left-catch" law+-- for 'MonadPlus', rather than the "left-distribution" law. This means that it+-- behaves more like 'Maybe' than @[]@.+-- -- @since 2.2.0.0 data NonDet :: Effect where Empty :: NonDet m a@@ -279,7 +335,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@@ -289,27 +345,40 @@ -- Exception instance C.MonadThrow (Eff es) where- throwM = unsafeEff_ . E.throwIO+ throwM = unsafeEff_ . withFrozenCallStack E.throwIO instance C.MonadCatch (Eff es) where- catch m handler = unsafeEff $ \es -> do- unEff m es `E.catch` \e -> do- unEff (handler e) es+ catch action handler = reallyUnsafeUnliftIO $ \unlift -> do+ E.catch (unlift action) (unlift . handler) instance C.MonadMask (Eff es) where- mask k = unsafeEff $ \es -> E.mask $ \unmask ->- unEff (k $ \m -> unsafeEff $ unmask . unEff m) es+ mask k = reallyUnsafeUnliftIO $ \unlift -> do+ E.mask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release) - uninterruptibleMask k = unsafeEff $ \es -> E.uninterruptibleMask $ \unmask ->- unEff (k $ \m -> unsafeEff $ unmask . unEff m) es+ uninterruptibleMask k = reallyUnsafeUnliftIO $ \unlift -> do+ E.uninterruptibleMask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release) - generalBracket acquire release use = unsafeEff $ \es -> E.mask $ \unmask -> do- resource <- unEff acquire es- b <- unmask (unEff (use resource) es) `E.catch` \e -> do- _ <- unEff (release resource $ C.ExitCaseException e) es- E.throwIO e- c <- unEff (release resource $ C.ExitCaseSuccess b) es- pure (b, c)+ generalBracket before after action = reallyUnsafeUnliftIO $ \unlift -> do+ E.mask $ \unmask -> do+ a <- unlift before+#if MIN_VERSION_base(4,21,0)+ b <- E.catchNoPropagate+ (unmask . unlift $ action a)+ (\ec@(E.ExceptionWithContext _ e) -> do+ _ <- E.annotateIO (E.WhileHandling (E.toException ec)) $ do+ unlift . after a $ C.ExitCaseException e+ E.rethrowIO ec+ )+#else+ b <- E.catch+ (unmask . unlift $ action a)+ (\e -> do+ _ <- unlift . after a $ C.ExitCaseException e+ E.throwIO e+ )+#endif+ c <- unlift . after a $ C.ExitCaseSuccess b+ pure (b, c) ---------------------------------------- -- Fail@@ -321,7 +390,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 +408,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 +456,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@@ -398,7 +467,7 @@ -- Lifting -- | Lift an 'Eff' computation into an effect stack with one more effect.-raise :: Eff es a -> Eff (e : es) a+raise :: forall e es a. Eff es a -> Eff (e : es) a raise m = unsafeEff $ \es -> unEff m =<< tailEnv es -- | Lift an 'Eff' computation into an effect stack with one more effect and@@ -411,23 +480,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 +545,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,19 +563,23 @@ 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 +-- | Wrapper to prevent a space leak on reconstruction of 'Handler' in+-- 'relinkHandler' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).+newtype HandlerImpl e es = HandlerImpl (EffectHandler e es)+ -- | An internal representation of dynamically dispatched effects, i.e. the -- effect handler bundled with its environment. data Handler :: Effect -> Type where- Handler :: !(Env handlerEs) -> !(EffectHandler e handlerEs) -> Handler e+ Handler :: !(Env handlerEs) -> !(HandlerImpl e handlerEs) -> Handler e type instance EffectRep Dynamic = Handler relinkHandler :: Relinker Handler e@@ -515,7 +588,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)@@ -529,11 +606,13 @@ -- ^ The operation. -> Eff es a send op = unsafeEff $ \es -> do- Handler handlerEs handler <- getEnv es- -- 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- -- stack frames from inside the effect handler continue to be added.+ Handler handlerEs (HandlerImpl handler) <- getEnv es+ when (envStorage es /= envStorage handlerEs) $ do+ error "es and handlerEs point to different Storages"+ -- Prevent the addition of unnecessary 'handler' stack frame to the call+ -- stack. Note that functions 'interpret', 'reinterpret', 'interpose' and+ -- 'impose' need to thaw the call stack so that useful stack frames from+ -- inside the effect handler continue to be added. unEff (withFrozenCallStack handler (LocalEnv es) op) handlerEs {-# NOINLINE send #-} @@ -553,7 +632,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 +645,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 +658,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 +669,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)
src/Effectful/Internal/Unlift.hs view
@@ -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
src/Effectful/Internal/Utils.hs view
@@ -14,31 +14,18 @@ , toAny , fromAny - -- * Strict 'IORef'- , IORef'- , newIORef'- , readIORef'- , writeIORef'-- -- * Strict 'MVar'- , MVar'- , toMVar'- , newMVar'- , readMVar'- , modifyMVar'- , modifyMVar_'- -- * Unique , Unique , newUnique - -- * CallStack+ -- * CallStack , thawCallStack++ -- * Array capacity+ , growCapacity ) 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)@@ -128,49 +115,6 @@ ---------------------------------------- --- | 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------------------------------------------- -- | A unique with no possibility for CAS contention. -- -- Credits for this go to Edward Kmett.@@ -188,3 +132,11 @@ thawCallStack = \case FreezeCallStack cs -> cs cs -> cs++----------------------------------------++-- | Grow capacity of an array.+--+-- See https://archive.ph/Z2R8w.+growCapacity :: Int -> Int+growCapacity n = 1 + quot (n * 3) 2
src/Effectful/Labeled.hs view
@@ -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
+ src/Effectful/Labeled/Error.hs view
@@ -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))
+ src/Effectful/Labeled/Reader.hs view
@@ -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
+ src/Effectful/Labeled/State.hs view
@@ -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)
+ src/Effectful/Labeled/Writer.hs view
@@ -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)
src/Effectful/NonDet.hs view
@@ -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,19 +31,25 @@ 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- = 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 +57,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+ backupData <- unsafeEff backupStorageData localSeqUnlift env $ \unlift -> do- mr <- (Just <$> unlift m1) `catchError` \_ () -> do- -- If m1 failed, roll back the environment.- restoreLocalEnv env backupEnv+ mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> do+ -- 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+ backupData <- unsafeEff backupStorageData+ runError @ErrorEmpty action >>= \case+ Right r -> pure $ Right r+ Left (cs, _) -> do+ -- If the whole action failed, restore the data.+ unsafeEff $ I.restoreStorageData backupData+ pure $ Left cs ---------------------------------------- @@ -85,28 +111,34 @@ -- -- @since 2.2.0.0 emptyEff :: (HasCallStack, NonDet :> es) => Eff es a-emptyEff = withFrozenCallStack $ send Empty+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 +-- | 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- -> Eff es (LocalEnv localEs handlerEs)-cloneLocalEnv = coerce . unsafeEff_ . cloneEnv . coerce--restoreLocalEnv- :: 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)
src/Effectful/Provider.hs view
@@ -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] -- :} --@@ -121,56 +123,68 @@ type instance DispatchOf (Provider e input f) = Static NoSideEffects +-- | Wrapper to prevent a space leak on reconstruction of 'Provider' in+-- 'relinkProvider' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).+newtype ProviderImpl input f e es where+ ProviderImpl+ :: (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r))+ -> ProviderImpl input f e es+ 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)+ -> !(ProviderImpl input f e handlerEs)+ -> 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- inlineBracket- (consEnv (Provider es0 run) relinkProvider es0)- unconsEnv- (\es -> unEff m es)+runProvider provider action = runProviderImpl action $+ ProviderImpl (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 action = runProviderImpl action $+ ProviderImpl $ let ?callStack = thawCallStack ?callStack+ in \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 (ProviderImpl 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@@ -183,18 +197,34 @@ ---------------------------------------- -- Helpers +runProviderImpl+ :: HasCallStack+ => Eff (Provider e input f : es) a+ -> ProviderImpl input f e es+ -> Eff es a+runProviderImpl action providerImpl = unsafeEff $ \es -> do+ inlineBracket+ (consEnv (Provider es providerImpl) relinkProvider es)+ unconsEnv+ (unEff action)+{-# INLINE runProviderImpl #-}+ relinkProvider :: Relinker StaticRep (Provider e input f) relinkProvider = Relinker $ \relink (Provider handlerEs run) -> do 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
src/Effectful/Provider/List.hs view
@@ -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,97 @@ 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+-- | Wrapper to prevent a space leak on reconstruction of 'ProviderList' in+-- 'relinkProviderList' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).+newtype ProviderListImpl input f providedEs es where+ ProviderListImpl+ :: (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r))+ -> ProviderListImpl input f providedEs es++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)+ -> !(ProviderListImpl input f providedEs handlerEs)+ -> 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- inlineBracket- (consEnv (ProviderList es0 run) relinkProviderList es0)- unconsEnv- (\es -> unEff m es)+runProviderList providerList action = runProviderListImpl action $+ ProviderListImpl (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 action = runProviderListImpl action $+ ProviderListImpl $ let ?callStack = thawCallStack ?callStack+ in \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) (ProviderListImpl 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@@ -123,24 +136,36 @@ ---------------------------------------- -- Helpers +runProviderListImpl+ :: (HasCallStack, KnownEffects providedEs)+ => Eff (ProviderList providedEs input f : es) a+ -> ProviderListImpl input f providedEs es+ -> Eff es a+runProviderListImpl action providerListImpl = unsafeEff $ \es -> do+ inlineBracket+ (consEnv (ProviderList es providerListImpl) relinkProviderList es)+ unconsEnv+ (unEff action)+{-# INLINE runProviderListImpl #-}+ relinkProviderList :: Relinker StaticRep (ProviderList e input f) relinkProviderList = Relinker $ \relink (ProviderList handlerEs run) -> do newHandlerEs <- relink handlerEs 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
src/Effectful/Reader/Dynamic.hs view
@@ -1,7 +1,8 @@ -- | The dynamically dispatched variant of the 'Reader' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use the statically dispatched variant,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.Reader.MonadReader' instance for compatibility with existing+-- code, it's recommended to use the statically dispatched variant, -- i.e. "Effectful.Reader.Static". module Effectful.Reader.Dynamic ( -- * Effect@@ -19,29 +20,28 @@ import Effectful import Effectful.Dispatch.Dynamic-import Effectful.Reader.Static qualified as R--data Reader r :: Effect where- Ask :: Reader r m r- Local :: (r -> r) -> m a -> Reader r m a--type instance DispatchOf (Reader r) = Dynamic+import Effectful.Internal.MTL (Reader(..)) --- | Run the 'Reader' effect with the given initial environment (via--- "Effectful.Reader.Static").+-- | Run the '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 = reinterpret (R.runReader r) $ \env -> \case- Ask -> R.ask- Local f m -> localSeqUnlift env $ \unlift -> R.local f (unlift m)+runReader r0 = interpret $ handler r0+ where+ handler :: r -> EffectHandler (Reader r) es+ handler r env = \case+ Ask -> pure r+ Local f action -> localSeqUnlift env $ \unlift -> do+ unlift $ interpose (handler $ f r) action -- | Execute a computation in a modified environment. -- -- @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.@@ -49,6 +49,7 @@ withReader f m = do r <- ask raise $ runReader (f r) m+{-# DEPRECATED withReader "withReader doesn't work correctly for all potential interpreters" #-} ---------------------------------------- -- Operations
src/Effectful/Reader/Static.hs view
@@ -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
src/Effectful/State/Dynamic.hs view
@@ -1,7 +1,8 @@ -- | The dynamically dispatched variant of the 'State' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use one of the statically dispatched variants,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.State.MonadState' instance for compatibility with existing+-- code, it's recommended to use one of the statically dispatched variants, -- i.e. "Effectful.State.Static.Local" or "Effectful.State.Static.Shared". module Effectful.State.Dynamic ( -- * Effect@@ -31,41 +32,29 @@ import Effectful import Effectful.Dispatch.Dynamic+import Effectful.Internal.MTL (State(..)) import Effectful.State.Static.Local qualified as L import Effectful.State.Static.Shared qualified as S --- | Provide access to a mutable value of type @s@.-data State s :: Effect where- Get :: State s m s- Put :: s -> State s m ()- State :: (s -> (a, s)) -> State s m a- StateM :: (s -> m (a, s)) -> State s m a--type instance DispatchOf (State s) = Dynamic- ---------------------------------------- -- 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 :: 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 +66,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
src/Effectful/State/Static/Local.hs view
@@ -7,7 +7,9 @@ -- 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.Exception (ErrorCall)+-- >>> import Control.Monad.Catch+-- >>> import Control.Monad.Trans.State.Strict qualified as S -- -- >>> :{ -- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do@@ -41,11 +43,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 +57,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 +68,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 +77,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 +86,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 +95,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 +115,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 +133,7 @@ -- -- @'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
@@ -7,7 +7,9 @@ -- 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.Exception (ErrorCall)+-- >>> import Control.Monad.Catch+-- >>> import Control.Monad.Trans.State.Strict qualified as S -- -- >>> :{ -- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do@@ -45,22 +47,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 +70,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 +111,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 +133,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 +151,5 @@ -- @'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
src/Effectful/Writer/Dynamic.hs view
@@ -1,7 +1,9 @@+{-# OPTIONS_GHC -Wno-orphans #-} -- | The dynamically dispatched variant of the 'Writer' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use one of the statically dispatched variants,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.Writer.MonadWriter' instance for compatibility with existing+-- code, it's recommended to use one of the statically dispatched variants, -- i.e. "Effectful.Writer.Static.Local" or "Effectful.Writer.Static.Shared". module Effectful.Writer.Dynamic ( -- * Effect@@ -25,34 +27,24 @@ import Effectful import Effectful.Dispatch.Dynamic+import Effectful.Internal.MTL (Writer(..)) import Effectful.Writer.Static.Local qualified as L import Effectful.Writer.Static.Shared qualified as S --- | Provide access to a write only value of type @w@.-data Writer w :: Effect where- Tell :: w -> Writer w m ()- Listen :: m a -> Writer w m (a, w)--type instance DispatchOf (Writer w) = Dynamic- ---------------------------------------- -- Local -- | 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 +54,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)
src/Effectful/Writer/Static/Local.hs view
@@ -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