effectful-core 2.1.0.0 → 2.6.1.0
raw patch · 38 files changed
Files
- CHANGELOG.md +122/−0
- README.md +66/−46
- cbits/utils.c +5/−0
- effectful-core.cabal +30/−19
- src/Effectful.hs +13/−9
- src/Effectful/Dispatch/Dynamic.hs +684/−104
- src/Effectful/Dispatch/Static.hs +3/−5
- src/Effectful/Dispatch/Static/Primitive.hs +2/−2
- src/Effectful/Dispatch/Static/Unsafe.hs +0/−34
- src/Effectful/Error/Dynamic.hs +68/−16
- src/Effectful/Error/Static.hs +103/−65
- src/Effectful/Exception.hs +644/−0
- src/Effectful/Fail.hs +4/−4
- src/Effectful/Internal/Effect.hs +82/−10
- src/Effectful/Internal/Env.hs +260/−113
- src/Effectful/Internal/MTL.hs +90/−0
- src/Effectful/Internal/Monad.hs +322/−106
- src/Effectful/Internal/Unlift.hs +94/−85
- src/Effectful/Internal/Utils.hs +142/−0
- src/Effectful/Labeled.hs +79/−0
- 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 +144/−0
- src/Effectful/Prim.hs +1/−0
- src/Effectful/Provider.hs +230/−0
- src/Effectful/Provider/List.hs +171/−0
- src/Effectful/Reader/Dynamic.hs +17/−16
- src/Effectful/Reader/Static.hs +10/−6
- src/Effectful/State/Dynamic.hs +14/−29
- src/Effectful/State/Static/Local.hs +19/−16
- src/Effectful/State/Static/Shared.hs +36/−38
- src/Effectful/Writer/Dynamic.hs +13/−25
- src/Effectful/Writer/Static/Local.hs +14/−9
- src/Effectful/Writer/Static/Shared.hs +23/−18
- utils/Effectful/Internal/Utils.hs +0/−49
- utils/utils.c +0/−5
CHANGELOG.md view
@@ -1,3 +1,125 @@+# 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`.+* Add `Effectful.Provider.List`, generalization of `Effectful.Provider`.+* Respect `withFrozenCallStack` used by callers of `send`.+* Support exchange of effects between the environment of the handler and the+ local one via `localSeqLend`, `localLend`, `localSeqBorrow` and `localBorrow`+ from `Effectful.Dispatch.Dynamic`.++# effectful-core-2.3.0.1 (2023-11-13)+* Prevent internal functions from appending call stack frames to handlers.++# effectful-core-2.3.0.0 (2023-09-13)+* Deprecate `withConcEffToIO`.+* Make `withEffToIO` take an explicit unlifting strategy for the sake of+ consistency with unlifting functions from `Effectful.Dispatch.Dynamic` and+ easier to understand API.+* Add support for turning an effect handler into an effectful operation via the+ `Provider` effect.+* Add `runErrorWith` and `runErrorNoCallStackWith` to `Effectful.Error.Dynamic`+ and `Effectful.Error.Static`.+* Add support for having multiple effects of the same type in scope via the+ `Labeled` effect.++# effectful-core-2.2.2.2 (2023-03-13)+* Allow `inject` to turn a monomorphic effect stack into a polymorphic one.+* Use C sources only with GHC < 9.+* Force inlining of `bracket` early to work around excessive inlining problem+ with GHC 9.6 (https://gitlab.haskell.org/ghc/ghc/-/issues/22824).++# effectful-core-2.2.2.1 (2023-01-12)+* Stop using the internal library because of bugs in `stack`.++# effectful-core-2.2.2.0 (2023-01-11)+* Add `withSeqEffToIO` and `withConcEffToIO` to `Effectful`.+* Use strict `IORef` and `MVar` variants where appropriate.+* Make `inject` work with effect stacks sharing a polymorphic suffix.++# effectful-core-2.2.1.0 (2022-11-09)+* Add `localSeqLift` and `localLift` to `Effectful.Dispatch.Dynamic`.++# effectful-core-2.2.0.0 (2022-10-24)+* Change `PrimState` for `Eff` from `RealWorld` to `PrimStateEff` to prevent the+ `Prim` effect from executing arbitrary `IO` actions via `ioToPrim`.+* Deprecate `(:>>)` as [GHC can't efficiently deal with type+ families](https://github.com/haskell-effectful/effectful/issues/52#issuecomment-1269155485).+* Add support for the `Alternative` and `MonadPlus` instances for `Eff` via the+ `NonDet` effect.+ # effectful-core-2.1.0.0 (2022-08-22) * Include the `e :> localEs` constraint in the `EffectHandler` to allow more flexibility in handling higher order effects.
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.@@ -38,30 +37,23 @@ [freer-simple](https://hackage.haskell.org/package/freer-simple), [fused-effects](https://hackage.haskell.org/package/fused-effects), [polysemy](https://hackage.haskell.org/package/polysemy),-[eff](https://github.com/hasura/eff) and probably a few more.+[eff](https://github.com/lexi-lambda/eff) and probably a few more. -Unfortunately, of all of them only `eff` is a promising proposition because of-reasonable performance characteristics (see the talk [Effects for-Less](https://www.youtube.com/watch?v=0jI-AlWEwYI) for more information) and-potential for good interoperability with the existing ecosystem.+It needs to be noted that of all of them only the work-in-progress `eff` library+is a promising proposition because of reasonable performance characteristics+(see the talk [Effects for Less](https://www.youtube.com/watch?v=0jI-AlWEwYI)+for more information) and potential for good interoperability with the existing+ecosystem. The second point is arguably the most important, because it allows focusing on things that matter instead of reinventing all kinds of wheels, hence being a necessary condition for broader adoption of the library. -However, `eff` uses delimited continuations underneath, which:--- Are not yet supported by GHC (though [the-proposal](https://github.com/ghc-proposals/ghc-proposals/pull/313) for including-support for them has been accepted).--- Are quite hard to understand.--- Make the library "too powerful" in a sense as it faces- [a](https://github.com/hasura/eff/issues/13)- [few](https://github.com/hasura/eff/issues/7)- [issues](https://github.com/hasura/eff/issues/12) with no clear path towards- their resolution.+Unfortunately, the development of `eff` has stalled due to a+[few](https://github.com/hasura/eff/issues/13)+[subtle](https://github.com/hasura/eff/issues/7)+[issues](https://github.com/hasura/eff/issues/12) related to its use of+delimited continuations underneath. ### What about `mtl`? @@ -96,13 +88,24 @@ What is more, the `Eff` monad is concrete, so GHC has many possibilities for optimization, which results in a very fast code at a default optimization-level. There is no need to mark every function `INLINE` or enable additional-optimization passes, it just works.+level. There is no need to explicitly mark functions with `INLINE` pragmas or+enable additional optimization passes, it just works. ### Any downsides? -As always, there's no free lunch. The `Eff` monad doesn't support `NonDet` nor-`Coroutine` effects. However, the `NonDet` effect in existing libraries is+As always, there's no free lunch. The `Eff` monad doesn't support effect+handlers that require the ability to suspend or capture the rest of the+computation and resume it later (potentially multiple times). This prevents+`effectful` from providing (in particular):++- A `NonDet` effect handler that executes multiple+[`Alternative`](https://hackage.haskell.org/package/base/docs/Control-Applicative.html#t:Alternative)+branches and collects their results.++- A `Coroutine` effect.++It needs to be noted however that such `NonDet` effect handler in existing+libraries is [broken](https://github.com/lexi-lambda/eff/blob/8c4df4bf54faf22456354be18095b14825be5e85/notes/semantics-zoo.md) and none of the ones with support for higher order effects provide the `Coroutine` effect, so arguably it's not a big loss.@@ -110,48 +113,65 @@ If you need such capability in your application, there are well established libraries such as [conduit](https://hackage.haskell.org/package/conduit) or [list-t](https://hackage.haskell.org/package/list-t) that can be used with-`effectful` without any issues.+`effectful` without any hassle. ### Summary -`effectful` is an extensible effects library that aims to replace "boring"-transformer stacks (which consist of a dozen of newtype'd `ExceptT`, `ReaderT`,-`StateT` and `WriterT` transformers) and their derivatives by providing-equivalent effects with improved semantics, performance and usability (it also-makes it easy to reuse them for your own effects). It doesn't try to make monad-transformers obsolete, so you're free to use it with `ConduitT`, `ContT`,-`ListT` etc. when necessary.+`effectful` is an extensible effects library that aims to be the replacement+for: +- The bare `ReaderT` pattern by being essentially its enriched version.++- Monad transformer stacks typically encountered in the wild (i.e. consisting of+ a dozen of newtype'd `ExceptT`, `ReaderT`, `StateT` and `WriterT` transformers+ and their derivatives) by providing equivalent effects with improved+ semantics, performance, usability and making it easy to reuse them for your+ own effects.++It doesn't try to make monad transformers obsolete, so you're free to+use it with `ConduitT`, `ContT`, `ListT` etc. when necessary.+ ## Package structure -The effect system is split among several libraries:+The library is split among several packages: - The [`effectful-core`](https://hackage.haskell.org/package/effectful-core)- library contains the core of the effect system along with the basic- effects. It aims for a small dependency footprint and provides building blocks- for more advanced effects.+ package contains the core of the library along with basic effects. It aims for+ a small dependency footprint and provides building blocks for more advanced+ effects. - The [`effectful-plugin`](https://hackage.haskell.org/package/effectful-plugin)- library provides an optional GHC plugin for improving disambiguation of+ package provides an optional GHC plugin for improving disambiguation of effects (see [here](https://github.com/haskell-effectful/effectful/blob/master/effectful-plugin/README.md) for more information). -- The [`effectful-th`](https://hackage.haskell.org/package/effectful-th) library+- The [`effectful-th`](https://hackage.haskell.org/package/effectful-th) package provides utilities for generating bits of effect-related boilerplate via Template Haskell. -- The [`effectful`](https://hackage.haskell.org/package/effectful) library+- The [`effectful`](https://hackage.haskell.org/package/effectful) package re-exports public modules of `effectful-core` and additionally provides most- features of the `unliftio` library divided into appropriate effects.+ features of the [`unliftio`](https://hackage.haskell.org/package/unliftio)+ package divided into appropriate effects. -## Example+## Examples -A `Filesystem` effect with two handlers, one that runs in `IO` and another that-uses an in-memory virtual file system can be found-[here](https://github.com/haskell-effectful/effectful/blob/master/effectful/examples/FileSystem.hs).+For the examples see the *Introduction* sections of+[`Effectful.Dispatch.Dynamic`](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Dynamic.html)+and+[`Effectful.Dispatch.Static`](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Static.html)+(when in doubt, start with dynamic dispatch). -## Resources+## Acknowledgements++To all contributors of existing effect libraries - thank you for putting the+time and effort to explore the space. In particular, conversations in issue+trackers of `cleff`, `eff`, `freer-simple`, `fused-effects` and `polysemy`+repositories were invaluable in helping me discover and understand challenges in+the space.++### Resources Resources that inspired the rise of this library and had a lot of impact on its design.
+ cbits/utils.c view
@@ -0,0 +1,5 @@+// Correct implementation of ThreadId# equality for GHC < 9.+long effectful_eq_thread(void *tso1, void *tso2)+{+ return tso1 == tso2;+}
effectful-core.cabal view
@@ -1,7 +1,7 @@-cabal-version: 2.4+cabal-version: 3.0 build-type: Simple name: effectful-core-version: 2.1.0.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.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.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,11 @@ 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 @@ -38,13 +42,16 @@ DataKinds DeriveFunctor DeriveGeneric+ DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving+ ImportQualifiedPost LambdaCase MultiParamTypeClasses NoStarIsType+ PolyKinds RankNTypes RoleAnnotations ScopedTypeVariables@@ -53,34 +60,29 @@ TypeApplications TypeFamilies TypeOperators--library effectful-internal-utils- import: language-- build-depends: base-- hs-source-dirs: utils- c-sources: utils/utils.c-- exposed-modules: Effectful.Internal.Utils+ UndecidableInstances library import: language ghc-options: -O2 - build-depends: effectful-internal-utils-- build-depends: base >= 4.13 && < 5+ 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 hs-source-dirs: src + if impl(ghc < 9)+ c-sources: cbits/utils.c+ exposed-modules: Effectful Effectful.Dispatch.Dynamic Effectful.Dispatch.Static@@ -88,12 +90,23 @@ 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+ Effectful.Provider.List Effectful.Reader.Dynamic Effectful.Reader.Static Effectful.State.Dynamic@@ -102,5 +115,3 @@ Effectful.Writer.Dynamic Effectful.Writer.Static.Local Effectful.Writer.Static.Shared-- reexported-modules: Effectful.Internal.Utils
src/Effectful.hs view
@@ -44,6 +44,7 @@ , Limit(..) , unliftStrategy , withUnliftStrategy+ , withSeqEffToIO , withEffToIO -- ** Lifting@@ -63,6 +64,7 @@ import Effectful.Internal.Effect import Effectful.Internal.Env+import Effectful.Internal.MTL () import Effectful.Internal.Monad -- $intro@@ -95,7 +97,8 @@ -- -- It implements support for extensible effects with both dynamic and static -- dispatch. For more information about each type consult the documentation in--- "Effectful.Dispatch.Dynamic" and "Effectful.Dispatch.Static".+-- "Effectful.Dispatch.Dynamic" and "Effectful.Dispatch.Static" (when in doubt,+-- start with dynamic dispatch). -- -- The library provides: --@@ -107,7 +110,8 @@ -- t'Effectful.Writer.Static.Local.Writer'. -- -- - Utilities for defining new effects and interpreting them, possibly in terms--- of already existing ones.+-- of already existing ones (see introduction of the+-- "Effectful.Dispatch.Dynamic" module for more information). -- -- While basic effects can be used out of the box, in general it's recommended -- to create your own that serve a more specific purpose.@@ -116,7 +120,7 @@ -- $integration -- -- Integration with most of existing libraries and frameworks can be done quite--- easily. The main difference on how that looks like depends on the way a+-- easily. The main difference in how that looks like depends on the way a -- library operates in a monadic context. -- -- There are three main groups a library might fall into. It either operates:@@ -144,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@@ -158,9 +162,9 @@ -- If a library operates in 'IO', there are a couple of ways to integrate it. -- -- The easiest way is to use its functions selectively in the 'Eff' monad with--- the help of 'liftIO' or 'withEffToIO' / 'withRunInIO'. However, this is not--- particularly robust, since it vastly broadens the scope in which the 'IOE'--- effect is needed (not to mention that explicit lifting is annoying).+-- the help of 'liftIO' or 'withEffToIO'. However, this is not particularly+-- robust, since it vastly broadens the scope in which the 'IOE' effect is+-- needed (not to mention that explicit lifting is annoying). -- -- A somewhat better approach is to create a dummy static effect with -- lightweight wrappers of the library functions. As an example have a look at@@ -195,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,4 +1,5 @@-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ImplicitParams #-} -- | Dynamically dispatched effects. module Effectful.Dispatch.Dynamic ( -- * Introduction@@ -13,15 +14,23 @@ -- ** Integration with @mtl@ style effects -- $integration + -- *** Functional dependencies+ -- $mtl-fundeps+ -- * Sending operations to the handler send+ , passthrough -- * Handling effects , EffectHandler , interpret+ , interpretWith , reinterpret+ , reinterpretWith , interpose+ , interposeWith , impose+ , imposeWith -- ** Handling local 'Eff' computations , LocalEnv@@ -33,6 +42,8 @@ , localUnliftIO -- *** Lifts+ , localSeqLift+ , localLift , withLiftMap , withLiftMapIO @@ -40,21 +51,38 @@ , localLiftUnlift , localLiftUnliftIO - -- *** Utils+ -- *** Misc+ , localSeqLend+ , localLend+ , localSeqBorrow+ , localBorrow , SharedSuffix+ , KnownSubset + -- ** Utils for first order effects+ , EffectHandler_+ , interpret_+ , interpretWith_+ , reinterpret_+ , reinterpretWith_+ , interpose_+ , interposeWith_+ , impose_+ , imposeWith_+ -- * Re-exports , HasCallStack ) where -import Control.Exception (bracket)-import Control.Monad.IO.Unlift-import GHC.Stack (HasCallStack)+import Control.Monad+import Data.Primitive.PrimArray+import GHC.Stack import GHC.TypeLits import Effectful.Internal.Effect import Effectful.Internal.Env import Effectful.Internal.Monad+import Effectful.Internal.Utils -- $intro --@@ -126,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 --@@ -143,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@@ -152,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 -- -- >>> :{@@ -200,10 +225,13 @@ -- -- If an effect makes use of the @m@ parameter, it is a /higher order effect/. ----- Interpretation of higher order effects is slightly more involved. To see why,--- let's consider the @Profiling@ effect for logging how much time a specific--- action took to run:+-- /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:+-- -- >>> :{ -- data Profiling :: Effect where -- Profile :: String -> m a -> Profiling m a@@ -236,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:@@ -320,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@@ -331,7 +357,7 @@ -- -- >>> :{ -- runDummyRNG :: Eff (RNG : es) a -> Eff es a--- runDummyRNG = interpret $ \_ -> \case+-- runDummyRNG = interpret_ $ \case -- RandomInt -> pure 55 -- :} --@@ -342,34 +368,161 @@ -- "777" -- +-- $mtl-fundeps+--+-- For dealing with classes that employ functional dependencies an additional+-- trick is needed.+--+-- Consider the following:+--+-- >>> :set -XFunctionalDependencies+--+-- >>> :{+-- class Monad m => MonadInput i m | m -> i where+-- input :: m i+-- :}+--+-- An attempt to define the instance as in the example above leads to violation+-- of the liberal coverage condition:+--+-- >>> :{+-- instance Reader i :> es => MonadInput i (Eff es) where+-- input = ask+-- :}+-- ...+-- ...Illegal instance declaration for ‘MonadInput i (Eff es)’...+-- ... The liberal coverage condition fails in class ‘MonadInput’...+-- ... for functional dependency: ‘m -> i’...+-- ...+--+-- 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+-- input = ask+-- :}+--+-- Now the @MonadInput@ class can be used with the 'Eff' monad:+--+-- >>> :{+-- double :: MonadInput Int m => m Int+-- double = (+) <$> input <*> input+-- :}+--+-- >>> 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:/ 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 (Handler es handler) m+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 (Handler handlerEs handler) m+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@@ -377,82 +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- bracket (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 handler)- unEff m es- )+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- bracket (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 (Handler handlerEs handler)- unEff m es- )+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@@ -465,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'.@@ -477,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@@ -488,13 +784,16 @@ -> ((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. localUnliftIO@@ -505,10 +804,56 @@ -> ((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 #-} +----------------------------------------+-- Lifts++-- | Create a local lifting function with the 'SeqUnlift' strategy. For the+-- general version see 'localLift'.+--+-- @since 2.2.1.0+localSeqLift+ :: (HasCallStack, SharedSuffix es handlerEs)+ => LocalEnv localEs handlerEs+ -- ^ Local environment.+ -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a)+ -- ^ Continuation with the lifting function in scope.+ -> Eff es a+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.+--+-- @since 2.2.1.0+localLift+ :: (HasCallStack, SharedSuffix es handlerEs)+ => LocalEnv localEs handlerEs+ -- ^ Local environment.+ -> UnliftStrategy+ -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a)+ -- ^ Continuation with the lifting function in scope.+ -> Eff es a+localLift (LocalEnv les) strategy k = unsafeEff $ \es -> do+ requireMatchingStorages es les+ case strategy of+ SeqUnlift -> seqUnliftIO es $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift+ 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 -- -- @'Eff' es a -> 'Eff' es b@@@ -526,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 --@@ -566,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@@ -589,15 +935,19 @@ -> ((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 #-} -- | Create a local unlifting function with the given strategy along with an -- unrestricted lifting function.@@ -615,13 +965,136 @@ -> ((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 #-} ------------------------------------------- Utils+-- Misc +-- | Lend effects to the local environment.+--+-- Consider the following effect:+--+-- >>> :{+-- data D :: Effect where+-- D :: D m ()+-- type instance DispatchOf D = Dynamic+-- :}+--+-- and an auxiliary effect that requires both @IOE@ and @D@ to run:+--+-- >>> :{+-- data E :: Effect+-- runE :: (IOE :> es, D :> es) => Eff (E : es) a -> Eff es a+-- runE = error "runE"+-- :}+--+-- Trying to use @runE@ inside the handler of @D@ doesn't work out of the box:+--+-- >>> :{+-- runD :: IOE :> es => Eff (D : es) a -> Eff es a+-- runD = interpret $ \env -> \case+-- D -> localSeqUnlift env $ \unlift -> do+-- unlift . runE $ pure ()+-- :}+-- ...+-- ...Could not deduce ...IOE :> localEs... arising from a use of ‘runE’+-- ...from the context: IOE :> es+-- ...+--+-- The problem is that @runE@ needs @IOE :> localEs@, but only @IOE :> es@ is+-- available. This function allows us to bridge the gap:+--+-- >>> :{+-- runD :: IOE :> es => Eff (D : es) a -> Eff es a+-- runD = interpret $ \env -> \case+-- D -> localSeqUnlift env $ \unlift -> do+-- localSeqLend @'[IOE] env $ \useIOE -> do+-- unlift . useIOE . runE $ pure ()+-- :}+--+-- @since 2.4.0.0+localSeqLend+ :: forall lentEs es handlerEs localEs a+ . (HasCallStack, KnownSubset lentEs es, SharedSuffix es handlerEs)+ => LocalEnv localEs handlerEs+ -> ((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 <- copyRefs @lentEs es les+ seqUnliftIO eles $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift+{-# INLINE localSeqLend #-}++-- | Lend effects to the local environment with a given unlifting strategy.+--+-- Generalizes 'localSeqLend'.+--+-- @since 2.4.0.0+localLend+ :: forall lentEs es handlerEs localEs a+ . (HasCallStack, KnownSubset lentEs es, SharedSuffix es handlerEs)+ => LocalEnv localEs handlerEs+ -> UnliftStrategy+ -> ((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 = 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 effects from the local environment.+--+-- @since 2.4.0.0+localSeqBorrow+ :: forall borrowedEs es handlerEs localEs a+ . (HasCallStack, KnownSubset borrowedEs localEs, SharedSuffix es handlerEs)+ => LocalEnv localEs handlerEs+ -> ((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 <- copyRefs @borrowedEs les es+ seqUnliftIO ees $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift+{-# INLINE localSeqBorrow #-}++-- | Borrow effects from the local environment with a given unlifting+-- strategy.+--+-- Generalizes 'localSeqBorrow'.+--+-- @since 2.4.0.0+localBorrow+ :: forall borrowedEs es handlerEs localEs a+ . (HasCallStack, KnownSubset borrowedEs localEs, SharedSuffix es handlerEs)+ => LocalEnv localEs handlerEs+ -> UnliftStrategy+ -> ((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 = 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 #-}+ -- | Require that both effect stacks share an opaque suffix. -- -- Functions from the 'localUnlift' family utilize this constraint to guarantee@@ -638,7 +1111,7 @@ -- Running local actions in a more specific environment is fine: -- -- >>> :{--- runE1 :: Eff (E ': es) a -> Eff es a+-- runE1 :: Eff (E : es) a -> Eff es a -- runE1 = interpret $ \env -> \case -- E m -> runReader () $ do -- localSeqUnlift env $ \unlift -> unlift m@@ -647,7 +1120,7 @@ -- Running local actions in a more general environment is fine: -- -- >>> :{--- runE2 :: Eff (E ': es) a -> Eff es a+-- runE2 :: Eff (E : es) a -> Eff es a -- runE2 = reinterpret (runReader ()) $ \env -> \case -- E m -> raise $ do -- localSeqUnlift env $ \unlift -> unlift m@@ -657,20 +1130,20 @@ -- this would make it possible to run anything within 'runPureEff': -- -- >>> :{--- runE3 :: Eff (E ': es) a -> Eff es a+-- runE3 :: Eff (E : es) a -> Eff es a -- runE3 = reinterpret (runReader ()) $ \env -> \case -- E m -> pure . runPureEff $ do -- localSeqUnlift env $ \unlift -> unlift m -- :} -- ...--- ...Could not deduce (SharedSuffix '[] es)...+-- ...Could not deduce ...SharedSuffix '[] es... -- ... -- -- Running local actions in a monomorphic effect stack is also not fine as -- this makes a special case of the above possible: -- -- >>> :{--- runE4 :: Eff '[E, IOE] a -> Eff '[IOE] a+-- runE4 :: Eff [E, IOE] a -> Eff '[IOE] a -- runE4 = interpret $ \env -> \case -- E m -> pure . runPureEff $ do -- localSeqUnlift env $ \unlift -> unlift m@@ -693,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.hs view
@@ -48,7 +48,7 @@ -- -- Unlike dynamically dispatched effects, statically dispatched effects have a -- single, set interpretation that cannot be changed at runtime, which makes--- them useful in specific scenatios. For example:+-- them useful in specific scenarios. For example: -- -- * If you'd like to ensure that a specific effect will behave in a certain way -- at all times, using a statically dispatched version is the only way to@@ -57,9 +57,7 @@ -- * If the effect you're about to define has only one reasonable -- implementation, it makes a lot of sense to make it statically dispatched. ----- Statically dispatched effects also perform slightly better than dynamically--- dispatched ones, because their operations are implemented as standard top--- level functions, so the compiler can apply more optimizations to them.+-- __When in doubt, use dynamic dispatch as it's more flexible.__ -- -- $example@@ -130,7 +128,7 @@ -- runLog logger = evalStaticRep (Log logger) -- :} -- ...--- ...No instance for (IOE :> es) arising from a use of ‘evalStaticRep’+-- ...No instance for ...IOE :> es... arising from a use of ‘evalStaticRep’ -- ... -- -- Including @'IOE' :> es@ in the context fixes the problem:
src/Effectful/Dispatch/Static/Primitive.hs view
@@ -5,8 +5,8 @@ -- sufficient. -- -- /Warning:/ playing the so called "type tetris" with functions from this--- module is not enough. Their misuse might lead to memory corruption or--- segmentation faults, so make sure you understand what you're doing.+-- module is not enough. Their misuse might lead to data races or internal+-- consistency check failures, so make sure you understand what you're doing. module Effectful.Dispatch.Static.Primitive ( -- * The environment Env
src/Effectful/Dispatch/Static/Unsafe.hs view
@@ -5,37 +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 __highly unsafe__ because:------ - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'--- computations.------ - The 'IO' computation must not run its argument in a different thread, but--- it's not checked anywhere.------ __If you disregard the second point, segmentation faults await.__-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 __highly unsafe__ because:------ - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'--- computations.------ - Unlifted 'Eff' computations must not be run in a thread distinct from the--- caller of 'reallyUnsafeUnliftIO', but it's not checked anywhere.------ __If you disregard the second point, segmentation faults await.__-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@@ -9,10 +10,14 @@ -- ** Handlers , runError+ , runErrorWith , runErrorNoCallStack+ , runErrorNoCallStackWith -- ** Operations+ , throwErrorWith , throwError+ , throwError_ , catchError , handleError , tryError@@ -28,38 +33,85 @@ import Effectful import Effectful.Dispatch.Dynamic-import qualified Effectful.Error.Static 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.Error.Static qualified as E+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) +-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific+-- error handler.+--+-- @since 2.3.0.0+runErrorWith+ :: HasCallStack+ => (E.CallStack -> e -> Eff es a)+ -- ^ The error handler.+ -> Eff (Error e : es) a+ -> Eff es a+runErrorWith handler m = runError m >>= \case+ Left (cs, e) -> handler cs e+ Right a -> pure a+ -- | Handle errors of type @e@ (via "Effectful.Error.Static"). In case of an -- error discard the 'E.CallStack'.+--+-- @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 --- | Throw an error of type @e@.+-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific+-- error handler. In case of an error discard the 'CallStack'.+runErrorNoCallStackWith+ :: HasCallStack+ => (e -> Eff es a)+ -- ^ The error handler.+ -> Eff (Error e : es) a+ -> Eff es a+runErrorNoCallStackWith handler m = runErrorNoCallStack m >>= \case+ Left e -> handler e+ Right a -> pure a++-- | 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@@ -74,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,17 +74,21 @@ -- -- /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 -- ** Handlers , runError+ , runErrorWith , runErrorNoCallStack+ , runErrorNoCallStackWith -- ** Operations+ , throwErrorWith , throwError+ , throwError_ , catchError , handleError , tryError@@ -96,17 +100,16 @@ , prettyCallStack ) where -import Control.Exception-import Data.Unique+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@@ -114,54 +117,98 @@ -- | 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+ :: HasCallStack+ => (CallStack -> e -> Eff es a)+ -- ^ The error handler.+ -> Eff (Error e : es) a+ -> Eff es a+runErrorWith handler action = runError action >>= \case+ Left (cs, e) -> handler cs e+ Right a -> pure a+ -- | Handle errors of type @e@. In case of an error discard the 'CallStack'.+--+-- @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 --- | Throw an error of type @e@.+-- | Handle errors of type @e@ with a specific error handler. In case of an+-- error discard the 'CallStack'.+runErrorNoCallStackWith+ :: HasCallStack+ => (e -> Eff es a)+ -- ^ The error handler.+ -> Eff (Error e : es) a+ -> Eff es a+runErrorNoCallStackWith handler action = runErrorNoCallStack action >>= \case+ Left e -> handler e+ Right a -> pure a++-- | 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@@ -172,49 +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" ++)- . ("If you see this, most likely there is a stray 'Async' action that\n" ++)- . ("outlived the scope of the 'Error' effect, was interacted with and threw\n" ++)- . ("an error to the parent thread. If that scenario sounds unlikely, please\n" ++)- . ("file a ticket at https://github.com/haskell-effectful/effectful/issues.\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,11 @@ , (:>)(..) , (:>>) , Subset(..)+ , KnownSubset+ , KnownPrefix(..)+ , IsUnknownSuffixOf+ , type (++)+ , KnownEffects(..) -- * Re-exports , Type@@ -38,8 +42,9 @@ -- /Note:/ GHC is kind enough to cache these values as they're top level CAFs, -- so the lookup is amortized @O(1)@ without any language level tricks. reifyIndex :: Int- reifyIndex = -- Don't show "minimal complete definition" in haddock.- error "unimplemented"+ reifyIndex =+ -- Don't show "minimal complete definition" in haddock.+ error "reifyIndex" instance TypeError ( Text "There is no handler for '" :<>: ShowType e :<>: Text "' in the context"@@ -61,17 +66,84 @@ type family xs :>> es :: Constraint where '[] :>> es = () (x : xs) :>> es = (x :> es, xs :>> es)+{-# DEPRECATED (:>>) "Usage of (:>>) slows down GHC too much. See https://github.com/haskell-effectful/effectful/issues/52#issuecomment-1269155485 for more information." #-} ---------------------------------------- --- | Provide evidence that @xs@ is a subset of @es@.-class 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.+ error "subsetFullyKnown"+ reifyIndices :: [Int]- reifyIndices = -- Don't show "minimal complete definition" in haddock.- error "unimplemented"+ reifyIndices =+ -- Don't show "minimal complete definition" in haddock.+ error "reifyIndices" -instance Subset '[] es where+-- If the subset is not fully known, make sure the subset and the base stack+-- have the same unknown suffix.+instance {-# INCOHERENT #-}+ ( KnownPrefix es+ , subEs `IsUnknownSuffixOf` es+ ) => Subset subEs es where+ subsetFullyKnown = False reifyIndices = [] -instance (e :> es, Subset xs es) => Subset (e : xs) es where- reifyIndices = reifyIndex @e @es : reifyIndices @xs @es+-- If the subset is fully known, we're done.+instance KnownPrefix es => Subset '[] es where+ subsetFullyKnown = True+ reifyIndices = []++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++instance KnownPrefix es => KnownPrefix (e : es) where+ prefixLength = 1 + prefixLength @es++instance {-# INCOHERENT #-} KnownPrefix es where+ prefixLength = 0++----++-- | 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)++----++-- | Append two type-level lists together.+type family (xs :: [Effect]) ++ (ys :: [Effect]) :: [Effect] where+ '[] ++ ys = ys+ (x : xs) ++ ys = x : xs ++ ys++infixr 5 ++++-- | Calculate length of a list of known effects.+class KnownEffects (es :: [Effect]) where+ knownEffectsLength :: Int+ knownEffectsLength =+ -- Don't show "minimal complete definition" in haddock.+ error "knownEffectsLength"++instance KnownEffects es => KnownEffects (e : es) where+ knownEffectsLength = 1 + knownEffectsLength @es++instance KnownEffects '[] where+ knownEffectsLength = 0
src/Effectful/Internal/Env.hs view
@@ -1,10 +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@@ -38,10 +56,12 @@ import Control.Monad import Control.Monad.Primitive-import Data.IORef+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@@ -73,27 +93,128 @@ -- data Env (es :: [Effect]) = Env { envOffset :: !Int- , envRefs :: !(PrimArray Int)- , envStorage :: !(IORef Storage)+ , 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'.@@ -124,34 +245,25 @@ -- Operations -- | Create an empty environment.-emptyEnv :: IO (Env '[])+emptyEnv :: HasCallStack => IO (Env '[]) emptyEnv = Env 0 <$> (unsafeFreezePrimArray =<< newPrimArray 0)- <*> (newIORef =<< emptyStorage)+ <*> (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- let vsSize = sizeofMutablePrimArray vs0- esSize = sizeofSmallMutableArray es0- fsSize = sizeofSmallMutableArray 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@@ -160,30 +272,30 @@ -- | Get the current size of the environment. sizeEnv :: Env es -> IO Int sizeEnv (Env offset refs _) = do- pure $ (sizeofPrimArray refs - offset) `div` 2+ pure $ sizeofPrimArray refs - offset -- | Access the tail of the environment. tailEnv :: Env (e : es) -> IO (Env es) tailEnv (Env offset refs storage) = do- pure $ Env (offset + 2) refs storage+ pure $ Env (offset + 1) refs storage ---------------------------------------- -- Extending and shrinking -- | Extend the environment with a new data type. consEnv- :: EffectRep (DispatchOf e) e+ :: HasCallStack+ => EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env (e : es)) consEnv e f (Env offset refs0 storage) = do let size = sizeofPrimArray refs0 - offset- mrefs <- newPrimArray (size + 2)- copyPrimArray mrefs 2 refs0 offset size- (ref, version) <- insertEffect storage e f+ mrefs <- newPrimArray (size + 1)+ copyPrimArray mrefs 1 refs0 offset size+ ref <- insertEffect storage e f writePrimArray mrefs 0 ref- writePrimArray mrefs 1 version refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage {-# NOINLINE consEnv #-}@@ -192,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 #-}@@ -204,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@@ -214,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 #-}@@ -226,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 #-} ----------------------------------------@@ -237,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 #-}@@ -250,18 +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- mrefs <- newPrimArray (2 * length xs)+ 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 (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)- writeRefs (i + 2) es- writeRefs 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 #-}@@ -271,129 +383,164 @@ -- | 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- e `seq` 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- e `seq` 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- e `seq` 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- let len0 = sizeofSmallMutableArray es0+ 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- e `seq` writeSmallArray es0 size (toAny e)- f `seq` writeSmallArray fs0 size (toAny f)- writeIORef storage $! Storage (size + 1) (version + 1) vs0 es0 fs0- pure (size, version)+ writePrimArray vs0 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- e `seq` writeSmallArray es size (toAny e)- f `seq` writeSmallArray fs size (toAny f)- writeIORef storage $! Storage (size + 1) (version + 1) vs es fs- pure (size, version)+ writePrimArray vs 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 :: 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 ()+writeSmallArray' arr i a = a `seq` writeSmallArray arr i a++#if !MIN_VERSION_primitive(0,9,0)+getSizeofSmallMutableArray :: SmallMutableArray RealWorld a -> IO Int+getSizeofSmallMutableArray arr = pure $! sizeofSmallMutableArray arr+#endif
+ 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,5 @@-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_HADDOCK not-home #-} -- | The 'Eff' monad. --@@ -15,6 +15,9 @@ , unsafeEff , unsafeEff_ + -- * NonDet+ , NonDet(..)+ -- * Fail , Fail(..) @@ -24,6 +27,7 @@ -- * Prim , Prim+ , PrimStateEff , runPrim -- * Lifting@@ -31,6 +35,7 @@ , raiseWith , subsume , inject+ , Subset -- * Unlifting , UnliftStrategy(..)@@ -38,10 +43,14 @@ , Limit(..) , unliftStrategy , withUnliftStrategy+ , withSeqEffToIO , withEffToIO+ , reallyUnsafeLiftMapIO+ , reallyUnsafeUnliftIO -- ** Low-level unlifts , seqUnliftIO+ , seqForkUnliftIO , concUnliftIO -- * Dispatch@@ -50,6 +59,7 @@ , EffectHandler , LocalEnv(..) , Handler(..)+ , HandlerImpl(..) , relinkHandler , runHandler , send@@ -65,17 +75,14 @@ , stateStaticRep , stateStaticRepM , localStaticRep-- -- *** Primitive operations- , consEnv- , getEnv- , putEnv- , stateEnv- , modifyEnv ) where -import Control.Applicative (liftA2)+import Control.Applicative+import Control.Concurrent (myThreadId)+import Control.Exception qualified as E+import Control.Monad import Control.Monad.Base+import Control.Monad.Catch qualified as C import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.IO.Unlift@@ -84,14 +91,14 @@ import Data.Kind (Constraint) import GHC.Exts (oneShot) import GHC.IO (IO(..))-import GHC.Stack (HasCallStack)+import GHC.Stack import System.IO.Unsafe (unsafeDupablePerformIO)-import qualified Control.Exception as E-import qualified Control.Monad.Catch as C+import Unsafe.Coerce (unsafeCoerce) import Effectful.Internal.Effect import Effectful.Internal.Env import Effectful.Internal.Unlift+import Effectful.Internal.Utils type role Eff nominal representational @@ -113,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@@ -133,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. --@@ -153,29 +160,49 @@ -- Unlifting IO -- | Get the current 'UnliftStrategy'.+--+-- /Note:/ this strategy is implicitly used by the 'MonadUnliftIO' and+-- 'MonadBaseControl' instance for 'Eff'. unliftStrategy :: IOE :> es => Eff es UnliftStrategy unliftStrategy = do IOE unlift <- getStaticRep pure unlift --- | Locally override the 'UnliftStrategy' with the given value.+-- | Locally override the current 'UnliftStrategy' with the given value. withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a withUnliftStrategy unlift = localStaticRep $ \_ -> IOE unlift --- | Create an unlifting function with the current 'UnliftStrategy'.+-- | Create an unlifting function with the 'SeqUnlift' strategy. For the general+-- version see 'withEffToIO'. ----- This function is equivalent to 'Effectful.withRunInIO', but has a--- 'HasCallStack' constraint for accurate stack traces in case an insufficiently--- powerful 'UnliftStrategy' is used and the unlifting function fails.-withEffToIO+-- /Note:/ usage of this function is preferrable to 'Effectful.withRunInIO'+-- because of explicit unlifting strategy and better error reporting.+--+-- @since 2.2.2.0+withSeqEffToIO :: (HasCallStack, IOE :> es) => ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a-withEffToIO f = unliftStrategy >>= \case- SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es f- ConcUnlift p b -> unsafeEff $ \es -> concUnliftIO es p b f+withSeqEffToIO k = unsafeEff $ \es -> seqUnliftIO es k+{-# INLINE withSeqEffToIO #-} +-- | Create an unlifting function with the given strategy.+--+-- /Note:/ usage of this function is preferrable to 'Effectful.withRunInIO'+-- because of explicit unlifting strategy and better error reporting.+withEffToIO+ :: (HasCallStack, IOE :> es)+ => UnliftStrategy+ -> ((forall r. Eff es r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting function in scope.+ -> 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 'SeqUnlift' strategy. seqUnliftIO :: HasCallStack@@ -184,8 +211,27 @@ -> ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> IO a-seqUnliftIO es k = seqUnlift k es unEff+seqUnliftIO es k = do+ tid0 <- myThreadId+ k $ \m -> do+ tid <- myThreadId+ if tid `eqThreadId` tid0+ then unEff m es+ else error+ $ "If you want to use the unlifting function to run Eff computations "+ ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)." +-- | Create an unlifting function with the 'SeqForkUnlift' strategy.+seqForkUnliftIO+ :: HasCallStack+ => Env es+ -- ^ The environment.+ -> ((forall r. Eff es r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting function in scope.+ -> IO a+seqForkUnliftIO es0 k = cloneEnv es0 >>= \es -> seqUnliftIO es k+{-# INLINE seqForkUnliftIO #-}+ -- | Create an unlifting function with the 'ConcUnlift' strategy. concUnliftIO :: HasCallStack@@ -196,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 @@ -213,51 +309,88 @@ 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 ----------------------------------------+-- NonDet++-- | 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+ (:<|>:) :: m a -> m a -> NonDet m a++type instance DispatchOf NonDet = Dynamic++-- | @since 2.2.0.0+instance NonDet :> es => Alternative (Eff es) where+ empty = send Empty+ a <|> b = send (a :<|>: b)++-- | @since 2.2.0.0+instance NonDet :> es => MonadPlus (Eff es)++---------------------------------------- -- 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 --- | Provide the ability to use the 'MonadFail' instance of 'Eff'.+-- | Provide the ability to use the 'MonadFail' instance for 'Eff'. data Fail :: Effect where Fail :: String -> Fail m a type instance DispatchOf Fail = Dynamic instance Fail :> es => MonadFail (Eff es) where- fail = send . Fail+ fail msg = send (Fail msg) ---------------------------------------- -- IO@@ -275,26 +408,38 @@ -- | 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 liftIO = unsafeEff_ --- | Use 'withEffToIO' if you want accurate stack traces on errors.+-- | Instance included for compatibility with existing code.+--+-- Usage of 'withEffToIO' is preferrable as it allows specifying the+-- 'UnliftStrategy' on a case-by-case basis and has better error reporting.+--+-- /Note:/ the unlifting strategy for 'withRunInIO' is taken from the 'IOE'+-- context (see 'unliftStrategy'). instance IOE :> es => MonadUnliftIO (Eff es) where- withRunInIO = withEffToIO+ withRunInIO k = unliftStrategy >>= (`withEffToIO` k) --- | Instance included for compatibility with existing code, usage of 'liftIO'--- is preferrable.+-- | Instance included for compatibility with existing code.+--+-- Usage of 'liftIO' is preferrable as it's a standard. instance IOE :> es => MonadBase IO (Eff es) where liftBase = unsafeEff_ --- | Instance included for compatibility with existing code, usage of--- 'Effectful.withRunInIO' is preferrable.+-- | Instance included for compatibility with existing code.+--+-- Usage of 'withEffToIO' is preferrable as it allows specifying the+-- 'UnliftStrategy' on a case-by-case basis and has better error reporting.+--+-- /Note:/ the unlifting strategy for 'liftBaseWith' is taken from the 'IOE'+-- context (see 'unliftStrategy'). instance IOE :> es => MonadBaseControl IO (Eff es) where type StM (Eff es) a = a- liftBaseWith = withEffToIO+ liftBaseWith k = unliftStrategy >>= (`withEffToIO` k) restoreM = pure ----------------------------------------@@ -306,19 +451,23 @@ type instance DispatchOf Prim = Static WithSideEffects data instance StaticRep Prim = Prim +-- | 'PrimState' token for 'Eff'. Used instead of 'RealWorld' to prevent the+-- 'Prim' effect from executing arbitrary 'IO' actions via 'ioToPrim'.+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- type PrimState (Eff es) = RealWorld- primitive = unsafeEff_ . IO+ type PrimState (Eff es) = PrimStateEff+ primitive = unsafeEff_ . IO . unsafeCoerce ---------------------------------------- -- 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@@ -331,30 +480,72 @@ -> ((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'. ----- /Note:/ this function should be needed rarely, usually when you have to cross--- API boundaries and monomorphic effect stacks are involved. Using monomorphic--- stacks is discouraged (see 'Eff'), but sometimes might be necessary due to--- external constraints.-inject :: Subset xs es => Eff xs a -> Eff es a+-- >>> data E1 :: Effect+-- >>> data E2 :: Effect+-- >>> data E3 :: Effect+--+-- It makes it possible to rearrange the effect stack however you like:+--+-- >>> :{+-- shuffle :: Eff (E3 : E1 : E2 : es) a -> Eff (E1 : E2 : E3 : es) a+-- shuffle = inject+-- :}+--+-- It can also turn a monomorphic effect stack into a polymorphic one:+--+-- >>> :{+-- toPoly :: (E1 :> es, E2 :> es, E3 :> es) => Eff [E1, E2, E3] a -> Eff es a+-- toPoly = inject+-- :}+--+-- Moreover, it allows for hiding specific effects from downstream:+--+-- >>> :{+-- onlyE1 :: Eff (E1 : es) a -> Eff (E1 : E2 : E3 : es) a+-- onlyE1 = inject+-- :}+--+-- >>> :{+-- onlyE2 :: Eff (E2 : es) a -> Eff (E1 : E2 : E3 : es) a+-- onlyE2 = inject+-- :}+--+-- >>> :{+-- onlyE3 :: Eff (E3 : es) a -> Eff (E1 : E2 : E3 : es) a+-- onlyE3 = inject+-- :}+--+-- However, it's not possible to inject a computation into an incompatible+-- effect stack:+--+-- >>> :{+-- coerceEs :: Eff es1 a -> Eff es2 a+-- coerceEs = inject+-- :}+-- ...+-- ...Couldn't match type ‘es1’ with ‘es2’+-- ...+inject :: Subset subEs es => Eff subEs a -> Eff es a inject m = unsafeEff $ \es -> unEff m =<< injectEnv es ----------------------------------------@@ -372,42 +563,57 @@ 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 es) -> !(EffectHandler e es) -> Handler e+ Handler :: !(Env handlerEs) -> !(HandlerImpl e handlerEs) -> Handler e type instance EffectRep Dynamic = Handler relinkHandler :: Relinker Handler e-relinkHandler = Relinker $ \relink (Handler handlerEs handle) -> do+relinkHandler = Relinker $ \relink (Handler handlerEs handler) -> do newHandlerEs <- relink handlerEs- pure $ Handler newHandlerEs handle+ 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- E.bracket (consEnv e relinkHandler es0)- unconsEnv- (\es -> unEff m es)+ inlineBracket+ (consEnv e relinkHandler es0)+ unconsEnv+ (\es -> unEff m es) -- | Send an operation of the given effect to its handler for execution. send :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => e (Eff es) a- -- ^ The effect.+ -- ^ The operation. -> Eff es a send op = unsafeEff $ \es -> do- Handler handlerEs handle <- getEnv es- unEff (handle (LocalEnv es) op) handlerEs+ 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 #-} ----------------------------------------@@ -426,75 +632,85 @@ -- | 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) runStaticRep e0 m = unsafeEff $ \es0 -> do- E.bracket (consEnv e0 dummyRelinker es0)- unconsEnv- (\es -> (,) <$> unEff m es <*> getEnv es)+ inlineBracket+ (consEnv e0 dummyRelinker es0)+ unconsEnv+ (\es -> (,) <$> unEff m es <*> getEnv es) -- | 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 evalStaticRep e m = unsafeEff $ \es0 -> do- E.bracket (consEnv e dummyRelinker es0)- unconsEnv- (\es -> unEff m es)+ inlineBracket+ (consEnv e dummyRelinker es0)+ unconsEnv+ (\es -> unEff m es) -- | 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) execStaticRep e0 m = unsafeEff $ \es0 -> do- E.bracket (consEnv e0 dummyRelinker es0)- unconsEnv- (\es -> unEff m es *> getEnv es)+ inlineBracket+ (consEnv e0 dummyRelinker es0)+ unconsEnv+ (\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- E.bracket (stateEnv es $ \s -> pure (s, f s))- (\s -> putEnv es s)- (\_ -> unEff m es)+ inlineBracket+ (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,14 +13,15 @@ , 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#) import GHC.Generics (Generic)@@ -27,7 +29,6 @@ import GHC.Stack (HasCallStack) import GHC.Weak (Weak(..)) import System.Mem.Weak (deRefWeak)-import qualified Data.IntMap.Strict as IM import Effectful.Internal.Env import Effectful.Internal.Utils@@ -36,21 +37,66 @@ -- Unlift strategies -- | The strategy to use when unlifting 'Effectful.Eff' computations via--- 'Effectful.withEffToIO', 'Effectful.withRunInIO' or the--- 'Effectful.Dispatch.Dynamic.localUnlift' family.------ /Note:/ unlifting functions should not be used outside of continuations that--- brought them into scope.+-- 'Effectful.withEffToIO' or the 'Effectful.Dispatch.Dynamic.localUnlift'+-- family. data UnliftStrategy = SeqUnlift- -- ^ The fastest strategy and a default setting for t'Effectful.IOE'. An- -- attempt to call the unlifting function in threads distinct from its creator- -- will result in a runtime error.+ -- ^ 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- -- ^ A strategy that 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)+ -- ^ 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 stock (Eq, Generic, Ord, Show) -- | Persistence setting for the 'ConcUnlift' strategy. --@@ -70,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@@ -89,57 +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 for various strategies and limits.-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- -- | 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@@ -147,34 +157,33 @@ -- use. This can't be done from inside the callback as the environment might -- have already changed by then. esTemplate <- cloneEnv es0- mvUses <- newMVar uses+ mvUses <- newMVar' uses k $ \m -> do es <- myThreadId >>= \case tid | tid0 `eqThreadId` tid -> pure es0- _ -> modifyMVar mvUses $ \case+ _ -> modifyMVar' mvUses $ \case 0 -> error $ "Number of permitted calls (" ++ show uses ++ ") to the unlifting " ++ "function in other threads was exceeded. Please increase the limit " ++ "or use the unlimited variant." 1 -> pure (0, esTemplate) n -> do- let newUses = n - 1 es <- cloneEnv esTemplate- newUses `seq` pure (newUses, es)- unEff m es+ pure (n - 1, 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@@ -182,11 +191,11 @@ -- use. This can't be done from inside the callback as the environment might -- have already changed by then. esTemplate <- cloneEnv es0- mvEntries <- newMVar $ ThreadEntries threads IM.empty+ mvEntries <- newMVar' $ ThreadEntries threads IM.empty k $ \m -> do es <- myThreadId >>= \case tid | tid0 `eqThreadId` tid -> pure es0- tid -> modifyMVar mvEntries $ \te -> do+ tid -> modifyMVar' mvEntries $ \te -> do let wkTid = weakThreadId tid (mes, i) <- case wkTid `IM.lookup` teEntries te of Just (ThreadEntry i td) -> (, i) <$> lookupEnv tid td@@ -204,7 +213,7 @@ { teCapacity = teCapacity te - 1 , teEntries = addThreadData wkTid i wkTidEs $ teEntries te }- newEntries `seq` pure (newEntries, esTemplate)+ pure (newEntries, esTemplate) _ -> do es <- cloneEnv esTemplate wkTidEs <- mkWeakThreadIdEnv tid es wkTid i mvEntries cleanUp@@ -212,14 +221,15 @@ { teCapacity = teCapacity te - 1 , teEntries = addThreadData wkTid i wkTidEs $ teEntries te }- newEntries `seq` pure (newEntries, es)- unEff m es+ pure (newEntries, es)+ coerce m es+{-# NOINLINE persistentConcUnlift #-} ---------------------------------------- -- Data types newtype EntryId = EntryId Int- deriving Eq+ deriving newtype Eq newEntryId :: EntryId newEntryId = EntryId 0@@ -249,7 +259,7 @@ -> Env es -> Int -> EntryId- -> MVar (ThreadEntries es)+ -> MVar' (ThreadEntries es) -> Bool -> IO (Weak (ThreadId, Env es)) mkWeakThreadIdEnv t@(ThreadId t#) es wkTid i v = \case@@ -295,17 +305,16 @@ ---------------------------------------- -deleteThreadData :: Int -> EntryId -> MVar (ThreadEntries es) -> IO ()-deleteThreadData wkTid i v = modifyMVar_ v $ \te -> do- let newEntries = ThreadEntries- { teCapacity = case teCapacity te of- -- If the template copy of the environment hasn't been consumed- -- yet, the capacity can be restored.- 0 -> 0- n -> n + 1- , teEntries = IM.update (cleanThreadEntry i) wkTid $ teEntries te- }- newEntries `seq` pure newEntries+deleteThreadData :: Int -> EntryId -> MVar' (ThreadEntries es) -> IO ()+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+ -- yet, the capacity can be restored.+ 0 -> 0+ n -> n + 1+ , teEntries = IM.update (cleanThreadEntry i) wkTid $ teEntries te+ } cleanThreadEntry :: EntryId -> ThreadEntry es -> Maybe (ThreadEntry es) cleanThreadEntry i0 (ThreadEntry i td0) = case cleanThreadData i0 td0 of
+ src/Effectful/Internal/Utils.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# OPTIONS_HADDOCK not-home #-}+module Effectful.Internal.Utils+ ( inlineBracket++ -- * Utils for 'ThreadId'+ , weakThreadId+ , eqThreadId++ -- * Utils for 'Any'+ , Any+ , toAny+ , fromAny++ -- * Unique+ , Unique+ , newUnique++ -- * CallStack+ , thawCallStack++ -- * Array capacity+ , growCapacity+ ) where++import Control.Exception+import Data.Primitive.ByteArray+import GHC.Conc.Sync (ThreadId(..))+import GHC.Exts (Any, RealWorld)+import GHC.Stack.Types (CallStack(..))+import Unsafe.Coerce (unsafeCoerce)++#if MIN_VERSION_base(4,19,0)+import GHC.Conc.Sync (fromThreadId)+#else+import GHC.Exts (Addr#, ThreadId#, unsafeCoerce#)+#if __GLASGOW_HASKELL__ >= 904+import Data.Word+#else+import Foreign.C.Types+#endif+#endif++-- | Version of bracket with an INLINE pragma to work around+-- https://gitlab.haskell.org/ghc/ghc/-/issues/22824.+inlineBracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c+inlineBracket before after action = mask $ \unmask -> do+ a <- before+ r <- unmask (action a) `onException` after a+ _ <- after a+ pure r+{-# INLINE inlineBracket #-}++----------------------------------------++-- | Get an id of a thread that doesn't prevent its garbage collection.+weakThreadId :: ThreadId -> Int+#if MIN_VERSION_base(4,19,0)+weakThreadId = fromIntegral . fromThreadId+#else+weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId (threadIdToAddr# t#)++foreign import ccall unsafe "rts_getThreadId"+#if __GLASGOW_HASKELL__ >= 904+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6163+ rts_getThreadId :: Addr# -> Word64+#elif __GLASGOW_HASKELL__ >= 900+ -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1254+ rts_getThreadId :: Addr# -> CLong+#else+ rts_getThreadId :: Addr# -> CInt+#endif++-- Note: FFI imports take Addr# instead of ThreadId# because of+-- https://gitlab.haskell.org/ghc/ghc/-/issues/8281, which would prevent loading+-- effectful-core into GHCi.+--+-- Previous workaround was to use an internal library with just this module, but+-- this is not viable because of bugs in stack (sigh).+--+-- The coercion is fine because GHC represents ThreadId# as a pointer.+threadIdToAddr# :: ThreadId# -> Addr#+threadIdToAddr# = unsafeCoerce#+#endif++----------------------------------------++#if __GLASGOW_HASKELL__ < 900++-- | 'Eq' instance for 'ThreadId' is broken in GHC < 9, see+-- https://gitlab.haskell.org/ghc/ghc/-/issues/16761 for more info.+eqThreadId :: ThreadId -> ThreadId -> Bool+eqThreadId (ThreadId t1#) (ThreadId t2#) =+ eq_thread (threadIdToAddr# t1#) (threadIdToAddr# t2#) == 1++foreign import ccall unsafe "effectful_eq_thread"+ eq_thread :: Addr# -> Addr# -> CLong++#else++eqThreadId :: ThreadId -> ThreadId -> Bool+eqThreadId = (==)++#endif++----------------------------------------++toAny :: a -> Any+toAny = unsafeCoerce++fromAny :: Any -> a+fromAny = unsafeCoerce++----------------------------------------++-- | A unique with no possibility for CAS contention.+--+-- Credits for this go to Edward Kmett.+newtype Unique = Unique (MutableByteArray RealWorld)++instance Eq Unique where+ Unique a == Unique b = sameMutableByteArray a b++newUnique :: IO Unique+newUnique = Unique <$> newByteArray 0++----------------------------------------++thawCallStack :: CallStack -> CallStack+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
@@ -0,0 +1,79 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | 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+ ( -- * Effect+ Labeled(..)++ -- ** Handlers+ , runLabeled++ -- ** Operations+ , labeled+ ) where++import Unsafe.Coerce (unsafeCoerce)++import Effectful+import Effectful.Dispatch.Static++-- | Assign a label to an effect.+--+-- The constructor is for sending labeled operations of a dynamically dispatched+-- effect to the handler:+--+-- >>> import Effectful.Dispatch.Dynamic+--+-- >>> :{+-- data X :: Effect where+-- X :: X m Int+-- type instance DispatchOf X = Dynamic+-- :}+--+-- >>> :{+-- runPureEff . runLabeled @"x" (interpret_ $ \X -> pure 333) $ do+-- send $ Labeled @"x" X+-- :}+-- 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) = DispatchOf e++data instance StaticRep (Labeled label e)++-- | Run a 'Labeled' effect with a given effect handler.+runLabeled+ :: forall label e es a 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 without a label.+--+-- Useful for running code written with the non-labeled effect in mind.+labeled+ :: forall label e es a+ . (HasCallStack, Labeled label e :> es)+ => Eff (e : es) a+ -- ^ The action using the effect.+ -> Eff es a+labeled m = subsume @(Labeled label e) (toLabeled m)++----------------------------------------+-- Helpers++fromLabeled :: Eff (Labeled label e : es) a -> Eff (e : es) a+fromLabeled = unsafeCoerce++toLabeled :: Eff (e : es) a -> Eff (Labeled label e : es) a+toLabeled = unsafeCoerce
+ 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
@@ -0,0 +1,144 @@+-- | Provider of the t'Control.Applicative.Alternative' and+-- t'Control.Monad.MonadPlus' instance for 'Eff'.+module Effectful.NonDet+ ( -- * Effect+ NonDet(..)+ , OnEmptyPolicy(..)++ -- ** Handlers+ , runNonDet++ -- * Operations+ , emptyEff+ , plusEff+ , sumEff++ -- * Re-exports+ , Alternative(..)+ , HasCallStack+ , CallStack+ , getCallStack+ , prettyCallStack+ ) where++import Control.Applicative+import Data.IORef.Strict+import GHC.Generics+import GHC.Stack++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Error.Static+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 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'.+ --+ -- /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'.+--+-- /Note:/ ':<|>:' executes the second computation if (and only if) the first+-- computation calls 'Empty'.+--+-- @since 2.2.0.0+runNonDet+ :: HasCallStack+ => OnEmptyPolicy+ -> Eff (NonDet : es) a+ -> Eff es (Either CallStack a)+runNonDet = \case+ OnEmptyKeep -> runNonDetKeep+ OnEmptyRollback -> runNonDetRollback++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` \_ ErrorEmpty -> pure Nothing+ case mr of+ Just r -> pure r+ Nothing -> unlift m2++runNonDetRollback+ :: HasCallStack+ => Eff (NonDet : es) a+ -> Eff es (Either CallStack a)+runNonDetRollback = reinterpret setup $ \env -> \case+ Empty -> throwError ErrorEmpty+ m1 :<|>: m2 -> do+ backupData <- unsafeEff backupStorageData+ localSeqUnlift env $ \unlift -> do+ 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++----------------------------------------++-- | Specialized version of 'empty' with the 'HasCallStack' constraint for+-- tracking purposes.+--+-- @since 2.2.0.0+emptyEff :: (HasCallStack, NonDet :> es) => Eff es a+emptyEff = withFrozenCallStack send Empty++-- | Specialized version of '<|>' with the `HasCallStack` constraint for+-- tracking purposes.+--+-- @since 2.5.0.0+plusEff :: (HasCallStack, NonDet :> es) => Eff es a -> Eff es a -> Eff es a+plusEff m1 m2 = send (m1 :<|>: m2)+infixl 3 `plusEff` -- same as <|>++-- | Specialized version of 'asum' with the 'HasCallStack' constraint for+-- tracking purposes.+--+-- @since 2.2.0.0+sumEff :: (HasCallStack, Foldable t, NonDet :> es) => t (Eff es a) -> Eff es a+sumEff = foldr 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++backupStorageData :: HasCallStack => Env es -> IO I.StorageData+backupStorageData env = I.copyStorageData . I.stData =<< readIORef' (I.envStorage env)
src/Effectful/Prim.hs view
@@ -2,6 +2,7 @@ module Effectful.Prim ( -- * Effect Prim+ , PrimStateEff -- ** Handlers , runPrim
+ src/Effectful/Provider.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE ImplicitParams #-}+-- | Turn an effect handler into an effectful operation.+--+-- @since 2.3.0.0+module Effectful.Provider+ ( -- * Example+ -- $example++ -- * Effect+ Provider+ , Provider_++ -- ** Handlers+ , runProvider+ , runProvider_++ -- ** Operations+ , provide+ , provide_+ , provideWith+ , provideWith_+ ) where++import Control.Monad+import Data.Coerce+import Data.Functor.Identity+import Data.Kind (Type)+import Data.Primitive.PrimArray+import GHC.Stack++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Env (Env(..))+import Effectful.Internal.Utils++-- $example+--+-- >>> import Control.Monad.IO.Class+-- >>> import Data.Map.Strict qualified as M+-- >>> import Effectful.Dispatch.Dynamic+-- >>> import Effectful.State.Static.Local+--+-- Given an effect:+--+-- >>> :{+-- data Write :: Effect where+-- Write :: String -> Write m ()+-- type instance DispatchOf Write = Dynamic+-- :}+--+-- >>> :{+-- write :: Write :> es => String -> Eff es ()+-- write = send . Write+-- :}+--+-- its handler can be turned into an effectful operation with the 'Provider'+-- effect:+--+-- >>> :{+-- action :: Provider_ Write FilePath :> es => Eff es ()+-- action = do+-- provideWith_ @Write "in.txt" $ do+-- write "hi"+-- write "there"+-- provideWith_ @Write "out.txt" $ do+-- write "good"+-- write "bye"+-- :}+--+-- Then, given multiple interpreters:+--+-- >>> :{+-- runWriteIO+-- :: IOE :> es+-- => FilePath+-- -> Eff (Write : es) a+-- -> Eff es a+-- runWriteIO fp = interpret_ $ \case+-- Write msg -> liftIO . putStrLn $ fp ++ ": " ++ msg+-- :}+--+-- >>> :{+-- runWritePure+-- :: State (M.Map FilePath [String]) :> es+-- => FilePath+-- -> Eff (Write : es) a+-- -> Eff es a+-- runWritePure fp = interpret_ $ \case+-- Write msg -> modify $ M.insertWith (++) fp [msg]+-- :}+--+-- @action@ can be supplied with either of them for the appropriate behavior:+--+-- >>> :{+-- runEff+-- . runProvider_ runWriteIO+-- $ action+-- :}+-- in.txt: hi+-- in.txt: there+-- out.txt: good+-- out.txt: bye+--+-- >>> :{+-- runPureEff+-- . fmap (fmap reverse)+-- . execState @(M.Map FilePath [String]) M.empty+-- . runProvider_ runWritePure+-- $ action+-- :}+-- fromList [("in.txt",["hi","there"]),("out.txt",["good","bye"])]++-- | Provide a way to run a handler of @e@ with a given @input@.+--+-- /Note:/ @f@ can be used to alter the return type of the effect handler. If+-- that's unnecessary, use 'Provider_'.+data Provider (e :: Effect) (input :: Type) (f :: Type -> Type) :: Effect++-- | A restricted variant of 'Provider' with unchanged return type of the effect+-- handler.+type Provider_ e input = Provider e input Identity++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)+ -> !(ProviderImpl input f e handlerEs)+ -> StaticRep (Provider e input f)++-- | Run the 'Provider' effect with a given effect handler.+runProvider+ :: 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 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_+ :: 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_ provider action = runProviderImpl action $+ ProviderImpl $ let ?callStack = thawCallStack ?callStack+ in \input -> coerce . provider input++-- | Run the effect handler.+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_ :: (HasCallStack, Provider_ e () :> es) => Eff (e : es) a -> Eff es a+provide_ = provideWith_ ()++-- | Run the effect handler with a given input.+provideWith+ :: (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 (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_+ :: (HasCallStack, Provider_ e input :> es)+ => input+ -- ^ The input to the effect handler.+ -> Eff (e : es) a+ -> Eff es a+provideWith_ input = adapt . provideWith input+ where+ adapt :: Eff es (Identity a) -> Eff es a+ adapt = coerce++----------------------------------------+-- 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+ :: 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 + 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
@@ -0,0 +1,171 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ImplicitParams #-}+-- | Turn a handler of multiple effects into an effectful operation.+--+-- Generalizes "Effectful.Provider".+--+-- @since 2.3.1.0+module Effectful.Provider.List+ ( -- * Effect+ ProviderList+ , ProviderList_++ -- ** Handlers+ , runProviderList+ , runProviderList_++ -- ** Operations+ , provideList+ , provideList_+ , provideListWith+ , provideListWith_++ -- * Misc+ , type (++)+ , KnownEffects+ ) where++import Control.Monad+import Data.Coerce+import Data.Functor.Identity+import Data.Primitive.PrimArray+import GHC.Stack++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Effect+import Effectful.Internal.Env (Env(..))+import Effectful.Internal.Utils++-- | 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 (providedEs :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect++-- | A restricted variant of 'ProviderList' with unchanged return type of the+-- handler.+type ProviderList_ providedEs input = ProviderList providedEs input Identity++type instance DispatchOf (ProviderList providedEs input f) = Static NoSideEffects++-- | 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 providedEs+ => !(Env handlerEs)+ -> !(ProviderListImpl input f providedEs handlerEs)+ -> StaticRep (ProviderList providedEs input f)++-- | Run the 'ProviderList' effect with a given handler.+runProviderList+ :: (HasCallStack, KnownEffects providedEs)+ => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r))+ -- ^ The handler.+ -> Eff (ProviderList providedEs input f : es) a+ -> Eff es a+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_+ :: (HasCallStack, KnownEffects providedEs)+ => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r)+ -- ^ The handler.+ -> Eff (ProviderList_ providedEs input : es) a+ -> Eff es a+runProviderList_ providerList action = runProviderListImpl action $+ ProviderListImpl $ let ?callStack = thawCallStack ?callStack+ in \input -> coerce . providerList input++-- | Run the handler.+provideList+ :: forall providedEs f es a+ . (HasCallStack, ProviderList providedEs () f :> es)+ => Eff (providedEs ++ es) a+ -> Eff es (f a)+provideList = provideListWith @providedEs ()++-- | Run the handler with unchanged return type.+provideList_+ :: forall providedEs es a+ . (HasCallStack, ProviderList_ providedEs () :> es)+ => Eff (providedEs ++ es) a+ -> Eff es a+provideList_ = provideListWith_ @providedEs ()++-- | Run the handler with a given input.+provideListWith+ :: forall providedEs input f es a+ . (HasCallStack, ProviderList providedEs input f :> es)+ => input+ -- ^ The input to the handler.+ -> Eff (providedEs ++ es) a+ -> Eff es (f a)+provideListWith input action = unsafeEff $ \es -> do+ 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 providedEs input es a+ . (HasCallStack, ProviderList_ providedEs input :> es)+ => input+ -- ^ The input to the handler.+ -> Eff (providedEs ++ es) a+ -> Eff es a+provideListWith_ input = adapt . provideListWith @providedEs input+ where+ adapt :: Eff es (Identity a) -> Eff es a+ adapt = coerce++----------------------------------------+-- 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 providedEs handlerEs es+ . (HasCallStack, KnownEffects providedEs)+ => Env (providedEs ++ handlerEs)+ -> Env 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 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 qualified Effectful.Reader.Static 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 qualified Effectful.State.Static.Local as L-import qualified Effectful.State.Static.Shared 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+import Effectful.Internal.MTL (State(..))+import Effectful.State.Static.Local qualified as L+import Effectful.State.Static.Shared 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 :: 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,113 +47,109 @@ , 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 -- | 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)+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+ v <- unsafeEff_ $ newMVar' s a <- evalStaticRep (State v) m- (a, ) <$> unsafeEff_ (readMVar v)+ (a, ) <$> unsafeEff_ (readMVar' v) -- | 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+ 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+ v <- unsafeEff_ $ newMVar' s _ <- evalStaticRep (State v) m- unsafeEff_ $ readMVar v+ 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 a <- evalStaticRep (State v) m- (a, ) <$> unsafeEff_ (readMVar v)+ (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- 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 _ <- evalStaticRep (State v) m- unsafeEff_ $ readMVar v+ 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+ readMVar' v -- | 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 $ \_ -> s `seq` 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 s `seq` pure (s, a)+ modifyMVar' v $ \s0 -> let (a, s) = f s0 in pure (s, a) -- | Apply the function to the current state. -- -- @'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+ modifyMVar' v $ \s0 -> do (a, s) <- unEff (f s0) es- s `seq` pure (s, a)+ pure (s, a) -- | Apply the monadic function to the current state. -- -- @'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 qualified Effectful.Writer.Static.Local as L-import qualified Effectful.Writer.Static.Shared 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+import Effectful.Internal.MTL (Writer(..))+import Effectful.Writer.Static.Local qualified as L+import Effectful.Writer.Static.Shared qualified as S ---------------------------------------- -- 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,40 +27,41 @@ , listens ) where -import Control.Concurrent.MVar+import Control.Concurrent.MVar.Strict import Control.Exception (onException, uninterruptibleMask)+import Data.Kind import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive -- | 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)+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+ v <- unsafeEff_ $ newMVar' mempty a <- evalStaticRep (Writer v) m- (a, ) <$> unsafeEff_ (readMVar v)+ (a, ) <$> unsafeEff_ (readMVar' v) -- | 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+ v <- unsafeEff_ $ newMVar' mempty _ <- evalStaticRep (Writer v) m- unsafeEff_ $ readMVar v+ 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 w `seq` 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,15 +80,15 @@ -- 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 -- lost. uninterruptibleMask $ \unmask -> do- v1 <- newMVar mempty+ 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@@ -95,8 +96,8 @@ -- exception was received while listening, merge results recorded so far. merge es v0 v1 = do putEnv es $ Writer v0- w1 <- readMVar v1- modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w+ w1 <- readMVar' v1+ 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
− utils/Effectful/Internal/Utils.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnliftedFFITypes #-}-{-# OPTIONS_HADDOCK not-home #-}-module Effectful.Internal.Utils- ( weakThreadId- , eqThreadId-- -- * Utils for 'Any'- , Any- , toAny- , fromAny- ) where--import Foreign.C.Types-import GHC.Conc.Sync (ThreadId(..))-import GHC.Exts (Any, ThreadId#)-import Unsafe.Coerce (unsafeCoerce)---- | Get an id of a thread that doesn't prevent its garbage collection.-weakThreadId :: ThreadId -> Int-weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId t#--foreign import ccall unsafe "rts_getThreadId"-#if __GLASGOW_HASKELL__ >= 904- -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6163- rts_getThreadId :: ThreadId# -> CULLong-#elif __GLASGOW_HASKELL__ >= 900- -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1254- rts_getThreadId :: ThreadId# -> CLong-#else- rts_getThreadId :: ThreadId# -> CInt-#endif---- | 'Eq' instance for 'ThreadId' is broken in GHC < 9, see--- https://gitlab.haskell.org/ghc/ghc/-/issues/16761 for more info.-eqThreadId :: ThreadId -> ThreadId -> Bool-eqThreadId (ThreadId t1#) (ThreadId t2#) = eq_thread t1# t2# == 1--foreign import ccall unsafe "effectful_eq_thread"- eq_thread :: ThreadId# -> ThreadId# -> CLong--------------------------------------------toAny :: a -> Any-toAny = unsafeCoerce--fromAny :: Any -> a-fromAny = unsafeCoerce
− utils/utils.c
@@ -1,5 +0,0 @@-// Correct implementation of ThreadId# equality for GHC < 9.-long effectful_eq_thread(void *tso1, void *tso2)-{- return tso1 == tso2;-}