diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,202 @@ +# effectful-core-2.7.0.0 (2026-08-24) +* Add the `Input` effect (`Effectful.Input.Dynamic`, `Effectful.Input.Static`, + `Effectful.Input.Static.Action` and `Effectful.Labeled.Input`) for access to + values. +* Add the `Output` effect (`Effectful.Output.Dynamic`, + `Effectful.Output.Static.Action`, `Effectful.Output.Static.Local.Array`, + `Effectful.Output.Static.Local.List`, `Effectful.Output.Static.Shared.Array`, + `Effectful.Output.Static.Shared.List` and `Effectful.Labeled.Output`) for + accumulation of values. +* Add the `ReturnWith` effect (`Effectful.ReturnWith.Dynamic`, + `Effectful.ReturnWith.Static` and `Effectful.Labeled.ReturnWith`) for early + return from a computation. +* Make the `Provider` and `ProviderList` effects dynamically dispatched and + export their operations. +* Add `Effectful.Labeled.Provider` and `Effectful.Labeled.Provider.List` with + labeled versions of the `Provider` and `ProviderList` effects. +* Re-export `Labeled(..)` from all `Effectful.Labeled.*` modules. +* Drop support for GHC < 9.6. +* Add definitions of `rethrowM` to `MonadThrow` and `catchNoPropagate` to + `MonadCatch` instances for `Eff` when appropriate (`exceptions` >= 0.10.11). +* If the cleanup action of `bracket`, `bracket_`, `bracketOnError`, `finally` or + `onException` from `Effectful.Exception` throws, the original exception is no + longer lost - it is preserved in a `WhileHandling` annotation of the new one + (`base` >= 4.21). +* Rename `Effectful.Internal.MTL` module to `Effectful.Internal.Effect.Dynamic`. +* Deprecate `withLiftMap` as its misuse in a multithreaded environment results + in undefined behavior that cannot be detected at runtime. Use + `localLiftUnlift` with an appropriate `UnliftStrategy` instead. +* Deprecate `stateM` and `modifyM` from `Effectful.State.Static.Local`, + `Effectful.State.Static.Shared`, `Effectful.State.Dynamic` and + `Effectful.Labeled.State` as well as the `StateM` operation of the dynamic + `State` effect. The shared variant pins the state to a lock-based + implementation, yet deadlocks when operations of the same `State` effect are + used within the callback, while the local variant silently discards state + modifications made this way. If you need atomic effectful updates of shared + state, use an explicit `MVar`. +* Deprecate `runStateMVar`, `evalStateMVar` and `execStateMVar` from + `Effectful.State.Static.Shared` so that the internal representation of the + shared `State` effect is not tied to an `MVar`. If you need access to the + state from outside of the effect, manage an explicit `MVar` yourself. +* Tighten pre-requisites for `unconsEnv` and `unreplaceEnv`. +* Add `localLendBorrow` to `Effectful.Dispatch.Dynamic`. +* Add `rethrowErrorWith`, `rethrowError` and `rethrowError_` (along with the + corresponding `RethrowErrorWith` operation of the dynamic `Error` effect) for + throwing errors with a given `CallStack`. +* Document why the `MonadThrow`, `MonadCatch` and `MonadMask` instances for + `Eff` are available without any effect requirements. +* Require `primitive` >= 0.9.0.0. +* Require `strict-mutable-base` >= 2.0.0.0. +* Remove `SharedSuffix` constraints from functions in + `Effectful.Dispatch.Dynamic` and deprecate the class, as runtime sanity + checks make it unnecessary. +* **Breaking changes**: + - Remove the `handlerEs` type parameter of `LocalEnv` as it was only needed + to support `SharedSuffix` constraints. + - Remove the `KnownEffects` class as it's no longer used; handlers of the + `ProviderList` effect now require the `KnownSubset` constraint instead. +* **Bugfixes**: + - `restoreStorageData` no longer shrinks the capacity of the storage, which + could result in out of bounds reads when out of date references to the + environment were accessed after the rollback, e.g. by the unlifting function + that escaped its scope. + - Unlifting functions created by `localLiftUnlift` with `SeqForkUnlift` or + `ConcUnlift` `Persistent` strategy now correctly share the effect storage + and the thread limit now applies jointly to both functions. + - `OnEmptyRollback` strategy of the `NonDet` effect now correctly rolls back + local state of statically dispatched effects stored in mutable variables. + - Thread registration in unlifting functions created with the `ConcUnlift` + `Persistent` strategy interrupted by an asynchronous exception no longer + leaks a finalizer that corrupts the thread limit accounting when the thread + dies. + - Running the computation given to the setup function of `reinterpret` or + `impose` in a cloned environment (e.g. by unlifting it with the + `SeqForkUnlift` strategy and running it outside of the scope of the setup + function) now results in an immediate, accurate error instead of + corruption of the environment of the call site. + +# 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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,12 @@ # effectful -[![Build Status](https://github.com/haskell-effectful/effectful/workflows/Haskell-CI/badge.svg?branch=master)](https://github.com/haskell-effectful/effectful/actions?query=branch%3Amaster) +[![CI](https://github.com/haskell-effectful/effectful/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/haskell-effectful/effectful/actions/workflows/haskell-ci.yml) [![Hackage](https://img.shields.io/hackage/v/effectful.svg)](https://hackage.haskell.org/package/effectful) -[![Dependencies](https://img.shields.io/hackage-deps/v/effectful.svg)](https://packdeps.haskellers.com/feed?needle=andrzej@rybczak.net) [![Stackage LTS](https://www.stackage.org/package/effectful/badge/lts)](https://www.stackage.org/lts/package/effectful) [![Stackage Nightly](https://www.stackage.org/package/effectful/badge/nightly)](https://www.stackage.org/nightly/package/effectful) - + 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. diff --git a/effectful-core.cabal b/effectful-core.cabal --- a/effectful-core.cabal +++ b/effectful-core.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.4 +cabal-version: 3.8 build-type: Simple name: effectful-core -version: 2.1.0.0 +version: 2.7.0.0 license: BSD-3-Clause license-file: LICENSE category: Control @@ -12,7 +12,7 @@ description: An easy to use, performant extensible effects library with seamless integration with the existing Haskell ecosystem. - . + This library provides core definitions with a minimal dependency footprint. See the @@ package for the "batteries-included" variant. @@ -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 == { 9.6.7, 9.8.4, 9.10.3, 9.12.4, 9.14.1 } bug-reports: https://github.com/haskell-effectful/effectful/issues source-repository head @@ -29,53 +29,38 @@ location: https://github.com/haskell-effectful/effectful.git common language - ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors + ghc-options: -Wall + -Wcompat + -Werror=missing-deriving-strategies + -Werror=prepositive-qualified-module - default-language: Haskell2010 + default-language: GHC2021 - default-extensions: BangPatterns - ConstraintKinds - DataKinds - DeriveFunctor - DeriveGeneric - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving + default-extensions: DataKinds + DeepSubsumption + DerivingStrategies + DuplicateRecordFields LambdaCase - MultiParamTypeClasses + NoFieldSelectors NoStarIsType - RankNTypes + OverloadedRecordDot RoleAnnotations - ScopedTypeVariables - StandaloneDeriving - TupleSections - 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.18 && < 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 + , primitive >= 0.9.0.0 + , strict-mutable-base >= 2.0.0.0 && < 3 , transformers-base >= 0.4.6 , unliftio-core >= 0.2.0.1 @@ -88,19 +73,45 @@ Effectful.Dispatch.Static.Unsafe Effectful.Error.Dynamic Effectful.Error.Static + Effectful.Exception Effectful.Fail + Effectful.Input.Dynamic + Effectful.Input.Static + Effectful.Input.Static.Action Effectful.Internal.Effect + Effectful.Internal.Effect.Dynamic Effectful.Internal.Env Effectful.Internal.Monad Effectful.Internal.Unlift + Effectful.Internal.Utils + Effectful.Internal.Utils.Word64Map + Effectful.Labeled + Effectful.Labeled.Error + Effectful.Labeled.Input + Effectful.Labeled.Output + Effectful.Labeled.Provider + Effectful.Labeled.Provider.List + Effectful.Labeled.Reader + Effectful.Labeled.ReturnWith + Effectful.Labeled.State + Effectful.Labeled.Writer + Effectful.NonDet + Effectful.Output.Dynamic + Effectful.Output.Static.Action + Effectful.Output.Static.Local.Array + Effectful.Output.Static.Local.List + Effectful.Output.Static.Shared.Array + Effectful.Output.Static.Shared.List Effectful.Prim + Effectful.Provider + Effectful.Provider.List Effectful.Reader.Dynamic Effectful.Reader.Static + Effectful.ReturnWith.Dynamic + Effectful.ReturnWith.Static Effectful.State.Dynamic Effectful.State.Static.Local Effectful.State.Static.Shared Effectful.Writer.Dynamic Effectful.Writer.Static.Local Effectful.Writer.Static.Shared - - reexported-modules: Effectful.Internal.Utils diff --git a/src/Effectful.hs b/src/Effectful.hs --- a/src/Effectful.hs +++ b/src/Effectful.hs @@ -44,6 +44,7 @@ , Limit(..) , unliftStrategy , withUnliftStrategy + , withSeqEffToIO , withEffToIO -- ** Lifting @@ -62,6 +63,7 @@ import Control.Monad.IO.Unlift import Effectful.Internal.Effect +import Effectful.Internal.Effect.Dynamic () import Effectful.Internal.Env import Effectful.Internal.Monad @@ -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 diff --git a/src/Effectful/Dispatch/Dynamic.hs b/src/Effectful/Dispatch/Dynamic.hs --- a/src/Effectful/Dispatch/Dynamic.hs +++ b/src/Effectful/Dispatch/Dynamic.hs @@ -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,39 @@ , localLiftUnlift , localLiftUnliftIO - -- *** Utils + -- *** Misc + , localSeqLend + , localLend + , localSeqBorrow + , localBorrow + , localLendBorrow , 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 +155,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 +170,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 +179,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 +226,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 +265,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 +349,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 +358,7 @@ -- -- >>> :{ -- runDummyRNG :: Eff (RNG : es) a -> Eff es a --- runDummyRNG = interpret $ \_ -> \case +-- runDummyRNG = interpret_ $ \case -- RandomInt -> pure 55 -- :} -- @@ -342,34 +369,162 @@ -- "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) + => LocalEnv localEs + -> e (Eff localEs) a + -- ^ The operation. + -> Eff es a +passthrough localEs op = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + Handler handlerEs (HandlerImpl handler) <- getEnv es + when (les.storage /= handlerEs.storage) $ 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 localEs 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,138 +532,331 @@ -- -- >>> :{ -- 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 :... +-- handler, called at src/Effectful/Dispatch/Dynamic.hs:... +-- passthrough, called at :... +-- handler, called at src/Effectful/Dispatch/Dynamic.hs:... +-- send, called at :... +-- ... 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 -- general version see 'localUnlift'. localSeqUnlift - :: (HasCallStack, SharedSuffix es handlerEs) - => LocalEnv localEs handlerEs + :: HasCallStack + => LocalEnv localEs -- ^ Local environment. -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a) -- ^ Continuation with the unlifting function in scope. -> Eff es a -localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do +localSeqUnlift localEs k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs 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'. localSeqUnliftIO - :: (HasCallStack, SharedSuffix es handlerEs, IOE :> es) - => LocalEnv localEs handlerEs + :: (HasCallStack, IOE :> es) + => LocalEnv localEs -- ^ Local environment. -> ((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 localEs k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + seqUnliftIO les k +{-# INLINE localSeqUnliftIO #-} -- | Create a local unlifting function with the given strategy. localUnlift - :: (HasCallStack, SharedSuffix es handlerEs) - => LocalEnv localEs handlerEs + :: HasCallStack + => LocalEnv localEs -- ^ Local environment. -> UnliftStrategy -> ((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 localEs strategy k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + 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 - :: (HasCallStack, SharedSuffix es handlerEs, IOE :> es) - => LocalEnv localEs handlerEs + :: (HasCallStack, IOE :> es) + => LocalEnv localEs -- ^ Local environment. -> UnliftStrategy -> ((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 localEs strategy k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + 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 + => LocalEnv localEs + -- ^ Local environment. + -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a) + -- ^ Continuation with the lifting function in scope. + -> Eff es a +localSeqLift localEs k = unsafeEff $ \es -> do + requireMatchingStorages es localEs + 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 + => LocalEnv localEs + -- ^ 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 localEs strategy k = unsafeEff $ \es -> do + requireMatchingStorages es localEs + 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@ @@ -519,19 +867,24 @@ -- -- /Note:/ the computation must not run its argument in a different thread, -- attempting to do so will result in a runtime error. +-- +-- /Warning:/ if the lifting function is used in a thread distinct from its +-- creator, the lifted computation must not interact with the environment. This +-- cannot be detected at runtime, hence the deprecation. withLiftMap - :: (HasCallStack, SharedSuffix es handlerEs) - => LocalEnv localEs handlerEs + :: HasCallStack + => LocalEnv localEs -- ^ Local environment. -> ((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. - (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do - seqUnliftIO localEs $ \unlift -> do +withLiftMap localEs k = unsafeEff $ \es -> do + requireMatchingStorages es localEs + (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \les -> do + seqUnliftIO les $ \unlift -> do (`unEff` es) . mapEff . unsafeEff_ $ unlift m +{-# DEPRECATED withLiftMap + "Misusing withLiftMap in multiple threads results in undefined behavior. Use localLiftUnlift with an appropriate UnliftStrategy instead." #-} -- | Utility for lifting 'IO' computations of type -- @@ -560,16 +913,17 @@ -- forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask -- :} withLiftMapIO - :: (HasCallStack, SharedSuffix es handlerEs, IOE :> es) - => LocalEnv localEs handlerEs + :: (HasCallStack, IOE :> es) + => LocalEnv localEs -- ^ Local environment. -> ((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 localEs k = unsafeEff $ \es -> do + requireMatchingStorages es localEs + (`unEff` es) $ k $ \mapIO m -> unsafeEff $ \les -> do + seqUnliftIO les $ \unlift -> mapIO $ unlift m +{-# INLINE withLiftMapIO #-} ---------------------------------------- -- Bidirectional lifts @@ -579,25 +933,28 @@ -- Useful for lifting complicated 'Eff' computations where the monadic action -- shows in both positive (as a result) and negative (as an argument) position. -- --- /Note:/ depending on the computation you're lifting 'localUnlift' along with --- 'withLiftMap' might be enough and is more efficient. +-- /Note:/ when 'SeqForkUnlift' or 'ConcUnlift' 'Persistent' strategy is used, +-- the unlifting functions will share the effect storage (unlike with two +-- separate calls to 'localLift' and 'localUnlift'). localLiftUnlift - :: (HasCallStack, SharedSuffix es handlerEs) - => LocalEnv localEs handlerEs + :: HasCallStack + => LocalEnv localEs -- ^ Local environment. -> UnliftStrategy -> ((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 localEs strategy k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + 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 - concUnliftIO les p l $ \unliftLocalEs -> do - (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) + SeqForkUnlift -> seqForkUnliftsIO es les $ \unliftEs unliftLocalEs -> do + (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) + ConcUnlift p l -> concUnliftsIO es les p l $ \unliftEs 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. @@ -608,24 +965,189 @@ -- /Note:/ depending on the computation you're lifting 'localUnliftIO' along -- with 'withLiftMapIO' might be enough and is more efficient. localLiftUnliftIO - :: (HasCallStack, SharedSuffix es handlerEs, IOE :> es) - => LocalEnv localEs handlerEs + :: (HasCallStack, IOE :> es) + => LocalEnv localEs -- ^ Local environment. -> UnliftStrategy -> ((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 localEs strategy k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + 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 localEs a + . (HasCallStack, KnownSubset lentEs es) + => LocalEnv localEs + -> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a) + -- ^ Continuation with the lent handler in scope. + -> Eff es a +localSeqLend localEs k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + 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 localEs a + . (HasCallStack, KnownSubset lentEs es) + => LocalEnv localEs + -> UnliftStrategy + -> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a) + -- ^ Continuation with the lent handler in scope. + -> Eff es a +localLend localEs strategy k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + 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 localEs a + . (HasCallStack, KnownSubset borrowedEs localEs) + => LocalEnv localEs + -> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a) + -- ^ Continuation with the borrowed handler in scope. + -> Eff es a +localSeqBorrow localEs k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + 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 localEs a + . (HasCallStack, KnownSubset borrowedEs localEs) + => LocalEnv localEs + -> UnliftStrategy + -> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a) + -- ^ Continuation with the borrowed handler in scope. + -> Eff es a +localBorrow localEs strategy k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + 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 #-} + +-- | Simultaneously lend effects to the local environment and borrow effects +-- from it with a given unlifting strategy. +-- +-- /Note:/ when 'SeqForkUnlift' or 'ConcUnlift' 'Persistent' strategy is used, +-- the lending and borrowing functions will share the effect storage (unlike +-- with two separate calls to 'localLend' and 'localBorrow'). +-- +-- @since 2.7.0.0 +localLendBorrow + :: forall lentEs borrowedEs es localEs a + . ( HasCallStack + , KnownSubset lentEs es + , KnownSubset borrowedEs localEs + ) + => LocalEnv localEs + -> UnliftStrategy + -> ( (forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) + -> (forall r. Eff (borrowedEs ++ es) r -> Eff es r) + -> Eff es a + ) + -- ^ Continuation with the lending and borrowing functions in scope. + -> Eff es a +localLendBorrow localEs strategy k = unsafeEff $ \es -> do + les <- unwrapLocalEnv es localEs + eles <- copyRefs @lentEs es les + ees <- copyRefs @borrowedEs les es + case strategy of + SeqUnlift -> seqUnliftIO eles $ \unliftLent -> do + seqUnliftIO ees $ \unliftBorrowed -> do + (`unEff` es) $ k (unsafeEff_ . unliftLent) (unsafeEff_ . unliftBorrowed) + SeqForkUnlift -> seqForkUnliftsIO eles ees $ \unliftLent unliftBorrowed -> do + (`unEff` es) $ k (unsafeEff_ . unliftLent) (unsafeEff_ . unliftBorrowed) + ConcUnlift p l -> concUnliftsIO eles ees p l $ \unliftLent unliftBorrowed -> do + (`unEff` es) $ k (unsafeEff_ . unliftLent) (unsafeEff_ . unliftBorrowed) +{-# INLINE localLendBorrow #-} + -- | Require that both effect stacks share an opaque suffix. -- --- Functions from the 'localUnlift' family utilize this constraint to guarantee --- sensible usage of unlifting functions. +-- Functions from the 'localUnlift' family previously required this constraint +-- to reject a subset of improper uses of unlifting functions at compile +-- time. It's no longer necessary, since all of them are detected at runtime +-- now. -- -- As an example, consider the following higher order effect: -- @@ -638,7 +1160,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 +1169,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,29 +1179,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)... --- ... -- --- 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 = interpret $ \env -> \case --- E m -> pure . runPureEff $ do --- localSeqUnlift env $ \unlift -> unlift m --- :} --- ... --- ...Running local actions in monomorphic effect stacks is not supported... +-- >>> runEff . runE3 $ send (E (pure 'x')) +-- *** Exception: Env and LocalEnv point to different Storages. -- ... -- -- @since 1.2.0.0 +{-# DEPRECATED SharedSuffix + "Runtime sanity checks in relevant functions make this constraint unnecessary." + #-} class SharedSuffix (es1 :: [Effect]) (es2 :: [Effect]) instance {-# INCOHERENT #-} SharedSuffix es es @@ -693,6 +1206,117 @@ 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 + requireInScopeSetup es handlerEs + (`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 + requireInScopeSetup es handlerEs + -- 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 (Env soffset srefs _) (Env doffset drefs storage) = do + 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 #-} + +-- | Make sure the setup function of 'reinterpret' or 'impose' runs its +-- argument within its scope. If it runs in a cloned environment, the handler +-- would still operate on the environment of the call site, corrupting it. +requireInScopeSetup :: HasCallStack => Env es -> Env handlerEs -> IO () +requireInScopeSetup es handlerEs + | es.storage /= handlerEs.storage = error + $ "The setup function ran the computation in a cloned environment.\n" + ++ "If you unlifted it with the SeqForkUnlift or ConcUnlift strategy and " + ++ "attempted to run it outside of the scope of the setup function or in " + ++ "a different thread, it's not allowed." + | otherwise = pure () + -- $setup -- >>> import Control.Concurrent (ThreadId, forkIOWithUnmask) +-- >>> import Control.Monad.IO.Class -- >>> import Effectful.Reader.Static diff --git a/src/Effectful/Dispatch/Static.hs b/src/Effectful/Dispatch/Static.hs --- a/src/Effectful/Dispatch/Static.hs +++ b/src/Effectful/Dispatch/Static.hs @@ -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: @@ -216,4 +214,5 @@ concUnliftIO es persistence limit k -- $setup +-- >>> :seti -XFieldSelectors -- >>> import Effectful diff --git a/src/Effectful/Dispatch/Static/Primitive.hs b/src/Effectful/Dispatch/Static/Primitive.hs --- a/src/Effectful/Dispatch/Static/Primitive.hs +++ b/src/Effectful/Dispatch/Static/Primitive.hs @@ -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 diff --git a/src/Effectful/Dispatch/Static/Unsafe.hs b/src/Effectful/Dispatch/Static/Unsafe.hs --- a/src/Effectful/Dispatch/Static/Unsafe.hs +++ b/src/Effectful/Dispatch/Static/Unsafe.hs @@ -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) diff --git a/src/Effectful/Error/Dynamic.hs b/src/Effectful/Error/Dynamic.hs --- a/src/Effectful/Error/Dynamic.hs +++ b/src/Effectful/Error/Dynamic.hs @@ -1,18 +1,29 @@ -- | 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". +-- +-- All caveats described in "Effectful.Error.Static" (in particular the +-- interaction with threads) apply. module Effectful.Error.Dynamic ( -- * Effect Error(..) -- ** Handlers , runError + , runErrorWith , runErrorNoCallStack + , runErrorNoCallStackWith -- ** Operations + , throwErrorWith , throwError + , throwError_ + , rethrowErrorWith + , rethrowError + , rethrowError_ , catchError , handleError , tryError @@ -28,39 +39,132 @@ 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.Effect.Dynamic (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 + RethrowErrorWith display cs e -> E.rethrowErrorWith display cs 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 "") +-- | Throw an error of type @e@ with the given 'E.CallStack' and specify a +-- display function in case a third-party code catches the internal exception +-- and 'show's it. +-- +-- Useful e.g. when you want to catch an error and rethrow it converted to a +-- different type without losing the original 'E.CallStack'. +-- +-- @since 2.7.0.0 +rethrowErrorWith + :: Error e :> es + => (e -> String) + -- ^ The display function. + -> E.CallStack + -- ^ The 'E.CallStack' to attach to the error. + -> e + -- ^ The error. + -> Eff es a +rethrowErrorWith display cs = send . RethrowErrorWith display cs + +-- | Throw an error of type @e@ with the given 'E.CallStack' and 'show' as a +-- display function. +-- +-- @since 2.7.0.0 +rethrowError + :: (Error e :> es, Show e) + => E.CallStack + -- ^ The 'E.CallStack' to attach to the error. + -> e + -- ^ The error. + -> Eff es a +rethrowError = rethrowErrorWith show + +-- | Throw an error of type @e@ with the given 'E.CallStack' and no display +-- function. +-- +-- @since 2.7.0.0 +rethrowError_ + :: Error e :> es + => E.CallStack + -- ^ The 'E.CallStack' to attach to the error. + -> e + -- ^ The error. + -> Eff es a +rethrowError_ = rethrowErrorWith (const "") + -- | Handle an error of type @e@. catchError :: (HasCallStack, Error e :> es) @@ -74,7 +178,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 diff --git a/src/Effectful/Error/Static.hs b/src/Effectful/Error/Static.hs --- a/src/Effectful/Error/Static.hs +++ b/src/Effectful/Error/Static.hs @@ -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,38 @@ -- -- /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. +-- +-- === Interaction with threads +-- +-- The 'Error' effect uses runtime exceptions underneath, so the usual rules +-- apply. In particular, in multi-threaded code an error thrown in a child +-- thread will not automatically propagate to the parent. If you need that, use +-- functions such as @withAsync@ from the +-- [Effectful.Concurrent.Async](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent-Async.html) +-- module of the @effectful@ package (which propagate exceptions from child +-- threads to their parents) or arrange the propagation yourself. +-- +-- For more information see the documentation of the +-- [Concurrent](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent.html#t:Concurrent) +-- effect. module Effectful.Error.Static ( -- * Effect Error -- ** Handlers , runError + , runErrorWith , runErrorNoCallStack + , runErrorNoCallStackWith -- ** Operations + , throwErrorWith , throwError + , throwError_ + , rethrowErrorWith + , rethrowError + , rethrowError_ , catchError , handleError , tryError @@ -96,17 +117,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 +134,145 @@ -- | 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 "") +-- | Throw an error of type @e@ with the given 'CallStack' and specify a +-- display function in case a third-party code catches the internal exception +-- and 'show's it. +-- +-- Useful e.g. when you want to catch an error and rethrow it converted to a +-- different type without losing the original 'CallStack'. +-- +-- @since 2.7.0.0 +rethrowErrorWith + :: forall e es a. Error e :> es + => (e -> String) + -- ^ The display function. + -> CallStack + -- ^ The 'CallStack' to attach to the error. + -> e + -- ^ The error. + -> Eff es a +rethrowErrorWith display cs e = do + Error eid <- getStaticRep @(Error e) + throwIO $ ErrorWrapper eid cs (display e) (toAny e) + +-- | Throw an error of type @e@ with the given 'CallStack' and 'show' as a +-- display function. +-- +-- @since 2.7.0.0 +rethrowError + :: forall e es a. (Error e :> es, Show e) + => CallStack + -- ^ The 'CallStack' to attach to the error. + -> e + -- ^ The error. + -> Eff es a +rethrowError = rethrowErrorWith show + +-- | Throw an error of type @e@ with the given 'CallStack' and no display +-- function. +-- +-- @since 2.7.0.0 +rethrowError_ + :: forall e es a. Error e :> es + => CallStack + -- ^ The 'CallStack' to attach to the error. + -> e + -- ^ The error. + -> Eff es a +rethrowError_ = rethrowErrorWith (const "") + -- | 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 +283,46 @@ -- | 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 p (ErrorWrapper _ cs errRep _) + = showParen (p > 10) + $ ("Effectful.Error.Static.ErrorWrapper: " ++) + . (errRep ++) + . ("\n" ++) + . (prettyCallStack cs ++) + . ("\n\nIf you see this message, most likely an error escaped the " ++) + . ("scope of its handler, e.g. by being thrown from a thread that " ++) + . ("outlived it, or was caught by an overly zealous exception handler. " ++) + . ("For more information see the documentation of the " ++) + . ("Effectful.Error.Static module." ++) -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 diff --git a/src/Effectful/Exception.hs b/src/Effectful/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Exception.hs @@ -0,0 +1,659 @@ +{-# 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) + -- $cleanup + , 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 + +-- $cleanup +-- +-- /Note:/ when compiled with @base@ >= 4.21, if the computation to run last +-- throws an exception while another one is being propagated, the original +-- exception is preserved in a @WhileHandling@ annotation of the new one. This +-- is what the corresponding functions from "Control.Exception" do since @base@ +-- 4.23 instead of discarding the original exception, see [CLC proposal +-- #397](https://github.com/haskell/core-libraries-committee/issues/397). + +-- | 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 = mask $ \restore -> do + a <- before + r <- restore (action a) `onException` after a + _ <- after a + pure r + +-- | 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 = bracket before (const after) (const 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 = mask $ \restore -> do + a <- before + restore (action a) `onException` after a + +-- | 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 = mask $ \restore -> do + r <- restore action `onException` handler + _ <- handler + pure r + +-- | 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 = + withException @E.SomeException action (const 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) diff --git a/src/Effectful/Fail.hs b/src/Effectful/Fail.hs --- a/src/Effectful/Fail.hs +++ b/src/Effectful/Fail.hs @@ -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 diff --git a/src/Effectful/Input/Dynamic.hs b/src/Effectful/Input/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Input/Dynamic.hs @@ -0,0 +1,68 @@ +-- | The dynamically dispatched variant of the 'Input' effect. +-- +-- /Note:/ unless you plan to change interpretations at runtime, it's +-- recommended to use one of the statically dispatched variants, +-- i.e. "Effectful.Input.Static" or "Effectful.Input.Static.Action". +-- +-- @since 2.7.0.0 +module Effectful.Input.Dynamic + ( -- * Effect + Input(..) + + -- ** Handlers + , runInput + , runInputAction + + -- ** Operations + , input + , inputs + ) where + +import Effectful +import Effectful.Dispatch.Dynamic + +-- | Provide access to values of type @i@. +data Input i :: Effect where + Input :: Input i m i + +type instance DispatchOf (Input i) = Dynamic + +---------------------------------------- +-- Handlers + +-- | Run the 'Input' effect with the given value. +runInput + :: HasCallStack + => i + -- ^ The input value. + -> Eff (Input i : es) a + -> Eff es a +runInput inputValue = interpret_ $ \case + Input -> pure inputValue + +-- | Run the 'Input' effect with the given action that supplies values. +runInputAction + :: forall i es a + . HasCallStack + => (HasCallStack => Eff es i) + -- ^ The action for input generation. + -> Eff (Input i : es) a + -> Eff es a +runInputAction inputAction = interpret_ $ \case + Input -> inputAction + +---------------------------------------- +-- Operations + +-- | Fetch the value. +input :: (HasCallStack, Input i :> es) => Eff es i +input = send Input + +-- | Fetch the result of applying a function to the value. +-- +-- @'inputs' f ≡ f '<$>' 'input'@ +inputs + :: (HasCallStack, Input i :> es) + => (i -> a) -- ^ The function to apply to the value. + -> Eff es a +inputs f = f <$> input diff --git a/src/Effectful/Input/Static.hs b/src/Effectful/Input/Static.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Input/Static.hs @@ -0,0 +1,49 @@ +-- | Support for access to a value of a particular type. +-- +-- @since 2.7.0.0 +module Effectful.Input.Static + ( -- * Effect + Input + + -- ** Handlers + , runInput + + -- ** Operations + , input + , inputs + ) where + +import Data.Kind + +import Effectful +import Effectful.Dispatch.Static + +-- | Provide access to a value of type @i@. +data Input (i :: Type) :: Effect + +type instance DispatchOf (Input i) = Static NoSideEffects +newtype instance StaticRep (Input i) = Input i + +-- | Run the 'Input' effect with the given value. +runInput + :: HasCallStack + => i + -- ^ The input value. + -> Eff (Input i : es) a + -> Eff es a +runInput = evalStaticRep . Input + +-- | Fetch the value. +input :: (HasCallStack, Input i :> es) => Eff es i +input = do + Input i <- getStaticRep + pure i + +-- | Fetch the result of applying a function to the value. +-- +-- @'inputs' f ≡ f '<$>' 'input'@ +inputs + :: (HasCallStack, Input i :> es) + => (i -> a) -- ^ The function to apply to the value. + -> Eff es a +inputs f = f <$> input diff --git a/src/Effectful/Input/Static/Action.hs b/src/Effectful/Input/Static/Action.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Input/Static/Action.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ImplicitParams #-} +-- | Support for access to values supplied by a monadic action. +-- +-- @since 2.7.0.0 +module Effectful.Input.Static.Action + ( -- * Effect + Input + + -- ** Handlers + , runInput + + -- ** Operations + , input + , inputs + ) where + +import Data.Kind +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Internal.Utils + +-- | Provide access to values of type @i@ supplied by a monadic action. +data Input (i :: Type) :: Effect + +type instance DispatchOf (Input i) = Static NoSideEffects + +-- | Wrapper to prevent a space leak on reconstruction of 'Input' in +-- 'relinkInput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520). +newtype InputImpl i es where + InputImpl :: (HasCallStack => Eff es i) -> InputImpl i es + +data instance StaticRep (Input i) where + Input + :: !(Env inputEs) + -> !(InputImpl i inputEs) + -> StaticRep (Input i) + +-- | Run the 'Input' effect with the given action that supplies values. +runInput + :: forall i es a + . HasCallStack + => (HasCallStack => Eff es i) + -- ^ The action for input generation. + -> Eff (Input i : es) a + -> Eff es a +runInput inputAction action = unsafeEff $ \es -> do + inlineBracket + (consEnv (Input es inputImpl) relinkInput es) + unconsEnv + (unEff action) + where + inputImpl = InputImpl $ let ?callStack = thawCallStack ?callStack in inputAction + +-- | Fetch the value. +input :: (HasCallStack, Input i :> es) => Eff es i +input = unsafeEff $ \es -> do + Input inputEs (InputImpl inputAction) <- getEnv es + -- Corresponds to thawCallStack in runInput. + (`unEff` inputEs) $ withFrozenCallStack inputAction + +-- | Fetch the result of applying a function to the value. +-- +-- @'inputs' f ≡ f '<$>' 'input'@ +inputs + :: (HasCallStack, Input i :> es) + => (i -> a) -- ^ The function to apply to the value. + -> Eff es a +inputs f = f <$> input + +---------------------------------------- +-- Helpers + +relinkInput :: Relinker StaticRep (Input i) +relinkInput = Relinker $ \relink (Input inputEs inputAction) -> do + newActionEs <- relink inputEs + pure $ Input newActionEs inputAction diff --git a/src/Effectful/Internal/Effect.hs b/src/Effectful/Internal/Effect.hs --- a/src/Effectful/Internal/Effect.hs +++ b/src/Effectful/Internal/Effect.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | Type-safe indexing for 'Effectful.Internal.Monad.Env'. -- @@ -10,6 +9,10 @@ , (:>)(..) , (:>>) , Subset(..) + , KnownSubset + , KnownPrefix(..) + , IsUnknownSuffixOf + , type (++) -- * Re-exports , Type @@ -38,8 +41,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 +65,71 @@ 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 ++ diff --git a/src/Effectful/Internal/Effect/Dynamic.hs b/src/Effectful/Internal/Effect/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Internal/Effect/Dynamic.hs @@ -0,0 +1,99 @@ +{-# 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.Effect.Dynamic 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 + -- | @since 2.7.0.0 + RethrowErrorWith :: (e -> String) -> CallStack -> 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 + +{-# DEPRECATED StateM "Use a combination of Get and Put instead." #-} + +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. +-- +-- /Warning:/ 'MTL.pass' is not implemented due to ambiguous semantics in +-- presence of runtime exceptions, so calling it (also indirectly via +-- 'MTL.censor', which is defined in terms of 'MTL.pass') results in a runtime +-- error. +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" diff --git a/src/Effectful/Internal/Env.hs b/src/Effectful/Internal/Env.hs --- a/src/Effectful/Internal/Env.hs +++ b/src/Effectful/Internal/Env.hs @@ -1,10 +1,30 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} module Effectful.Internal.Env ( -- * The environment Env(..) + , Ref(..) + , Version , Storage(..) + -- ** StorageData + , StorageData(..) + , cloneStorage + , replaceStorage + , backupStorageData + , restoreStorageData + + -- *** Utils + , AnyRelinker + , toAnyRelinker + , fromAnyRelinker + , AnyEffect + , toAnyEffect + , fromAnyEffect + -- ** Relinker , Relinker(..) , dummyRelinker @@ -38,10 +58,13 @@ import Control.Monad import Control.Monad.Primitive -import Data.IORef +import Data.IORef.Strict qualified as S import Data.Primitive.PrimArray import Data.Primitive.SmallArray -import GHC.Stack (HasCallStack) +import Data.Primitive.Types +import Data.Proxy +import GHC.Exts ((*#), (+#)) +import GHC.Stack import Effectful.Internal.Effect import Effectful.Internal.Utils @@ -72,28 +95,206 @@ -- - Cloning: /@O(N)@/, where @N@ is the size of the 'Storage'. -- data Env (es :: [Effect]) = Env - { envOffset :: !Int - , envRefs :: !(PrimArray Int) - , envStorage :: !(IORef Storage) + { offset :: !Int + , refs :: !(PrimArray Ref) + , storage :: !(S.IORef Storage) } +-- | Reference to the effect in 'Storage'. +data Ref = Ref !Int !Version + +instance Prim Ref where + sizeOfType# _ = 2# *# sizeOfType# (Proxy @Int) + alignmentOfType# _ = alignmentOfType# (Proxy @Int) + indexByteArray# arr i = + let n = 2# *# i + ref = indexByteArray# arr n + version = indexByteArray# arr (n +# 1#) + in Ref ref version + readByteArray# arr i s0 = + let n = 2# *# i + !(# s1, ref #) = readByteArray# arr n s0 + !(# s2, version #) = readByteArray# arr (n +# 1#) s1 + in (# s2, Ref ref version #) + writeByteArray# arr i (Ref ref version) s0 = + let n = 2# *# i + s1 = writeByteArray# arr n ref s0 + s2 = writeByteArray# arr (n +# 1#) version s1 + in s2 + indexOffAddr# addr i = + let n = 2# *# i + ref = indexOffAddr# addr n + version = indexOffAddr# addr (n +# 1#) + in Ref ref version + readOffAddr# addr i s0 = + let n = 2# *# i + !(# s1, ref #) = readOffAddr# addr n s0 + !(# s2, version #) = readOffAddr# addr (n +# 1#) s1 + in (# s2, Ref ref version #) + writeOffAddr# addr i (Ref ref version) s0 = + let n = 2# *# i + s1 = writeOffAddr# addr n ref s0 + s2 = writeOffAddr# addr (n +# 1#) version s1 + in s2 + +-- | Version of the effect. +newtype Version = Version Int + deriving newtype (Eq, Ord, Prim, Show) + -- | A storage of effects. data Storage = Storage - { stSize :: !Int - , stVersion :: !Int - , stVersions :: !(MutablePrimArray RealWorld Int) - , stEffects :: !(SmallMutableArray RealWorld Any) - , stRelinkers :: !(SmallMutableArray RealWorld Any) + { version :: !Version + , data_ :: {-# 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 + { size :: !Int + , versions :: !(MutablePrimArray RealWorld Version) + , effects :: !(SmallMutableArray RealWorld AnyEffect) + , relinkers :: !(SmallMutableArray RealWorld AnyRelinker) + } + +-- | Clone the storage to use it in a different thread. +-- +-- @since 2.7.0.0 +cloneStorage :: HasCallStack => S.IORef Storage -> IO (S.IORef Storage) +cloneStorage storage0 = do + Storage version storageData0 <- S.readIORef storage0 + storageData <- copyStorageData storageData0 + storage <- S.newIORef $ Storage version storageData + relinkStorageData storageData storage + pure storage + +-- | Replace the storage of the environment. +-- +-- @since 2.7.0.0 +replaceStorage :: Env es -> S.IORef Storage -> IO (Env es) +replaceStorage (Env offset refs _) storage = pure $ Env offset refs storage + +-- | 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 + +-- | Relink effects in the storage data to the given storage. +-- +-- @since 2.7.0.0 +relinkStorageData :: HasCallStack => StorageData -> S.IORef Storage -> IO () +relinkStorageData (StorageData storageSize _ es fs) storage = go storageSize + where + go = \case + 0 -> pure () + k -> do + let i = k - 1 + Relinker relinker <- fromAnyRelinker <$> readSmallArray fs i + readSmallArray es i + >>= relinker (relinkEnv storage) . fromAnyEffect + >>= writeSmallArray' es i . toAnyEffect + go i + +-- | Backup storage data of the environment. +-- +-- It can be restored later with 'restoreStorageData'. +-- +-- @since 2.7.0.0 +backupStorageData :: HasCallStack => Env es -> IO StorageData +backupStorageData env = do + storageData <- copyStorageData . (.data_) =<< S.readIORef env.storage + -- Relinking to the same storage might seem weird, but relinkers need to run + -- and make a copy of mutable data associated with statically dispatched + -- effects if appropriate. + relinkStorageData storageData env.storage + pure storageData + +-- | Restore a copy of the 'StorageData'. +-- +-- The copy needs to be from the same 'Env' as the target. It's consumed by this +-- operation and must not be used afterwards. +-- +-- @since 2.5.0.0 +restoreStorageData :: HasCallStack => StorageData -> Env es -> IO () +restoreStorageData (StorageData newSize vs1 es1 fs1) env = do + Storage version (StorageData oldSize vs0 es0 fs0) <- S.readIORef env.storage + when (newSize /= oldSize) $ do + error $ "newSize (" ++ show newSize ++ ") /= oldSize (" ++ show oldSize ++ ")" + -- Since the time the backup was made the storage might've been grown by + -- 'insertEffect', so if necessary create new arrays matching the current + -- capacity, as shrinking it would violate the invariant that out of date + -- references in 'getLocation' never read out of bounds. + vs0size <- getSizeofMutablePrimArray vs0 + vs1size <- getSizeofMutablePrimArray vs1 + vs <- if vs0size > vs1size + then do + vs <- newPrimArray vs0size + copyMutablePrimArray vs 0 vs1 0 newSize + -- Fill the unused part of the versions array with + -- 'undefinedVersion' to maintain the invariant that slots beyond + -- the size of the storage never contain garbage (see the note on + -- 'undefinedVersion'). + setPrimArray vs newSize (vs0size - newSize) undefinedVersion + pure vs + else pure vs1 + es0size <- getSizeofSmallMutableArray es0 + es1size <- getSizeofSmallMutableArray es1 + es <- if es0size > es1size + then do + es <- newSmallArray es0size undefinedEffect + copySmallMutableArray es 0 es1 0 newSize + pure es + else pure es1 + fs0size <- getSizeofSmallMutableArray fs0 + fs1size <- getSizeofSmallMutableArray fs1 + fs <- if fs0size > fs1size + then do + fs <- newSmallArray fs0size undefinedRelinker + copySmallMutableArray fs 0 fs1 0 newSize + pure fs + else pure fs1 + S.writeIORef env.storage $ Storage version (StorageData newSize vs es fs) + +---------------------------------------- -- 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,78 +325,57 @@ -- Operations -- | Create an empty environment. -emptyEnv :: IO (Env '[]) +emptyEnv :: HasCallStack => IO (Env '[]) emptyEnv = Env 0 <$> (unsafeFreezePrimArray =<< newPrimArray 0) - <*> (newIORef =<< emptyStorage) + <*> (S.newIORef =<< emptyStorage) -- | Clone the environment to use it in a different thread. -cloneEnv :: 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 - let relinkEffects = \case - 0 -> pure () - k -> do - let i = k - 1 - Relinker f <- fromAny <$> readSmallArray fs i - readSmallArray es i - >>= f (relinkEnv storage) . fromAny - >>= writeSmallArray es i . toAny - relinkEffects i - relinkEffects storageSize - pure $ Env offset refs storage -{-# NOINLINE cloneEnv #-} +cloneEnv :: HasCallStack => Env es -> IO (Env es) +cloneEnv env = replaceStorage env =<< cloneStorage env.storage -- | 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 #-} -- | Shrink the environment by one data type. -- +-- The environment needs to come from 'consEnv', i.e. the intended usage is +-- @bracket (consEnv e f env) unconsEnv@. +-- -- /Note:/ after calling this function @e@ from the input environment is no -- longer usable. -unconsEnv :: Env (e : es) -> IO () -unconsEnv (Env _ refs storage) = do +unconsEnv :: HasCallStack => Env (e : es) -> IO () +unconsEnv (Env offset refs storage) = do + when (offset /= 0) $ do + error $ "offset (" ++ show offset ++ ") /= 0" deleteEffect storage (indexPrimArray refs 0) -{-# NOINLINE unconsEnv #-} ---------------------------------------- @@ -204,7 +384,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,22 +394,23 @@ 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 #-} -- | Remove a reference to the replaced effect. -- +-- The environment needs to come from 'replaceEnv', i.e. the intended usage is +-- @bracket (replaceEnv e f env) unreplaceEnv@. +-- -- /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) -{-# NOINLINE unreplaceEnv #-} + when (offset /= 0) $ do + error $ "offset (" ++ show offset ++ ") /= 0" + deleteEffect storage $ indexPrimArray refs (reifyIndex @e @es) ---------------------------------------- @@ -237,31 +418,32 @@ 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 #-} ---------------------------------------- -- | 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 +453,171 @@ -- | 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 _) <- S.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 + => S.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) <- S.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) + S.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 + -- Fill the unused part of the versions array with 'undefinedVersion' to + -- maintain the invariant that slots beyond the size of the storage never + -- contain garbage (see the note on 'undefinedVersion'). + setPrimArray vs size (len - size) undefinedVersion 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) + S.writeIORef storage $ + Storage (bumpVersion version) (StorageData (size + 1) vs es fs) + pure $ Ref size version +{-# NOINLINE insertEffect #-} -- | 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 => S.IORef Storage -> Ref -> IO () +deleteEffect storage (Ref ref version) = do + Storage currentVersion (StorageData size vs es fs) <- S.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 + S.writeIORef storage $ Storage currentVersion (StorageData (size - 1) vs es fs) +{-# NOINLINE deleteEffect #-} -- | Relink the environment to use the new storage. -relinkEnv :: IORef Storage -> Env es -> IO (Env es) +relinkEnv :: S.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 +-- | Version of an unused slot. +-- +-- /Note:/ slots of the versions array beyond the current size of the storage +-- always contain 'undefinedVersion', so that out of date references to them +-- reliably fail the version check in 'getLocation'. This invariant is +-- maintained by 'insertEffect', 'deleteEffect' and 'restoreStorageData'. +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 diff --git a/src/Effectful/Internal/Monad.hs b/src/Effectful/Internal/Monad.hs --- a/src/Effectful/Internal/Monad.hs +++ b/src/Effectful/Internal/Monad.hs @@ -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,18 +43,27 @@ , Limit(..) , unliftStrategy , withUnliftStrategy + , withSeqEffToIO , withEffToIO + , reallyUnsafeLiftMapIO + , reallyUnsafeUnliftIO -- ** Low-level unlifts , seqUnliftIO + , seqForkUnliftIO , concUnliftIO + , seqForkUnliftsIO + , concUnliftsIO -- * Dispatch -- ** Dynamic dispatch , EffectHandler - , LocalEnv(..) + , LocalEnv + , unwrapLocalEnv + , requireMatchingStorages , Handler(..) + , HandlerImpl(..) , relinkHandler , runHandler , send @@ -65,17 +79,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 +95,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 +124,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 +144,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 +164,49 @@ -- Unlifting IO -- | Get the current 'UnliftStrategy'. -unliftStrategy :: IOE :> es => Eff es UnliftStrategy +-- +-- /Note:/ this strategy is implicitly used by the 'MonadUnliftIO' and +-- 'MonadBaseControl' instance for 'Eff'. +unliftStrategy :: (HasCallStack, IOE :> es) => Eff es UnliftStrategy unliftStrategy = do IOE unlift <- getStaticRep pure unlift --- | Locally override the 'UnliftStrategy' with the given value. -withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a +-- | Locally override the current 'UnliftStrategy' with the given value. +withUnliftStrategy :: (HasCallStack, 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 +215,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 == 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 +246,118 @@ -> ((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) k = ephemeralConcLimitedUnlift es uses k +concUnliftIO es Ephemeral Unlimited k = ephemeralConcUnlimitedUnlift es k +concUnliftIO es Persistent (Limited threads) k = + if threads == 1 + then persistentConcSingleUnlift es k + else persistentConcUnlift es False threads k +concUnliftIO es Persistent Unlimited k = persistentConcUnlift es True maxBound k +-- | Create two unlifting functions with the 'SeqForkUnlift' strategy. +-- +-- The unlifting functions will share the effect storage (unlike with two +-- separate calls to 'seqForkUnliftIO'). +-- +-- /Warning:/ both environments must have the same underlying storage. +-- +-- @since 2.7.0.0 +seqForkUnliftsIO + :: HasCallStack + => Env es + -> Env localEs + -> ((forall r. Eff es r -> IO r) -> (forall r. Eff localEs r -> IO r) -> IO a) + -- ^ Continuation with the unlifting functions in scope. + -> IO a +seqForkUnliftsIO es0 les0 k = do + storage <- cloneStorage es0.storage + es <- replaceStorage es0 storage + les <- replaceStorage les0 storage + seqUnliftIO es $ \unliftEs -> do + seqUnliftIO les $ \unliftLocalEs -> do + k unliftEs unliftLocalEs +{-# INLINE seqForkUnliftsIO #-} + +-- | Create unlifting functions with the 'ConcUnlift' strategy. +-- +-- In the 'Persistent' variant the unlifting functions will share the effect +-- storage in each thread (unlike with two separate calls to 'concUnliftIO'). +-- +-- /Warning:/ both environments must have the same underlying storage. +-- +-- @since 2.7.0.0 +concUnliftsIO + :: HasCallStack + => Env es + -> Env localEs + -- ^ The environment. + -> Persistence + -> Limit + -> ((forall r. Eff es r -> IO r) -> (forall r. Eff localEs r -> IO r) -> IO a) + -- ^ Continuation with the unlifting functions in scope. + -> IO a +concUnliftsIO es les Ephemeral (Limited uses) k = do + ephemeralConcLimitedUnlift es uses $ \unliftEs -> do + ephemeralConcLimitedUnlift les uses $ \unliftLocalEs -> do + k unliftEs unliftLocalEs +concUnliftsIO es les Ephemeral Unlimited k = do + ephemeralConcUnlimitedUnlift es $ \unliftEs -> do + ephemeralConcUnlimitedUnlift les $ \unliftLocalEs -> do + k unliftEs unliftLocalEs +concUnliftsIO es les Persistent (Limited threads) k = do + if threads == 1 + then persistentConcSingleUnlifts es les k + else persistentConcUnlifts es les False threads k +concUnliftsIO es les Persistent Unlimited k = do + persistentConcUnlifts es les True maxBound k + +-- | 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 +373,129 @@ 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 +-- | Available without any effect requirements. +-- +-- Gating it behind an effect (such as 'IOE' or a more specialized effect) would +-- accomplish nothing, since any Haskell expression is free to throw an +-- exception with 'E.throw' at any point. instance C.MonadThrow (Eff es) where - throwM = unsafeEff_ . E.throwIO + throwM = unsafeEff_ . withFrozenCallStack E.throwIO +#if MIN_VERSION_base(4,21,0) && MIN_VERSION_exceptions(0,10,11) + rethrowM = unsafeEff_ . E.rethrowIO +#endif + +-- | Available without any effect requirements. +-- +-- This is the one instance of the three that would arguably benefit from +-- requiring 'IOE' (or a more specialized effect), as catching imprecise +-- exceptions makes it possible to write non-deterministic pure functions with +-- 'runPureEff'. Unfortunately it can't, because t'C.MonadCatch' is a superclass +-- of t'C.MonadMask', which needs to be available unconditionally (see the note +-- there). +-- +-- For the full discussion see +-- [issue #76](https://github.com/haskell-effectful/effectful/issues/76). 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) +#if MIN_VERSION_base(4,21,0) && MIN_VERSION_exceptions(0,10,11) + catchNoPropagate action handler = reallyUnsafeUnliftIO $ \unlift -> do + E.catchNoPropagate (unlift action) (unlift . handler) +#endif + +-- | Available without any effect requirements. +-- +-- This makes it possible to use cleanup functions such as +-- 'Effectful.Exception.bracket' or 'Effectful.Exception.finally' anywhere, e.g. +-- to restore a state on error: +-- +-- @ +-- transactionally :: forall s es a. 'Effectful.State.Static.Local.State' s ':>' es => 'Eff' es a -> 'Eff' es a +-- transactionally = 'Effectful.Exception.bracketOnError' ('Effectful.State.Static.Local.get' \@s) ('Effectful.State.Static.Local.put' \@s) . const +-- @ +-- +-- Requiring 'IOE' would make functions like the above impossible to write and +-- force 'IOE' to show up in application code that otherwise only needs more +-- restricted effects, which would be a significant usability regression. On the +-- other hand, requiring a more specialized effect would be annoying, since +-- functions making use of t'C.MonadMask' are ubiquitous. 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 +513,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 +556,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,83 +585,156 @@ -> ((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 ---------------------------------------- -- Dynamic dispatch -type role LocalEnv nominal nominal +type role LocalEnv nominal -- | Opaque representation of the 'Eff' environment at the point of calling the -- 'send' function, i.e. right before the control is passed to the effect -- handler. -- --- The second type variable represents effects of a handler and is needed for --- technical reasons to guarantee soundness (see --- t'Effectful.Dispatch.Dynamic.SharedSuffix' for more information). -newtype LocalEnv (localEs :: [Effect]) (handlerEs :: [Effect]) = LocalEnv (Env localEs) +-- /Note:/ functions that consume it perform runtime checks to ensure that it's +-- used within the scope of the effect handler it belongs to. +newtype LocalEnv (localEs :: [Effect]) = LocalEnv (Env localEs) +-- | Unwrap the 'LocalEnv' via 'requireMatchingStorages'. +unwrapLocalEnv :: HasCallStack => Env es -> LocalEnv localEs -> IO (Env localEs) +unwrapLocalEnv es localEs@(LocalEnv les) = do + requireMatchingStorages es localEs + pure les + +-- | Make sure that the 'LocalEnv' is used in the thread/context of the effect +-- handler it belongs to. +requireMatchingStorages :: HasCallStack => Env es -> LocalEnv localEs -> IO () +requireMatchingStorages es (LocalEnv les) + | es.storage /= les.storage = error + $ "Env and LocalEnv point to different Storages.\n" + ++ "If you passed LocalEnv to a different thread/context and tried to " + ++ "use it there, it's not allowed. You need to use it in the " + ++ "thread/context of the effect handler." + | otherwise = pure () + -- | 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 + => LocalEnv localEs -- ^ 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 (es.storage /= handlerEs.storage) $ 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 +753,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) diff --git a/src/Effectful/Internal/Unlift.hs b/src/Effectful/Internal/Unlift.hs --- a/src/Effectful/Internal/Unlift.hs +++ b/src/Effectful/Internal/Unlift.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MagicHash #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} -- | Implementation of sequential and concurrent unlifts. @@ -12,14 +13,19 @@ , Limit(..) -- * Unlifting functions - , seqUnlift - , concUnlift - , ephemeralConcUnlift + , ephemeralConcLimitedUnlift + , ephemeralConcUnlimitedUnlift , persistentConcUnlift + , persistentConcSingleUnlift + , persistentConcUnlifts + , persistentConcSingleUnlifts ) where import Control.Concurrent +import Control.Concurrent.MVar.Strict qualified as S import Control.Monad +import Data.Coerce +import Data.Word import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (mkWeak#, mkWeakNoFinalizer#) import GHC.Generics (Generic) @@ -27,30 +33,75 @@ 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 +import Effectful.Internal.Utils.Word64Map qualified as M ---------------------------------------- -- 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. -- @@ -63,6 +114,78 @@ -- - Lifting 'Control.Concurrent.forkIOWithUnmask' requires the 'Persistent' -- strategy, otherwise the unmasking function would start with a fresh -- environment each time it's called. +-- +-- Both cases come down to what happens when the unlifting function is called +-- more than once in the same thread. If a thread calls it only once, the +-- 'Persistence' setting makes no observable difference. +-- +-- === Example 1 +-- +-- Consider a thread that modifies thread local state, then inspects it with a +-- second call to the unlifting function: +-- +-- >>> import Control.Concurrent +-- >>> import Control.Monad +-- >>> import Effectful +-- >>> import Effectful.State.Dynamic +-- +-- >>> :{ +-- modifyThenGet :: UnliftStrategy -> IO Int +-- modifyThenGet strategy = runEff . evalStateLocal @Int 0 $ do +-- withEffToIO strategy $ \unlift -> do +-- result <- newEmptyMVar +-- void . forkIO $ do +-- unlift $ modify @Int (+1) +-- putMVar result =<< unlift (get @Int) +-- takeMVar result +-- :} +-- +-- With the 'Persistent' strategy the unlifting function keeps the environment +-- between the calls, so the second call sees the modification from the first +-- one: +-- +-- >>> modifyThenGet $ ConcUnlift Persistent (Limited 1) +-- 1 +-- +-- On the other hand, with 'Ephemeral' each call to the unlifting function +-- starts with a fresh copy of the environment, so the modification is silently +-- lost: +-- +-- >>> modifyThenGet $ ConcUnlift Ephemeral (Limited 2) +-- 0 +-- +-- This also showcases the limit meaning different things for the two settings: +-- for the 'Persistent' strategy it limits the number of threads the unlifting +-- can happen in, for 'Ephemeral' it limits the number of calls to the unlifting +-- function. +-- +-- === Example 2 +-- +-- Consider a situation where a single worker thread runs multiple independent +-- jobs: +-- +-- >>> :{ +-- twoJobs :: UnliftStrategy -> IO [Int] +-- twoJobs strategy = runEff . evalStateLocal @Int 0 $ do +-- withEffToIO strategy $ \unlift -> do +-- result <- newEmptyMVar +-- void . forkIO $ do +-- let job = unlift $ modify @Int (+1) >> get @Int +-- putMVar result =<< sequence [job, job] +-- takeMVar result +-- :} +-- +-- With 'Ephemeral' both jobs start from the environment as it was when the +-- unlifting function was created: +-- +-- >>> twoJobs $ ConcUnlift Ephemeral Unlimited +-- [1,1] +-- +-- With 'Persistent' the second job inherits changes made by the first one, even +-- though the user would most likely expect them to be independent: +-- +-- >>> twoJobs $ ConcUnlift Persistent Unlimited +-- [1,2] data Persistence = Ephemeral -- ^ Don't persist the environment between calls to the unlifting function in @@ -70,7 +193,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 +212,23 @@ -- 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 +-- | Concurrent unlift with limited uses that doesn't preserve the environment +-- between calls to the unlifting function in threads other than its creator. +-- +-- @since 2.7.0.0 +ephemeralConcLimitedUnlift + :: (HasCallStack, forall r. Coercible (effEs 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) + -> ((forall r. effEs r -> IO r) -> IO a) -> IO a -ephemeralConcUnlift uses k es0 unEff = do +ephemeralConcLimitedUnlift es0 uses k = do unless (uses > 0) $ do error $ "Invalid number of uses: " ++ show uses tid0 <- myThreadId @@ -147,34 +236,53 @@ -- 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 - k $ \m -> do - es <- myThreadId >>= \case - tid | tid0 `eqThreadId` tid -> pure es0 - _ -> 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 + mvUses <- S.newMVar uses + let getEs = myThreadId >>= \case + tid | tid0 == tid -> pure es0 + _ -> S.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 + es <- cloneEnv esTemplate + pure (n - 1, es) + k $ \action -> coerce action =<< getEs +{-# INLINE ephemeralConcLimitedUnlift #-} +-- | Concurrent unlift with unlimited uses that doesn't preserve the environment +-- between calls to the unlifting function in threads other than its creator. +-- +-- @since 2.7.0.0 +ephemeralConcUnlimitedUnlift + :: (HasCallStack, forall r. Coercible (effEs r) (Env es -> IO r)) + => Env es + -> ((forall r. effEs r -> IO r) -> IO a) + -> IO a +ephemeralConcUnlimitedUnlift es0 k = do + tid0 <- myThreadId + -- Create a copy of the environment as a template for the other threads to + -- use. This can't be done from inside the callback as the environment might + -- have already changed by then. + esTemplate <- cloneEnv es0 + let getEs = myThreadId >>= \case + tid | tid0 == tid -> pure es0 + _ -> cloneEnv esTemplate + k $ \action -> coerce action =<< getEs +{-# INLINE ephemeralConcUnlimitedUnlift #-} + -- | Concurrent unlift that preserves the environment between calls to the -- unlifting function within a particular thread. persistentConcUnlift - :: HasCallStack - => Bool + :: (HasCallStack, forall r. Coercible (effEs 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) + -> ((forall r. effEs r -> IO r) -> IO a) -> 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,139 +290,218 @@ -- 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 - k $ \m -> do - es <- myThreadId >>= \case - tid | tid0 `eqThreadId` tid -> pure es0 - 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 - Nothing -> pure (Nothing, newEntryId) - case mes of - Just es -> pure (te, es) - Nothing -> case teCapacity te of - 0 -> error - $ "Number of other threads (" ++ show threads ++ ") permitted to " - ++ "use the unlifting function was exceeded. Please increase the " - ++ "limit or use the unlimited variant." - 1 -> do - wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp - let newEntries = ThreadEntries - { teCapacity = teCapacity te - 1 - , teEntries = addThreadData wkTid i wkTidEs $ teEntries te - } - newEntries `seq` pure (newEntries, esTemplate) - _ -> do - es <- cloneEnv esTemplate - wkTidEs <- mkWeakThreadIdEnv tid es wkTid i mvEntries cleanUp - let newEntries = ThreadEntries - { teCapacity = teCapacity te - 1 - , teEntries = addThreadData wkTid i wkTidEs $ teEntries te - } - newEntries `seq` pure (newEntries, es) - unEff m es - ----------------------------------------- --- Data types + mvEntries <- S.newMVar $ ThreadEntries threads M.empty + let getEs = myThreadId >>= \case + tid | tid0 == tid -> pure es0 + tid -> do + te0 <- S.readMVar mvEntries + let wkTid = weakThreadId tid + case wkTid `M.lookup` te0.entries of + Just wkEs -> getWkTidEnv wkEs + -- If the environment is not in the map, there is no point checking + -- again within modifyMVar below, because this is the only thread + -- that can put it there. + Nothing -> S.modifyMVar mvEntries $ \te -> case te.capacity of + 0 -> noCapacityError threads + 1 -> do + wkTidEs <- mkWeakThreadIdEnv tid wkTid esTemplate mvEntries cleanUp + let newEntries = ThreadEntries + { capacity = te.capacity - 1 + , entries = M.insert wkTid wkTidEs te.entries + } + pure (newEntries, esTemplate) + _ -> do + es <- cloneEnv esTemplate + wkTidEs <- mkWeakThreadIdEnv tid wkTid es mvEntries cleanUp + let newEntries = ThreadEntries + { capacity = te.capacity - 1 + , entries = M.insert wkTid wkTidEs te.entries + } + pure (newEntries, es) + k $ \action -> coerce action =<< getEs +{-# INLINE persistentConcUnlift #-} -newtype EntryId = EntryId Int - deriving Eq +-- | Variant of 'persistentConcUnlift' for a single other thread that doesn't +-- need ThreadEntries. +-- +-- @since 2.7.0.0 +persistentConcSingleUnlift + :: ( HasCallStack, forall r. Coercible (effEs r) (Env es -> IO r)) + => Env es + -> ((forall r. effEs r -> IO r) -> IO a) + -> IO a +persistentConcSingleUnlift es0 k = do + tid0 <- myThreadId + -- Create a copy of the environment for the other thread to use. This can't be + -- done from inside the callback as the environment might have already changed + -- by then. + es <- cloneEnv es0 + -- GHC never labels threads as 0. + mvWeakTid <- S.newMVar 0 + let getEs = myThreadId >>= \case + tid | tid0 == tid -> pure es0 + tid -> do + let wkTid = weakThreadId tid + S.readMVar mvWeakTid >>= \case + 0 -> S.modifyMVar mvWeakTid $ \case + 0 -> pure (wkTid, es) + _ -> noCapacityError 1 + v | v == wkTid -> pure es + | otherwise -> noCapacityError 1 + k $ \action -> coerce action =<< getEs +{-# INLINE persistentConcSingleUnlift #-} -newEntryId :: EntryId -newEntryId = EntryId 0 +-- | Variant of 'persistentConcUnlift' producing two unlifting functions that +-- share the effect storage in each thread. +-- +-- @since 2.7.0.0 +persistentConcUnlifts + :: ( HasCallStack + , forall r. Coercible (effEs r) (Env es -> IO r) + , forall r. Coercible (effLocalEs r) (Env localEs -> IO r) + ) + => Env es + -> Env localEs + -> Bool + -> Int + -- ^ Number of threads that are allowed to use the unlift function. + -> ((forall r. effEs r -> IO r) -> (forall r. effLocalEs r -> IO r) -> IO a) + -> IO a +persistentConcUnlifts es0 les0 cleanUp threads k = do + unless (threads > 0) $ do + error $ "Invalid number of threads: " ++ show threads + tid0 <- myThreadId + -- Create a copy of the environments sharing the effect storage as a template + -- for the other threads to use. This can't be done from inside the callback + -- as the environment might have already changed by then. + storageTemplate <- cloneStorage es0.storage + esTemplate <- replaceStorage es0 storageTemplate + lesTemplate <- replaceStorage les0 storageTemplate + mvEntries <- S.newMVar $ ThreadEntries threads M.empty + let getEsLes = myThreadId >>= \case + tid | tid0 == tid -> pure (es0, les0) + tid -> do + te0 <- S.readMVar mvEntries + let wkTid = weakThreadId tid + case wkTid `M.lookup` te0.entries of + Just wkEsLes -> getWkTidEnv wkEsLes + -- If the environments are not in the map, there is no point + -- checking again within modifyMVar below, because this is the only + -- thread that can put them there. + Nothing -> S.modifyMVar mvEntries $ \te -> case te.capacity of + 0 -> noCapacityError threads + 1 -> do + wkTidEsLes <- mkWeakThreadIdEnv tid wkTid (esTemplate, lesTemplate) mvEntries cleanUp + let newEntries = ThreadEntries + { capacity = te.capacity - 1 + , entries = M.insert wkTid wkTidEsLes te.entries + } + pure (newEntries, (esTemplate, lesTemplate)) + _ -> do + storage <- cloneStorage storageTemplate + es <- replaceStorage esTemplate storage + les <- replaceStorage lesTemplate storage + wkTidEsLes <- mkWeakThreadIdEnv tid wkTid (es, les) mvEntries cleanUp + let newEntries = ThreadEntries + { capacity = te.capacity - 1 + , entries = M.insert wkTid wkTidEsLes te.entries + } + pure (newEntries, (es, les)) + k (\action -> coerce action . fst =<< getEsLes) + (\action -> coerce action . snd =<< getEsLes) +{-# INLINE persistentConcUnlifts #-} -nextEntryId :: EntryId -> EntryId -nextEntryId (EntryId i) = EntryId (i + 1) +-- | Variant of 'persistentConcUnlifts' for a single other thread that doesn't +-- need ThreadEntries. +-- +-- @since 2.7.0.0 +persistentConcSingleUnlifts + :: ( HasCallStack + , forall r. Coercible (effEs r) (Env es -> IO r) + , forall r. Coercible (effLocalEs r) (Env localEs -> IO r) + ) + => Env es + -> Env localEs + -> ((forall r. effEs r -> IO r) -> (forall r. effLocalEs r -> IO r) -> IO a) + -> IO a +persistentConcSingleUnlifts es0 les0 k = do + tid0 <- myThreadId + -- Create a copy of the environments sharing the effect storage for the other + -- thread to use. This can't be done from inside the callback as the + -- environment might have already changed by then. + storage <- cloneStorage es0.storage + es <- replaceStorage es0 storage + les <- replaceStorage les0 storage + -- GHC never labels threads as 0. + mvWeakTid <- S.newMVar 0 + let getEsLes = myThreadId >>= \case + tid | tid0 == tid -> pure (es0, les0) + tid -> do + let wkTid = weakThreadId tid + S.readMVar mvWeakTid >>= \case + 0 -> S.modifyMVar mvWeakTid $ \case + 0 -> pure (wkTid, (es, les)) + _ -> noCapacityError 1 + v | v == wkTid -> pure (es, les) + | otherwise -> noCapacityError 1 + k (\action -> coerce action . fst =<< getEsLes) + (\action -> coerce action . snd =<< getEsLes) +{-# INLINE persistentConcSingleUnlifts #-} -data ThreadEntries es = ThreadEntries - { teCapacity :: !Int - , teEntries :: !(IM.IntMap (ThreadEntry es)) - } +---------------------------------------- +-- Internal helpers --- | In GHC < 9 weak thread ids are 32bit long, while ThreadIdS are 64bit long, --- so there is potential for collisions. This is solved by keeping, for a --- particular weak thread id, a list of ThreadIdS with unique EntryIdS. -data ThreadEntry es = ThreadEntry !EntryId !(ThreadData es) +noCapacityError :: HasCallStack => Int -> a +noCapacityError threads = error + $ "Number of other threads (" ++ show threads ++ ") permitted to " + ++ "use the unlifting function was exceeded. Please increase the " + ++ "limit or use the unlimited variant." -data ThreadData es - = ThreadData !EntryId !(Weak (ThreadId, Env es)) (ThreadData es) - | NoThreadData +getWkTidEnv :: HasCallStack => Weak a -> IO a +getWkTidEnv wkTidEnv = deRefWeak wkTidEnv >>= \case + Nothing -> error "Impossible, thread alive but its weak ref dead" + Just env -> pure env ----------------------------------------- --- Weak references to threads +data ThreadEntries a = ThreadEntries + { capacity :: !Int + , entries :: !(M.Word64Map (Weak a)) + } mkWeakThreadIdEnv :: ThreadId - -> Env es - -> Int - -> EntryId - -> MVar (ThreadEntries es) + -> Word64 + -> a + -> S.MVar (ThreadEntries a) -> Bool - -> IO (Weak (ThreadId, Env es)) -mkWeakThreadIdEnv t@(ThreadId t#) es wkTid i v = \case + -> IO (Weak a) +mkWeakThreadIdEnv (ThreadId t#) wkTid es v = \case True -> IO $ \s0 -> - case mkWeak# t# (t, es) finalizer s0 of + case mkWeak# t# es finalizer s0 of (# s1, w #) -> (# s1, Weak w #) False -> IO $ \s0 -> - case mkWeakNoFinalizer# t# (t, es) s0 of + case mkWeakNoFinalizer# t# es s0 of (# s1, w #) -> (# s1, Weak w #) where - IO finalizer = deleteThreadData wkTid i v - ----------------------------------------- --- Manipulation of ThreadEntries - -lookupEnv :: ThreadId -> ThreadData es -> IO (Maybe (Env es)) -lookupEnv tid0 = \case - NoThreadData -> pure Nothing - ThreadData _ wkTidEs td -> deRefWeak wkTidEs >>= \case - Nothing -> lookupEnv tid0 td - Just (tid, es) - | tid0 `eqThreadId` tid -> pure $ Just es - | otherwise -> lookupEnv tid0 td - ----------------------------------------- - -addThreadData - :: Int - -> EntryId - -> Weak (ThreadId, Env es) - -> IM.IntMap (ThreadEntry es) - -> IM.IntMap (ThreadEntry es) -addThreadData wkTid i w teMap - | i == newEntryId = IM.insert wkTid (newThreadEntry i w) teMap - | otherwise = IM.adjust (consThreadData w) wkTid teMap - -newThreadEntry :: EntryId -> Weak (ThreadId, Env es) -> ThreadEntry es -newThreadEntry i w = ThreadEntry (nextEntryId i) $ ThreadData i w NoThreadData - -consThreadData :: Weak (ThreadId, Env es) -> ThreadEntry es -> ThreadEntry es -consThreadData w (ThreadEntry i td) = - ThreadEntry (nextEntryId i) $ ThreadData i w td - ----------------------------------------- - -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 - -cleanThreadEntry :: EntryId -> ThreadEntry es -> Maybe (ThreadEntry es) -cleanThreadEntry i0 (ThreadEntry i td0) = case cleanThreadData i0 td0 of - NoThreadData -> Nothing - td -> Just (ThreadEntry i td) - -cleanThreadData :: EntryId -> ThreadData es -> ThreadData es -cleanThreadData i0 = \case - NoThreadData -> NoThreadData - ThreadData i w td - | i0 == i -> td - | otherwise -> ThreadData i w (cleanThreadData i0 td) + -- The finalizer runs only if the corresponding entry is in the map. It + -- might not be there for two reasons: + -- + -- 1. Registration of the thread was interrupted by an asynchronous + -- exception after the finalizer was attached, but before the update of + -- the map was committed. The commit was rolled back, so there is + -- nothing to clean up (and if the thread registered successfully + -- afterwards, the entry belongs to the finalizer attached then). + -- + -- 2. The thread registered successfully after one or more interrupted + -- attempts, so multiple finalizers run on its death and another one + -- already cleaned up the entry. + IO finalizer = S.modifyMVar_ v $ \te -> do + pure $ case M.updateLookupWithKey (\_ _ -> Nothing) wkTid te.entries of + (Nothing, _) -> te + (Just _, newEntries) -> ThreadEntries + { capacity = case te.capacity of + -- If the template copy of the environment hasn't been consumed + -- yet, the capacity can be restored. + 0 -> 0 + n -> n + 1 + , entries = newEntries + } diff --git a/src/Effectful/Internal/Utils.hs b/src/Effectful/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Internal/Utils.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# OPTIONS_HADDOCK not-home #-} +module Effectful.Internal.Utils + ( inlineBracket + + -- * Utils for 'ThreadId' + , weakThreadId + + -- * Utils for 'Any' + , Any + , toAny + , fromAny + + -- * Unique + , Unique + , newUnique + + -- * CallStack + , thawCallStack + + -- * Array capacity + , growCapacity + ) where + +import Control.Exception +import Data.Primitive.ByteArray +import Data.Word +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#) +#endif + +-- Pretend to depend on containers to silence -Wunused-packages as containers +-- dependency is needed for doctests. +import Data.IntMap.Strict () + +-- | 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 -> Word64 +#if MIN_VERSION_base(4,19,0) +weakThreadId = fromThreadId +#else +weakThreadId (ThreadId t#) = rts_getThreadId (threadIdToAddr# t#) + +foreign import ccall unsafe "rts_getThreadId" + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6163 + rts_getThreadId :: Addr# -> Word64 + +-- 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 + +---------------------------------------- + +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 + +---------------------------------------- + +-- | Remove exactly one layer of freezing, i.e. the one added by 'send' and +-- friends via 'withFrozenCallStack'. Freezes applied by client code need to +-- stay intact, so this must not recurse. +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 diff --git a/src/Effectful/Internal/Utils/Word64Map.hs b/src/Effectful/Internal/Utils/Word64Map.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Internal/Utils/Word64Map.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE Strict #-} +-- | A minimal, strict map keyed by 'Word64' values (adaptation of +-- 'Data.IntMap.Strict'). +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Effectful.Internal.Utils.Word64Map + ( Word64Map + , empty + , lookup + , insert + , delete + , updateLookupWithKey + ) where + +import Data.Bits +import Data.Word +import Prelude hiding (lookup) + +-- | A map of 'Word64' keys to values of type @a@. +data Word64Map a + = Bin Prefix (Word64Map a) (Word64Map a) + | Tip Word64 a + | Nil + +-- | A @Prefix@ represents some prefix of high-order bits of a @Word64@. +newtype Prefix = Prefix Word64 + +unPrefix :: Prefix -> Word64 +unPrefix (Prefix p) = p + +---------------------------------------- + +-- | The empty map. +empty :: Word64Map a +empty = Nil + +-- | Look up the value at a key in the map. +lookup :: Word64 -> Word64Map a -> Maybe a +lookup k = go + where + go (Bin p l r) | left k p = go l + | otherwise = go r + go (Tip kx x) | k == kx = Just x + | otherwise = Nothing + go Nil = Nothing + +-- | Insert a new key/value pair in the map. If the key is already present, the +-- associated value is replaced with the supplied one. +-- +-- The value is evaluated to WHNF when it is inserted into the map. +insert :: Word64 -> a -> Word64Map a -> Word64Map a +insert k x = go + where + go t@(Bin p l r) + | nomatch k p = linkKey k (Tip k x) p t + | left k p = Bin p (go l) r + | otherwise = Bin p l (go r) + go t@(Tip ky _) + | k == ky = Tip k x + | otherwise = link k (Tip k x) ky t + go Nil = Tip k x + +-- | Delete a key and its value from the map. When the key is not a member of +-- the map, the original map is returned. +delete :: Word64 -> Word64Map a -> Word64Map a +delete k = go + where + go t@(Bin p l r) + | nomatch k p = t + | left k p = binCheckLeft p (go l) r + | otherwise = binCheckRight p l (go r) + go t@(Tip ky _) + | k == ky = Nil + | otherwise = t + go Nil = Nil + +-- | Look up and update the value at a key in the map. The function returns the +-- original value, if it exists, and the updated map. +-- +-- The updated value is evaluated to WHNF when it is inserted into the map. +updateLookupWithKey + :: (Word64 -> a -> Maybe a) + -> Word64 + -> Word64Map a + -> (Maybe a, Word64Map a) +updateLookupWithKey f k = go + where + go t@(Bin p l r) + | nomatch k p = (Nothing, t) + | left k p = let (found, l') = go l in (found, binCheckLeft p l' r) + | otherwise = let (found, r') = go r in (found, binCheckRight p l r') + go t@(Tip ky y) + | k == ky = case f ky y of + Just y' -> (Just y, Tip ky y') + Nothing -> (Just y, Nil) + | otherwise = (Nothing, t) + go Nil = (Nothing, Nil) + +---------------------------------------- +-- Internal helpers + +-- | Whether the @Word64@ does not start with the given @Prefix@. +-- +-- A @Word64@ starts with a @Prefix@ if it shares the high bits with the +-- internal @Word64@ value of the @Prefix@ up to the mask bit. +-- +-- @nomatch@ is usually used to determine whether a key belongs in a @Bin@, +-- since all keys in a @Bin@ share a @Prefix@. +nomatch :: Word64 -> Prefix -> Bool +nomatch i (Prefix p) = (i `xor` p) .&. prefixMask /= 0 + where + prefixMask = p `xor` (-p) + +-- | Whether the @Word64@ is to the left of the split created by a @Bin@ with +-- this @Prefix@. +-- +-- This does not imply that the @Word64@ belongs in this @Bin@. That fact is +-- usually determined first using @nomatch@. +left :: Word64 -> Prefix -> Bool +left i p = i < unPrefix p + +-- | Link two @Word64Map@s. The maps must not be empty. The @Prefix@es of the +-- two maps must be different. @k1@ must share the prefix of @t1@. @p2@ must be +-- the prefix of @t2@. +linkKey :: Word64 -> Word64Map a -> Prefix -> Word64Map a -> Word64Map a +linkKey k1 t1 p2 t2 = link k1 t1 (unPrefix p2) t2 + +-- | Link two @Word64Map@s. The maps must not be empty. The @Prefix@es of the +-- two maps must be different. @k1@ must share the prefix of @t1@ and @k2@ must +-- share the prefix of @t2@. +link :: Word64 -> Word64Map a -> Word64 -> Word64Map a -> Word64Map a +link k1 t1 k2 t2 = linkWithMask (branchMask k1 k2) k1 t1 k2 t2 + +-- `linkWithMask` is useful when the `branchMask` has already been computed +linkWithMask :: Word64 -> Word64 -> Word64Map a -> Word64 -> Word64Map a -> Word64Map a +linkWithMask m k1 t1 k2 t2 + | k1 < k2 = Bin p t1 t2 + | otherwise = Bin p t2 t1 + where + p = Prefix (mask k1 m .|. m) + +-- | The prefix of key @i@ up to (but not including) the switching bit @m@. +mask :: Word64 -> Word64 -> Word64 +mask i m = i .&. (m `xor` (-m)) + +-- | The first switching bit where the two prefixes disagree. +-- +-- Precondition for defined behavior: p1 /= p2. +branchMask :: Word64 -> Word64 -> Word64 +branchMask k1 k2 = + unsafeShiftL 1 (finiteBitSize (0 :: Word64) - 1 - countLeadingZeros (k1 `xor` k2)) + +-- | Smart constructor that collapses an empty left subtree. +binCheckLeft :: Prefix -> Word64Map a -> Word64Map a -> Word64Map a +binCheckLeft _ Nil r = r +binCheckLeft p l r = Bin p l r + +-- | Smart constructor that collapses an empty right subtree. +binCheckRight :: Prefix -> Word64Map a -> Word64Map a -> Word64Map a +binCheckRight _ l Nil = l +binCheckRight p l r = Bin p l r diff --git a/src/Effectful/Labeled.hs b/src/Effectful/Labeled.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled.hs @@ -0,0 +1,82 @@ +{-# 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. +-- +-- /Note:/ labeled effects are best used together with the +-- [effectful-plugin](https://hackage.haskell.org/package/effectful-plugin) +-- package, as it significantly improves their usability. +-- +-- 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 diff --git a/src/Effectful/Labeled/Error.hs b/src/Effectful/Labeled/Error.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Error.hs @@ -0,0 +1,192 @@ +{-# 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_ + , rethrowErrorWith + , rethrowError + , rethrowError_ + , catchError + , handleError + , tryError + + -- * Re-exports + , Labeled(..) + , 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 "") + +-- | Throw an error of type @e@ with the given 'E.CallStack' and specify a +-- display function in case a third-party code catches the internal exception +-- and 'show's it. +-- +-- Useful e.g. when you want to catch an error and rethrow it converted to a +-- different type without losing the original 'E.CallStack'. +-- +-- @since 2.7.0.0 +rethrowErrorWith + :: forall label e es a + . Labeled label (Error e) :> es + => (e -> String) + -- ^ The display function. + -> E.CallStack + -- ^ The 'E.CallStack' to attach to the error. + -> e + -- ^ The error. + -> Eff es a +rethrowErrorWith display cs = + send . Labeled @label . RethrowErrorWith display cs + +-- | Throw an error of type @e@ with the given 'E.CallStack' and 'show' as a +-- display function. +-- +-- @since 2.7.0.0 +rethrowError + :: forall label e es a + . (Labeled label (Error e) :> es, Show e) + => E.CallStack + -- ^ The 'E.CallStack' to attach to the error. + -> e + -- ^ The error. + -> Eff es a +rethrowError = rethrowErrorWith @label show + +-- | Throw an error of type @e@ with the given 'E.CallStack' and no display +-- function. +-- +-- @since 2.7.0.0 +rethrowError_ + :: forall label e es a + . Labeled label (Error e) :> es + => E.CallStack + -- ^ The 'E.CallStack' to attach to the error. + -> e + -- ^ The error. + -> Eff es a +rethrowError_ = rethrowErrorWith @label (const "") + +-- | 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)) diff --git a/src/Effectful/Labeled/Input.hs b/src/Effectful/Labeled/Input.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Input.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'Input' effect. +-- +-- @since 2.7.0.0 +module Effectful.Labeled.Input + ( -- * Effect + Input + + -- ** Handlers + , runInput + , runInputAction + + -- ** Operations + , input + , inputs + + -- * Re-exports + , Labeled(..) + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Input.Dynamic (Input(..)) +import Effectful.Input.Dynamic qualified as I + +-- | Run the 'Input' effect with the given value. +runInput + :: forall label i es a + . HasCallStack + => i + -- ^ The input value. + -> Eff (Labeled label (Input i) : es) a + -> Eff es a +runInput = runLabeled @label . I.runInput + +-- | Run the 'Input' effect with the given action that supplies values. +runInputAction + :: forall label i es a + . HasCallStack + => (HasCallStack => Eff es i) + -- ^ The action for input generation. + -> Eff (Labeled label (Input i) : es) a + -> Eff es a +runInputAction = runLabeled @label . I.runInputAction + +---------------------------------------- +-- Operations + +-- | Fetch the value. +input + :: forall label i es + . (HasCallStack, Labeled label (Input i) :> es) + => Eff es i +input = send $ Labeled @label Input + +-- | Fetch the result of applying a function to the value. +-- +-- @'inputs' f ≡ f '<$>' 'input'@ +inputs + :: forall label i es a + . (HasCallStack, Labeled label (Input i) :> es) + => (i -> a) -- ^ The function to apply to the value. + -> Eff es a +inputs f = f <$> input @label diff --git a/src/Effectful/Labeled/Output.hs b/src/Effectful/Labeled/Output.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Output.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'Output' effect. +-- +-- @since 2.7.0.0 +module Effectful.Labeled.Output + ( -- * Effect + Output(..) + + -- ** Handlers + , runOutputAction + , runOutputLocalArray + , runOutputLocalList + , runOutputSharedArray + , runOutputSharedList + + -- ** Operations + , output + + -- * Re-exports + , Labeled(..) + , Array + ) where + +import Data.Primitive.Array + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Output.Dynamic (Output(..)) +import Effectful.Output.Dynamic qualified as O + +---------------------------------------- +-- Handlers + +-- | Run the 'Output' effect with the given action for receiving values. +runOutputAction + :: forall label o es a + . HasCallStack + => (HasCallStack => o -> Eff es ()) + -- ^ The action for output generation. + -> Eff (Labeled label (Output o) : es) a + -> Eff es a +runOutputAction = runLabeled @label . O.runOutputAction + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated array (via "Effectful.Output.Static.Local.Array"). +runOutputLocalArray + :: forall label o es a + . HasCallStack + => Eff (Labeled label (Output o) : es) a + -> Eff es (a, Array o) +runOutputLocalArray = runLabeled @label O.runOutputLocalArray + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated list (via "Effectful.Output.Static.Local.List"). +runOutputLocalList + :: forall label o es a + . HasCallStack + => Eff (Labeled label (Output o) : es) a + -> Eff es (a, [o]) +runOutputLocalList = runLabeled @label O.runOutputLocalList + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated array (via "Effectful.Output.Static.Shared.Array"). +runOutputSharedArray + :: forall label o es a + . HasCallStack + => Eff (Labeled label (Output o) : es) a + -> Eff es (a, Array o) +runOutputSharedArray = runLabeled @label O.runOutputSharedArray + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated list (via "Effectful.Output.Static.Shared.List"). +runOutputSharedList + :: forall label o es a + . HasCallStack + => Eff (Labeled label (Output o) : es) a + -> Eff es (a, [o]) +runOutputSharedList = runLabeled @label O.runOutputSharedList + +---------------------------------------- +-- Operations + +-- | Feed the value to the underlying handler. +output + :: forall label o es + . (HasCallStack, Labeled label (Output o) :> es) + => o + -> Eff es () +output = send . Labeled @label . Output diff --git a/src/Effectful/Labeled/Provider.hs b/src/Effectful/Labeled/Provider.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Provider.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'Provider' effect. +-- +-- @since 2.7.0.0 +module Effectful.Labeled.Provider + ( -- * Effect + Provider(..) + , Provider_ + + -- ** Handlers + , runProvider + , runProvider_ + + -- ** Operations + , provide + , provide_ + , provideWith + , provideWith_ + + -- * Re-exports + , Labeled(..) + ) where + +import Data.Coerce +import Data.Functor.Identity + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Provider (Provider(..), Provider_) +import Effectful.Provider qualified as P + +-- | Run the labeled 'Provider' effect with a given effect handler. +runProvider + :: forall label e input f es a + . HasCallStack + => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r)) + -- ^ The effect handler. + -> Eff (Labeled label (Provider e input f) : es) a + -> Eff es a +runProvider provider = runLabeled @label (P.runProvider provider) + +-- | Run the labeled 'Provider' effect with a given effect handler that doesn't +-- change its return type. +runProvider_ + :: forall label e input es a + . HasCallStack + => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r) + -- ^ The effect handler. + -> Eff (Labeled label (Provider_ e input) : es) a + -> Eff es a +runProvider_ provider = runLabeled @label (P.runProvider_ provider) + +---------------------------------------- +-- Operations + +-- | Run the effect handler. +provide + :: forall label e f es a + . (HasCallStack, Labeled label (Provider e () f) :> es) + => Eff (e : es) a + -> Eff es (f a) +provide = send . Labeled @label . P.ProvideWith () + +-- | Run the effect handler with unchanged return type. +provide_ + :: forall label e es a + . (HasCallStack, Labeled label (Provider_ e ()) :> es) + => Eff (e : es) a + -> Eff es a +provide_ = dropIdentity . send . Labeled @label . P.ProvideWith () + +-- | Run the effect handler with a given input. +provideWith + :: forall label e input f es a + . (HasCallStack, Labeled label (Provider e input f) :> es) + => input + -- ^ The input to the effect handler. + -> Eff (e : es) a + -> Eff es (f a) +provideWith input = send . Labeled @label . P.ProvideWith input + +-- | Run the effect handler that doesn't change its return type with a given +-- input. +provideWith_ + :: forall label e input es a + . (HasCallStack, Labeled label (Provider_ e input) :> es) + => input + -- ^ The input to the effect handler. + -> Eff (e : es) a + -> Eff es a +provideWith_ input = dropIdentity . send . Labeled @label . P.ProvideWith input + +---------------------------------------- +-- Helpers + +dropIdentity :: Eff es (Identity a) -> Eff es a +dropIdentity = coerce diff --git a/src/Effectful/Labeled/Provider/List.hs b/src/Effectful/Labeled/Provider/List.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Provider/List.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'ProviderList' effect. +-- +-- @since 2.7.0.0 +module Effectful.Labeled.Provider.List + ( -- * Effect + ProviderList(..) + , ProviderList_ + + -- ** Handlers + , runProviderList + , runProviderList_ + + -- ** Operations + , provideList + , provideList_ + , provideListWith + , provideListWith_ + + -- * Re-exports + , Labeled(..) + , type (++) + , KnownSubset + ) where + +import Data.Coerce +import Data.Functor.Identity + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Provider.List (ProviderList(..), ProviderList_, type (++)) +import Effectful.Provider.List qualified as P + +-- | Run the labeled 'ProviderList' effect with a given handler. +runProviderList + :: forall label providedEs input f es a + . (HasCallStack, KnownSubset providedEs (providedEs ++ es)) + => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r)) + -- ^ The handler. + -> Eff (Labeled label (ProviderList providedEs input f) : es) a + -> Eff es a +runProviderList provider = runLabeled @label (P.runProviderList provider) + +-- | Run the labeled 'ProviderList' effect with a given handler that doesn't +-- change its return type. +runProviderList_ + :: forall label providedEs input es a + . (HasCallStack, KnownSubset providedEs (providedEs ++ es)) + => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r) + -- ^ The handler. + -> Eff (Labeled label (ProviderList_ providedEs input) : es) a + -> Eff es a +runProviderList_ provider = runLabeled @label (P.runProviderList_ provider) + +---------------------------------------- +-- Operations + +-- | Run the handler. +provideList + :: forall label providedEs f es a + . (HasCallStack, Labeled label (ProviderList providedEs () f) :> es) + => Eff (providedEs ++ es) a + -> Eff es (f a) +provideList = send . Labeled @label . P.ProvideListWith @providedEs () + +-- | Run the handler with unchanged return type. +provideList_ + :: forall label providedEs es a + . (HasCallStack, Labeled label (ProviderList_ providedEs ()) :> es) + => Eff (providedEs ++ es) a + -> Eff es a +provideList_ = dropIdentity . send . Labeled @label . P.ProvideListWith @providedEs () + +-- | Run the handler with a given input. +provideListWith + :: forall label providedEs input f es a + . (HasCallStack, Labeled label (ProviderList providedEs input f) :> es) + => input + -- ^ The input to the handler. + -> Eff (providedEs ++ es) a + -> Eff es (f a) +provideListWith input = send . Labeled @label . P.ProvideListWith @providedEs input + +-- | Run the handler that doesn't change its return type with a given input. +provideListWith_ + :: forall label providedEs input es a + . (HasCallStack, Labeled label (ProviderList_ providedEs input) :> es) + => input + -- ^ The input to the handler. + -> Eff (providedEs ++ es) a + -> Eff es a +provideListWith_ input = + dropIdentity . send . Labeled @label . P.ProvideListWith @providedEs input + +---------------------------------------- +-- Helpers + +dropIdentity :: Eff es (Identity a) -> Eff es a +dropIdentity = coerce diff --git a/src/Effectful/Labeled/Reader.hs b/src/Effectful/Labeled/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Reader.hs @@ -0,0 +1,70 @@ +{-# 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 + + -- * Re-exports + , Labeled(..) + ) 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 diff --git a/src/Effectful/Labeled/ReturnWith.hs b/src/Effectful/Labeled/ReturnWith.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/ReturnWith.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'ReturnWith' effect. +-- +-- @since 2.7.0.0 +module Effectful.Labeled.ReturnWith + ( -- * Effect + ReturnWith(..) + + -- ** Handlers + , runReturnWith + + -- ** Operations + , returnWith + + -- * Re-exports + , Labeled(..) + ) where + +import GHC.Stack (withFrozenCallStack) + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.ReturnWith.Dynamic (ReturnWith(..)) +import Effectful.ReturnWith.Dynamic qualified as R + +-- | Run a computation that can return early with a value of type @r@ (via +-- "Effectful.ReturnWith.Static"). +runReturnWith + :: forall label r es + . HasCallStack + => Eff (Labeled label (ReturnWith r) : es) r + -> Eff es r +runReturnWith = runLabeled @label R.runReturnWith + +-- | Return early with the given value. +returnWith + :: forall label r es a + . (HasCallStack, Labeled label (ReturnWith r) :> es) + => r + -- ^ The value. + -> Eff es a +returnWith = withFrozenCallStack send . Labeled @label . ReturnWith diff --git a/src/Effectful/Labeled/State.hs b/src/Effectful/Labeled/State.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/State.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- The deprecated stateM needs to use the deprecated StateM operation until +-- they're removed. +{-# OPTIONS_GHC -Wno-deprecations #-} +-- | 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 + + -- * Re-exports + , Labeled(..) + ) 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) + +{-# DEPRECATED stateM, modifyM + "Use a combination of get and put instead." #-} diff --git a/src/Effectful/Labeled/Writer.hs b/src/Effectful/Labeled/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Writer.hs @@ -0,0 +1,109 @@ +{-# 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 + + -- * Re-exports + , Labeled(..) + ) 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) diff --git a/src/Effectful/NonDet.hs b/src/Effectful/NonDet.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/NonDet.hs @@ -0,0 +1,153 @@ +-- | Provider of the t'Control.Applicative.Alternative' and +-- t'Control.Monad.MonadPlus' instance for 'Eff'. +-- +-- /Note:/ the 'NonDet' effect uses the t'Effectful.Error.Static.Error' effect +-- underneath, so caveats described in "Effectful.Error.Static" (in particular +-- the interaction with threads) apply. +module Effectful.NonDet + ( -- * Effect + NonDet(..) + , OnEmptyPolicy(..) + + -- ** Handlers + , runNonDet + + -- * Operations + , emptyEff + , plusEff + , sumEff + + -- * Re-exports + , Alternative(..) + , HasCallStack + , CallStack + , getCallStack + , prettyCallStack + ) where + +import Control.Applicative +import GHC.Generics +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Dispatch.Static +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'. + -- + -- The rollback applies to the thread local state of __all__ effects, in + -- particular ones handled outside of 'runNonDet': + -- + -- >>> import Effectful.State.Static.Local + -- >>> :{ + -- runPureEff . runState @Int 0 . runNonDet OnEmptyRollback $ + -- (modify @Int (+1) >> emptyEff) <|> get @Int + -- :} + -- (Right 0,0) + -- + -- /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 I.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 I.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 diff --git a/src/Effectful/Output/Dynamic.hs b/src/Effectful/Output/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Output/Dynamic.hs @@ -0,0 +1,86 @@ +-- | The dynamically dispatched variant of the 'Output' effect. +-- +-- /Note:/ unless you plan to change interpretations at runtime, it's +-- recommended to use one of the statically dispatched variants, +-- i.e. "Effectful.Output.Static.Action", "Effectful.Output.Static.Local.Array", +-- "Effectful.Output.Static.Local.List", "Effectful.Output.Static.Shared.Array" +-- or "Effectful.Output.Static.Shared.List". +-- +-- @since 2.7.0.0 +module Effectful.Output.Dynamic + ( -- * Effect + Output(..) + + -- ** Handlers + , runOutputAction + , runOutputLocalArray + , runOutputLocalList + , runOutputSharedArray + , runOutputSharedList + + -- ** Operations + , output + ) where + +import Data.Primitive.Array + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Output.Static.Local.Array qualified as LA +import Effectful.Output.Static.Local.List qualified as LL +import Effectful.Output.Static.Shared.Array qualified as SA +import Effectful.Output.Static.Shared.List qualified as SL + +-- | Provide the ability to feed values of type @o@ to a handler. +data Output o :: Effect where + Output :: o -> Output o m () + +type instance DispatchOf (Output o) = Dynamic + +---------------------------------------- +-- Handlers + +-- | Run the 'Output' effect with the given action for receiving values. +runOutputAction + :: forall o es a + . HasCallStack + => (HasCallStack => o -> Eff es ()) + -- ^ The action for output generation. + -> Eff (Output o : es) a + -> Eff es a +runOutputAction outputAction = interpret_ $ \case + Output o -> outputAction $! o + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated array (via "Effectful.Output.Static.Local.Array"). +runOutputLocalArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o) +runOutputLocalArray = reinterpret_ LA.runOutput $ \case + Output o -> LA.output o + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated list (via "Effectful.Output.Static.Local.List"). +runOutputLocalList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o]) +runOutputLocalList = reinterpret_ LL.runOutput $ \case + Output o -> LL.output o + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated array (via "Effectful.Output.Static.Shared.Array"). +runOutputSharedArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o) +runOutputSharedArray = reinterpret_ SA.runOutput $ \case + Output o -> SA.output o + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated list (via "Effectful.Output.Static.Shared.List"). +runOutputSharedList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o]) +runOutputSharedList = reinterpret_ SL.runOutput $ \case + Output o -> SL.output o + +---------------------------------------- +-- Operations + +-- | Feed the value to the underlying handler. +output + :: (HasCallStack, Output o :> es) + => o -- ^ The value. + -> Eff es () +output = send . Output diff --git a/src/Effectful/Output/Static/Action.hs b/src/Effectful/Output/Static/Action.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Output/Static/Action.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ImplicitParams #-} +-- | Support for feeding values of a particular type to a monadic action. +-- +-- @since 2.7.0.0 +module Effectful.Output.Static.Action + ( -- * Effect + Output + + -- ** Handlers + , runOutput + + -- ** Operations + , output + ) where + +import Data.Kind +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Internal.Utils + +-- | Provide the ability to feed values of type @o@ to a monadic action. +data Output (o :: Type) :: Effect + +type instance DispatchOf (Output o) = Static NoSideEffects + +-- | Wrapper to prevent a space leak on reconstruction of 'Output' in +-- 'relinkOutput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520). +newtype OutputImpl o es where + OutputImpl :: (HasCallStack => o -> Eff es ()) -> OutputImpl o es + +data instance StaticRep (Output o) where + Output + :: !(Env actionEs) + -> !(OutputImpl o actionEs) + -> StaticRep (Output o) + +-- | Run the 'Output' effect with the given action for receiving values. +runOutput + :: forall o es a + . HasCallStack + => (HasCallStack => o -> Eff es ()) + -- ^ The action for receiving values. + -> Eff (Output o : es) a + -> Eff es a +runOutput outputAction action = unsafeEff $ \es -> do + inlineBracket + (consEnv (Output es outputImpl) relinkOutput es) + unconsEnv + (unEff action) + where + outputImpl = OutputImpl $ let ?callStack = thawCallStack ?callStack in outputAction + +-- | Feed the value to the underlying monadic action. +output + :: (HasCallStack, Output o :> es) + => o -- ^ The value. + -> Eff es () +output !o = unsafeEff $ \es -> do + Output actionEs (OutputImpl outputAction) <- getEnv es + -- Corresponds to thawCallStack in runOutput. + (`unEff` actionEs) $ withFrozenCallStack outputAction o + +---------------------------------------- +-- Helpers + +relinkOutput :: Relinker StaticRep (Output o) +relinkOutput = Relinker $ \relink (Output actionEs outputAction) -> do + newActionEs <- relink actionEs + pure $ Output newActionEs outputAction diff --git a/src/Effectful/Output/Static/Local/Array.hs b/src/Effectful/Output/Static/Local/Array.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Output/Static/Local/Array.hs @@ -0,0 +1,79 @@ +-- | Support for accumulation of values in a thread local array. +-- +-- @since 2.7.0.0 +module Effectful.Output.Static.Local.Array + ( -- * Effect + Output + + -- ** Handlers + , runOutput + + -- ** Operations + , output + + -- * Re-exports + , Array + ) where + +import Control.Monad.Primitive +import Data.Kind +import Data.Primitive.Array + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Internal.Utils + +-- | Provide access to accumulation of values of type @o@ in a thread local +-- array. +data Output (o :: Type) :: Effect + +type instance DispatchOf (Output o) = Static NoSideEffects +data instance StaticRep (Output o) = Output !Int !(MutableArray RealWorld o) + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated array. +runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o) +runOutput = runOutputImpl $ \(Output size arr) -> do + freezeArray arr 0 size + +-- | Append the value to the end of the array. +output + :: (HasCallStack, Output o :> es) + => o -- ^ The value. + -> Eff es () +output !o = unsafeEff $ \es -> do + Output size arr0 <- getEnv es + let len0 = sizeofMutableArray arr0 + arr <- case size `compare` len0 of + GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")" + LT -> pure arr0 + EQ -> do + let len = growCapacity len0 + arr <- newArray len undefinedValue + copyMutableArray arr 0 arr0 0 size + pure arr + writeArray arr size o + putEnv es $ Output (size + 1) arr + +---------------------------------------- +-- Helpers + +runOutputImpl + :: HasCallStack + => (StaticRep (Output o) -> IO acc) + -> Eff (Output o : es) a + -> Eff es (a, acc) +runOutputImpl f action = unsafeEff $ \es0 -> do + arr <- newArray 0 undefinedValue + inlineBracket + (consEnv (Output 0 arr) relinkOutput es0) + unconsEnv + (\es -> (,) <$> unEff action es <*> (f =<< getEnv es)) + where + relinkOutput = Relinker $ \_ (Output size arr0) -> do + arr <- cloneMutableArray arr0 0 (sizeofMutableArray arr0) + pure $ Output size arr + +undefinedValue :: HasCallStack => a +undefinedValue = error "Undefined value" diff --git a/src/Effectful/Output/Static/Local/List.hs b/src/Effectful/Output/Static/Local/List.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Output/Static/Local/List.hs @@ -0,0 +1,39 @@ +-- | Support for accumulation of values in a thread local list. +-- +-- @since 2.7.0.0 +module Effectful.Output.Static.Local.List + ( -- * Effect + Output + + -- ** Handlers + , runOutput + + -- ** Operations + , output + ) where + +import Data.Kind + +import Effectful +import Effectful.Dispatch.Static + +-- | Provide access to accumulation of values of type @o@ in a thread local +-- list. +data Output (o :: Type) :: Effect + +type instance DispatchOf (Output o) = Static NoSideEffects +newtype instance StaticRep (Output o) = Output [o] + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated list. +runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o]) +runOutput action = do + (a, Output acc) <- runStaticRep (Output []) action + pure (a, reverse acc) + +-- | Append the value to the end of the list. +output + :: (HasCallStack, Output o :> es) + => o -- ^ The value. + -> Eff es () +output !o = stateStaticRep $ \(Output acc) -> ((), Output (o : acc)) diff --git a/src/Effectful/Output/Static/Shared/Array.hs b/src/Effectful/Output/Static/Shared/Array.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Output/Static/Shared/Array.hs @@ -0,0 +1,77 @@ +-- | Support for accumulation of values in a shared array. +-- +-- @since 2.7.0.0 +module Effectful.Output.Static.Shared.Array + ( -- * Effect + Output + + -- ** Handlers + , runOutput + + -- ** Operations + , output + + -- * Re-exports + , Array + ) where + +import Control.Concurrent.MVar.Strict qualified as S +import Control.Monad.Primitive +import Data.Kind +import Data.Primitive.Array + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Internal.Utils + +-- | Provide access to accumulation of values of type @o@ in a shared array. +data Output (o :: Type) :: Effect + +data OutputData o = OutputData !Int !(MutableArray RealWorld o) + +type instance DispatchOf (Output o) = Static NoSideEffects +newtype instance StaticRep (Output o) = Output (S.MVar (OutputData o)) + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated array. +runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o) +runOutput = runOutputImpl $ \(OutputData size arr) -> do + freezeArray arr 0 size + +-- | Append the value to the end of the array. +output + :: (HasCallStack, Output o :> es) + => o -- ^ The value. + -> Eff es () +output !o = unsafeEff $ \es -> do + Output v <- getEnv es + S.modifyMVar_ v $ \(OutputData size arr0) -> do + let len0 = sizeofMutableArray arr0 + arr <- case size `compare` len0 of + GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")" + LT -> pure arr0 + EQ -> do + let len = growCapacity len0 + arr <- newArray len undefinedValue + copyMutableArray arr 0 arr0 0 size + pure arr + writeArray arr size o + pure $ OutputData (size + 1) arr + +---------------------------------------- +-- Helpers + +runOutputImpl + :: HasCallStack + => (OutputData o -> IO acc) + -> Eff (Output o : es) a + -> Eff es (a, acc) +runOutputImpl f action = do + v <- unsafeEff_ $ S.newMVar . OutputData 0 =<< newArray 0 undefinedValue + a <- evalStaticRep (Output v) action + acc <- unsafeEff_ $ f =<< S.readMVar v + pure (a, acc) + +undefinedValue :: HasCallStack => a +undefinedValue = error "Undefined value" diff --git a/src/Effectful/Output/Static/Shared/List.hs b/src/Effectful/Output/Static/Shared/List.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Output/Static/Shared/List.hs @@ -0,0 +1,43 @@ +-- | Support for accumulation of values in a shared list. +-- +-- @since 2.7.0.0 +module Effectful.Output.Static.Shared.List + ( -- * Effect + Output + + -- ** Handlers + , runOutput + + -- ** Operations + , output + ) where + +import Control.Concurrent.MVar.Strict qualified as S +import Data.Kind + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive + +-- | Provide access to accumulation of values of type @o@ in a shared list. +data Output (o :: Type) :: Effect + +type instance DispatchOf (Output o) = Static NoSideEffects +newtype instance StaticRep (Output o) = Output (S.MVar [o]) + +-- | Run the 'Output' effect and return the final value along with the +-- accumulated list. +runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o]) +runOutput action = do + v <- unsafeEff_ $ S.newMVar [] + a <- evalStaticRep (Output v) action + (a, ) . reverse <$> unsafeEff_ (S.readMVar v) + +-- | Append the value to the end of the list. +output + :: (HasCallStack, Output o :> es) + => o -- ^ The value. + -> Eff es () +output !o = unsafeEff $ \es -> do + Output v <- getEnv es + S.modifyMVar_ v $ \acc -> pure (o : acc) diff --git a/src/Effectful/Prim.hs b/src/Effectful/Prim.hs --- a/src/Effectful/Prim.hs +++ b/src/Effectful/Prim.hs @@ -2,6 +2,7 @@ module Effectful.Prim ( -- * Effect Prim + , PrimStateEff -- ** Handlers , runPrim diff --git a/src/Effectful/Provider.hs b/src/Effectful/Provider.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Provider.hs @@ -0,0 +1,208 @@ +-- | 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 Data.Coerce +import Data.Functor.Identity +import Data.Kind (Type) +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Dynamic + +-- $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"])] +-- +-- Moreover, operations of the 'Provider' effect can be intercepted with +-- 'interpose', e.g. to adjust the input of the effect handler: +-- +-- >>> :{ +-- adjustPaths +-- :: Provider_ Write FilePath :> es +-- => Eff es a +-- -> Eff es a +-- adjustPaths = interpose @(Provider_ Write FilePath) $ \env -> \case +-- ProvideWith fp action -> do +-- passthrough env $ ProvideWith ("logs/" ++ fp) action +-- :} +-- +-- >>> :{ +-- runEff +-- . runProvider_ runWriteIO +-- . adjustPaths +-- $ action +-- :} +-- logs/in.txt: hi +-- logs/in.txt: there +-- logs/out.txt: good +-- logs/out.txt: 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 where + -- | Run the effect handler with a given input. + -- + -- @since 2.7.0.0 + ProvideWith :: input -> Eff (e : es) a -> Provider e input f (Eff es) (f a) + +-- | 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) = Dynamic + +-- | Run the 'Provider' effect with a given effect handler. +runProvider + :: forall e input f es a + . 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 = interpret $ \env -> \case + ProvideWith input action -> provider input $ do + localSeqUnlift env $ \unlift -> do + localSeqLend @'[e] env $ \lend -> do + unlift . lend $ action + +-- | Run the 'Provider' effect with a given effect handler that doesn't change +-- its return type. +runProvider_ + :: forall e input es a + . 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 = interpret $ \env -> \case + ProvideWith input action -> provider input $ do + localSeqUnlift env $ \unlift -> do + localSeqLend @'[e] env $ \lend -> do + unlift . lend $ coerce action + +-- | Run the effect handler. +provide :: (HasCallStack, Provider e () f :> es) => Eff (e : es) a -> Eff es (f a) +provide = send . ProvideWith () + +-- | Run the effect handler with unchanged return type. +provide_ :: (HasCallStack, Provider_ e () :> es) => Eff (e : es) a -> Eff es a +provide_ = dropIdentity . send . 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 = send . ProvideWith input + +-- | 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 = dropIdentity . send . ProvideWith input + +---------------------------------------- +-- Helpers + +dropIdentity :: Eff es (Identity a) -> Eff es a +dropIdentity = coerce diff --git a/src/Effectful/Provider/List.hs b/src/Effectful/Provider/List.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Provider/List.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | 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 (++) + , KnownSubset + ) where + +import Data.Coerce +import Data.Functor.Identity +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Internal.Effect + +-- | 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 where + -- | Run the effect handlers with a given input. + -- + -- @since 2.7.0.0 + ProvideListWith + :: forall providedEs input f es a + . input + -> Eff (providedEs ++ es) a + -> ProviderList providedEs input f (Eff es) (f a) + +-- | 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) = Dynamic + +-- | Run the 'ProviderList' effect with a given handler. +runProviderList + :: forall providedEs input f es a + . (HasCallStack, KnownSubset providedEs (providedEs ++ es)) + => (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 provider = interpret $ \env -> \case + ProvideListWith input action -> provider input $ do + localSeqUnlift env $ \unlift -> do + localSeqLend @providedEs env $ \lend -> do + unlift . lend $ action + +-- | Run the 'ProviderList' effect with a given handler that doesn't change its +-- return type. +runProviderList_ + :: forall providedEs input es a + . (HasCallStack, KnownSubset providedEs (providedEs ++ es)) + => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r) + -- ^ The handler. + -> Eff (ProviderList_ providedEs input : es) a + -> Eff es a +runProviderList_ provider = interpret $ \env -> \case + ProvideListWith input action -> provider input $ do + localSeqUnlift env $ \unlift -> do + localSeqLend @providedEs env $ \lend -> do + unlift . lend $ coerce action + +-- | Run the handler. +provideList + :: forall providedEs f es a + . (HasCallStack, ProviderList providedEs () f :> es) + => Eff (providedEs ++ es) a + -> Eff es (f a) +provideList = send . 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_ = dropIdentity . send . 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 = send . ProvideListWith @providedEs input + +-- | 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 = dropIdentity . send . ProvideListWith @providedEs input + +---------------------------------------- +-- Helpers + +dropIdentity :: Eff es (Identity a) -> Eff es a +dropIdentity = coerce diff --git a/src/Effectful/Reader/Dynamic.hs b/src/Effectful/Reader/Dynamic.hs --- a/src/Effectful/Reader/Dynamic.hs +++ b/src/Effectful/Reader/Dynamic.hs @@ -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.Effect.Dynamic (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 diff --git a/src/Effectful/Reader/Static.hs b/src/Effectful/Reader/Static.hs --- a/src/Effectful/Reader/Static.hs +++ b/src/Effectful/Reader/Static.hs @@ -1,4 +1,8 @@ -- | Support for access to a read only value of a particular type. +-- +-- /Note:/ strictly speaking the value is not read only because of 'local'. If +-- you want to ensure that the initial value never changes, use +-- "Effectful.Input.Static". module Effectful.Reader.Static ( -- * Effect Reader @@ -13,19 +17,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 +41,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 +52,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 +61,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 +71,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 diff --git a/src/Effectful/ReturnWith/Dynamic.hs b/src/Effectful/ReturnWith/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/ReturnWith/Dynamic.hs @@ -0,0 +1,49 @@ +-- | The dynamically dispatched variant of the 'ReturnWith' effect. +-- +-- /Note:/ unless you plan to change interpretations at runtime, it's +-- recommended to use the statically dispatched variant, +-- i.e. "Effectful.ReturnWith.Static". +-- +-- All caveats described in "Effectful.ReturnWith.Static" (in particular the +-- interaction with threads) apply. +-- +-- @since 2.7.0.0 +module Effectful.ReturnWith.Dynamic + ( -- * Effect + ReturnWith(..) + + -- ** Handlers + , runReturnWith + + -- ** Operations + , returnWith + ) where + +import GHC.Stack (withFrozenCallStack) + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.ReturnWith.Static qualified as R + +-- | Provide the ability to return early with a value of type @r@. +data ReturnWith r :: Effect where + ReturnWith :: r -> ReturnWith r m a + +type instance DispatchOf (ReturnWith r) = Dynamic + +-- | Run a computation that can return early with a value of type @r@ (via +-- "Effectful.ReturnWith.Static"). +runReturnWith + :: HasCallStack + => Eff (ReturnWith r : es) r + -> Eff es r +runReturnWith = reinterpret_ R.runReturnWith $ \case + ReturnWith r -> R.returnWith r + +-- | Return early with the given value. +returnWith + :: (HasCallStack, ReturnWith r :> es) + => r + -- ^ The value. + -> Eff es a +returnWith = withFrozenCallStack send . ReturnWith diff --git a/src/Effectful/ReturnWith/Static.hs b/src/Effectful/ReturnWith/Static.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/ReturnWith/Static.hs @@ -0,0 +1,112 @@ +-- | Support for early return from a computation. +-- +-- >>> import Control.Monad (when) +-- +-- >>> :{ +-- classify :: ReturnWith String :> es => Int -> Eff es String +-- classify n = do +-- when (n < 0) $ returnWith "negative" +-- when (n == 0) $ returnWith "zero" +-- pure "positive" +-- :} +-- +-- >>> runEff . runReturnWith $ classify 5 +-- "positive" +-- +-- >>> runEff . runReturnWith $ classify (-5) +-- "negative" +-- +-- === Interaction with threads +-- +-- The 'ReturnWith' effect uses runtime exceptions underneath, so the usual +-- rules apply. In particular, in multi-threaded code a call to 'returnWith' in +-- a child thread will not automatically propagate to the parent. If you need +-- that, use functions such as @withAsync@ from the +-- [Effectful.Concurrent.Async](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent-Async.html) +-- module of the @effectful@ package (which propagate exceptions from child +-- threads to their parents) or arrange the propagation yourself. +-- +-- For more information see the documentation of the +-- [Concurrent](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent.html#t:Concurrent) +-- effect. +-- +-- @since 2.7.0.0 +module Effectful.ReturnWith.Static + ( -- * Effect + ReturnWith + + -- ** Handlers + , runReturnWith + + -- ** Operations + , returnWith + ) where + +import Data.Kind +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Exception +import Effectful.Internal.Utils + +-- | Provide the ability to return early with a value of type @r@. +data ReturnWith (r :: Type) :: Effect + +type instance DispatchOf (ReturnWith r) = Static NoSideEffects +newtype instance StaticRep (ReturnWith r) = ReturnWith ReturnWithId + +-- | Run a computation that can return early with a value of type @r@. +runReturnWith + :: forall r es + . HasCallStack + => Eff (ReturnWith r : es) r + -> Eff es r +runReturnWith action = do + rid <- unsafeEff_ newReturnWithId + evalStaticRep (ReturnWith @r rid) $ do + catchJust (matchReturnWith rid) action pure + +-- | Return early with the given value. +returnWith + :: forall r es a. (HasCallStack, ReturnWith r :> es) + => r + -- ^ The value. + -> Eff es a +returnWith r = do + ReturnWith rid <- getStaticRep @(ReturnWith r) + withFrozenCallStack throwIO $ ReturnWithWrapper rid callStack (toAny r) + +---------------------------------------- +-- Helpers + +newtype ReturnWithId = ReturnWithId Unique + deriving newtype Eq + +-- | A unique is picked so that distinct 'ReturnWith' handlers for the same +-- type don't catch each other's values. +newReturnWithId :: IO ReturnWithId +newReturnWithId = ReturnWithId <$> newUnique + +data ReturnWithWrapper = ReturnWithWrapper !ReturnWithId CallStack Any + +instance Show ReturnWithWrapper where + showsPrec p (ReturnWithWrapper _ cs _) + = showParen (p > 10) + $ ("Effectful.ReturnWith.Static.ReturnWithWrapper\n" ++) + . (prettyCallStack cs ++) + . ("\n\nIf you see this message, most likely a call to returnWith " ++) + . ("escaped the scope of its handler, e.g. by being made from a thread " ++) + . ("that outlived it, or was caught by an overly zealous exception " ++) + . ("handler. For more information see the documentation of the " ++) + . ("Effectful.ReturnWith.Static module." ++) + +instance Exception ReturnWithWrapper where + -- See discussion in https://github.com/haskell-effectful/effectful/pull/232. + toException = asyncExceptionToException + fromException = asyncExceptionFromException + +matchReturnWith :: ReturnWithId -> ReturnWithWrapper -> Maybe r +matchReturnWith rid (ReturnWithWrapper rtag _ r) + | rid == rtag = Just (fromAny r) + | otherwise = Nothing diff --git a/src/Effectful/State/Dynamic.hs b/src/Effectful/State/Dynamic.hs --- a/src/Effectful/State/Dynamic.hs +++ b/src/Effectful/State/Dynamic.hs @@ -1,7 +1,11 @@ +-- The handlers need to interpret the deprecated StateM operation until it's +-- removed. +{-# OPTIONS_GHC -Wno-deprecations #-} -- | 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 +35,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.Effect.Dynamic (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 +69,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 @@ -157,3 +145,6 @@ => (s -> Eff es s) -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s) + +{-# DEPRECATED stateM, modifyM + "Use a combination of get and put instead." #-} diff --git a/src/Effectful/State/Static/Local.hs b/src/Effectful/State/Static/Local.hs --- a/src/Effectful/State/Static/Local.hs +++ b/src/Effectful/State/Static/Local.hs @@ -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,10 @@ -- -- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ modifyM - :: State s :> es + :: (HasCallStack, State s :> es) => (s -> Eff es s) -- ^ The monadic function to modify the state. -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s) --- $setup --- >>> import Control.Exception (ErrorCall) --- >>> import Control.Monad.Catch +{-# DEPRECATED stateM, modifyM + "State modifications made via operations of the same State effect within the callback are discarded. Use a combination of get and put instead." #-} diff --git a/src/Effectful/State/Static/Shared.hs b/src/Effectful/State/Static/Shared.hs --- a/src/Effectful/State/Static/Shared.hs +++ b/src/Effectful/State/Static/Shared.hs @@ -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,115 @@ , modifyM ) where -import Control.Concurrent.MVar +import Control.Concurrent.MVar.Strict qualified as S +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 (S.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_ $ S.newMVar s a <- evalStaticRep (State v) m - (a, ) <$> unsafeEff_ (readMVar v) + (a, ) <$> unsafeEff_ (S.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_ $ S.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_ $ S.newMVar s _ <- evalStaticRep (State v) m - unsafeEff_ $ readMVar v + unsafeEff_ $ S.readMVar v --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | Run the 'State' effect with the given initial state 'S.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 => S.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_ (S.readMVar v) --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | Run the 'State' effect with the given initial state 'S.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 => S.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 'S.MVar' and return the -- final state, discarding the final value. -execStateMVar :: MVar s -> Eff (State s : es) a -> Eff es s +execStateMVar :: HasCallStack => S.MVar s -> Eff (State s : es) a -> Eff es s execStateMVar v m = do _ <- evalStaticRep (State v) m - unsafeEff_ $ readMVar v + unsafeEff_ $ S.readMVar v +{-# DEPRECATED runStateMVar, evalStateMVar, execStateMVar + "If you need access to the state from outside of the State effect, manage an explicit MVar yourself." #-} + -- | 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 + S.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 + 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) + S.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 + S.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 +{-# DEPRECATED stateM, modifyM + "Operations of the same State effect used within the callback deadlock. Use a combination of get and put instead, or an explicit MVar if you need atomic updates." #-} diff --git a/src/Effectful/Writer/Dynamic.hs b/src/Effectful/Writer/Dynamic.hs --- a/src/Effectful/Writer/Dynamic.hs +++ b/src/Effectful/Writer/Dynamic.hs @@ -1,8 +1,12 @@ +{-# 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". +-- +-- __If you just want to accumulate values, use "Effectful.Output.Dynamic".__ module Effectful.Writer.Dynamic ( -- * Effect Writer(..) @@ -25,34 +29,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.Effect.Dynamic (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 +56,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) diff --git a/src/Effectful/Writer/Static/Local.hs b/src/Effectful/Writer/Static/Local.hs --- a/src/Effectful/Writer/Static/Local.hs +++ b/src/Effectful/Writer/Static/Local.hs @@ -8,6 +8,8 @@ -- is inefficient. __This applies, in particular, to the standard list type__, -- which makes the 'Writer' effect pretty niche. -- +-- __If you just want to accumulate values, use "Effectful.Output.Static.Local.Array" or "Effectful.Output.Static.Local.List".__ +-- -- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the -- @transformers@ package includes additional operations -- 'Control.Monad.Trans.Writer.Strict.pass' and @@ -28,6 +30,7 @@ ) where import Control.Exception (onException, mask) +import Data.Kind import Effectful import Effectful.Dispatch.Static @@ -35,27 +38,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 +78,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 diff --git a/src/Effectful/Writer/Static/Shared.hs b/src/Effectful/Writer/Static/Shared.hs --- a/src/Effectful/Writer/Static/Shared.hs +++ b/src/Effectful/Writer/Static/Shared.hs @@ -8,6 +8,8 @@ -- is inefficient. __This applies, in particular, to the standard list type__, -- which makes the 'Writer' effect pretty niche. -- +-- __If you just want to accumulate values, use "Effectful.Output.Static.Shared.Array" or "Effectful.Output.Static.Shared.List".__ +-- -- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the -- @transformers@ package includes additional operations -- 'Control.Monad.Trans.Writer.Strict.pass' and @@ -27,44 +29,69 @@ , listens ) where -import Control.Concurrent.MVar +import Control.Concurrent.MVar.Strict qualified as S 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 (S.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_ $ S.newMVar mempty a <- evalStaticRep (Writer v) m - (a, ) <$> unsafeEff_ (readMVar v) + (a, ) <$> unsafeEff_ (S.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_ $ S.newMVar mempty _ <- evalStaticRep (Writer v) m - unsafeEff_ $ readMVar v + unsafeEff_ $ S.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 + S.modifyMVar_ v $ \w0 -> pure (w0 <> w1) -- | Execute an action and append its output to the overall output of the -- 'Writer'. -- +-- /Note:/ the output of 'tell' executed from threads spawned within the nested +-- action is accounted for only if it completes before 'listen' merges the +-- output, which happens as soon as the action finishes. In particular, the +-- output of threads that outlive the scope of 'listen' will be lost: +-- +-- >>> :{ +-- runEff . execWriter @String $ do +-- lock <- liftIO newEmptyMVar +-- done <- liftIO newEmptyMVar +-- tell "1" +-- _ <- listen @String $ do +-- tell "2" +-- withEffToIO (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do +-- _ <- forkIO $ do +-- takeMVar lock +-- unlift $ tell "3" +-- putMVar done () +-- pure () +-- liftIO $ putMVar lock () +-- liftIO $ takeMVar done +-- tell "4" +-- :} +-- "124" +-- -- /Note:/ if an exception is received while the action is executed, the partial -- output of the action will still be appended to the overall output of the -- 'Writer': @@ -79,15 +106,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 <- S.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 +122,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 <- S.readMVar v1 + S.modifyMVar_ v0 $ \w0 -> pure (w0 <> w1) pure w1 -- | Execute an action and append its output to the overall output of the @@ -104,11 +131,16 @@ -- 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.Concurrent -- >>> import Control.Exception (ErrorCall) --- >>> import Control.Monad.Catch +-- >>> import Effectful.Exception diff --git a/utils/Effectful/Internal/Utils.hs b/utils/Effectful/Internal/Utils.hs deleted file mode 100644 --- a/utils/Effectful/Internal/Utils.hs +++ /dev/null @@ -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 diff --git a/utils/utils.c b/utils/utils.c deleted file mode 100644 --- a/utils/utils.c +++ /dev/null @@ -1,5 +0,0 @@ -// Correct implementation of ThreadId# equality for GHC < 9. -long effectful_eq_thread(void *tso1, void *tso2) -{ - return tso1 == tso2; -}