diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,125 @@ +# effectful-core-2.6.1.0 (2025-08-30) +* Add `MonadError`, `MonadReader`, `MonadState` and `MonadWriter` instances for + `Eff` for compatibility with existing code. + +# effectful-core-2.6.0.0 (2025-06-13) +* Adjust `generalBracket` with `base >= 4.21` to make use of the new exception + annotation mechanism. +* Add `withException` to `Effectful.Exception`. +* Deprecate `Effectful.Reader.Dynamic.withReader` as it doesn't work correctly + for all potential interpreters. +* **Breaking changes**: + - Change the order of type parameters in `raise` for better usability. + - `Effectful.Error.Static.ErrorWrapper` is no longer caught by `catchSync`. + - Remove deprecated function `Effectful.withConcEffToIO`. + +# effectful-core-2.5.1.0 (2024-11-27) +* Add `passthrough` to `Effectful.Dispatch.Dynamic` for passing operations to + the upstream handler within `interpose` and `impose` without having to fully + pattern match on them. +* **Bugfixes**: + - Fix a potential space leak related to `HasCallStack` quirks (see + https://gitlab.haskell.org/ghc/ghc/-/issues/25520 for more information). + +# effectful-core-2.5.0.0 (2024-10-23) +* Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make + `emptyEff` and `sumEff` generate better call stacks. +* Explicitly define `setByteArray#` and `setOffAddr#` in the `Prim` instance of + `Ref` for `primitive` < 0.9.0.0. +* **Bugfixes**: + - `OnEmptyRollback` strategy of the `NonDet` effect is no longer broken. +* **Breaking changes**: + - Remove `restoreEnv` function from `Effectful.Dispatch.Static.Primitive` + since it was broken. + - Base `Effectful.Exception` on `Control.Exception` instead of the + `safe-exceptions` library for consistency with provided `MonadThrow` and + `MonadCatch` instances. + +# effectful-core-2.4.0.0 (2024-10-08) +* Add utility functions for handling effects that take the effect handler as the + last parameter to `Effectful.Dispatch.Dynamic`. +* Add utility functions for handling first order effects to + `Effectful.Dispatch.Dynamic`. +* Improve `Effectful.Labeled`, add `Effectful.Labeled.Error`, + `Effectful.Labeled.Reader`, `Effectful.Labeled.State` and + `Effectful.Labeled.Writer`. +* Add `throwErrorWith` and `throwError_` to `Effectful.Error.Static` and + `Effectful.Error.Dynamic`. +* Add `HasCallStack` constraints where appropriate for better debugging + experience. +* Add a `SeqForkUnlift` strategy to support running unlifting functions outside + of the scope of effects they capture. +* Add `Effectful.Exception` with appropriate re-exports from the + `safe-exceptions` library. +* **Bugfixes**: + - Ensure that a `LocalEnv` is only used in a thread it belongs to. + - Properly roll back changes made to the environment when `OnEmptyRollback` + policy for the `NonDet` effect is selected. + - Fix a bug in `stateM` and `modifyM` of thread local `State` effect that + might've caused dropped state updates + ([#237](https://github.com/haskell-effectful/effectful/issues/237)). +* **Breaking changes**: + - `localSeqLend`, `localLend`, `localSeqBorrow` and `localBorrow` now take a + list of effects instead of a single one. + - `Effectful.Error.Static.throwError` now requires the error type to have a + `Show` constraint. If this is not the case for some of your error types, use + `throwError_` for them. + - `ThrowError` operation from the dynamic version of the `Error` effect was + replaced with `ThrowErrorWith`. + - `stateEnv` and `modifyEnv` now take pure modification functions. If you rely + on their old forms, switch to a combination of `getEnv` and `putEnv`. + - `runStateMVar`, `evalStateMVar` and `execStateMVar` now take a strict + `MVar'` from the `strict-mutable-base` package. + +# effectful-core-2.3.1.0 (2024-06-07) +* Drop support for GHC 8.8. +* Remove inaccurate information from the `Show` instance of `ErrorWrapper`. +* Add `Effectful.Provider.List`, generalization of `Effectful.Provider`. +* Respect `withFrozenCallStack` used by callers of `send`. +* Support exchange of effects between the environment of the handler and the + local one via `localSeqLend`, `localLend`, `localSeqBorrow` and `localBorrow` + from `Effectful.Dispatch.Dynamic`. + +# effectful-core-2.3.0.1 (2023-11-13) +* Prevent internal functions from appending call stack frames to handlers. + +# effectful-core-2.3.0.0 (2023-09-13) +* Deprecate `withConcEffToIO`. +* Make `withEffToIO` take an explicit unlifting strategy for the sake of + consistency with unlifting functions from `Effectful.Dispatch.Dynamic` and + easier to understand API. +* Add support for turning an effect handler into an effectful operation via the + `Provider` effect. +* Add `runErrorWith` and `runErrorNoCallStackWith` to `Effectful.Error.Dynamic` + and `Effectful.Error.Static`. +* Add support for having multiple effects of the same type in scope via the + `Labeled` effect. + +# effectful-core-2.2.2.2 (2023-03-13) +* Allow `inject` to turn a monomorphic effect stack into a polymorphic one. +* Use C sources only with GHC < 9. +* Force inlining of `bracket` early to work around excessive inlining problem + with GHC 9.6 (https://gitlab.haskell.org/ghc/ghc/-/issues/22824). + +# effectful-core-2.2.2.1 (2023-01-12) +* Stop using the internal library because of bugs in `stack`. + +# effectful-core-2.2.2.0 (2023-01-11) +* Add `withSeqEffToIO` and `withConcEffToIO` to `Effectful`. +* Use strict `IORef` and `MVar` variants where appropriate. +* Make `inject` work with effect stacks sharing a polymorphic suffix. + +# effectful-core-2.2.1.0 (2022-11-09) +* Add `localSeqLift` and `localLift` to `Effectful.Dispatch.Dynamic`. + +# effectful-core-2.2.0.0 (2022-10-24) +* Change `PrimState` for `Eff` from `RealWorld` to `PrimStateEff` to prevent the + `Prim` effect from executing arbitrary `IO` actions via `ioToPrim`. +* Deprecate `(:>>)` as [GHC can't efficiently deal with type + families](https://github.com/haskell-effectful/effectful/issues/52#issuecomment-1269155485). +* Add support for the `Alternative` and `MonadPlus` instances for `Eff` via the + `NonDet` effect. + # effectful-core-2.1.0.0 (2022-08-22) * Include the `e :> localEs` constraint in the `EffectHandler` to allow more flexibility in handling higher order effects. 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/cbits/utils.c b/cbits/utils.c new file mode 100644 --- /dev/null +++ b/cbits/utils.c @@ -0,0 +1,5 @@ +// Correct implementation of ThreadId# equality for GHC < 9. +long effectful_eq_thread(void *tso1, void *tso2) +{ + return tso1 == tso2; +} 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.0 build-type: Simple name: effectful-core -version: 2.1.0.0 +version: 2.6.1.0 license: BSD-3-Clause license-file: LICENSE category: Control @@ -21,7 +21,7 @@ CHANGELOG.md README.md -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.1 +tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.2, 9.12.2, 9.14.1 } bug-reports: https://github.com/haskell-effectful/effectful/issues source-repository head @@ -29,7 +29,11 @@ location: https://github.com/haskell-effectful/effectful.git common language - ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors + ghc-options: -Wall + -Wcompat + -Wno-unticked-promoted-constructors + -Wmissing-deriving-strategies + -Werror=prepositive-qualified-module default-language: Haskell2010 @@ -38,13 +42,16 @@ DataKinds DeriveFunctor DeriveGeneric + DerivingStrategies FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase MultiParamTypeClasses NoStarIsType + PolyKinds RankNTypes RoleAnnotations ScopedTypeVariables @@ -53,34 +60,29 @@ TypeApplications TypeFamilies TypeOperators - -library effectful-internal-utils - import: language - - build-depends: base - - hs-source-dirs: utils - c-sources: utils/utils.c - - exposed-modules: Effectful.Internal.Utils + UndecidableInstances library import: language ghc-options: -O2 - build-depends: effectful-internal-utils - - build-depends: base >= 4.13 && < 5 + build-depends: base >= 4.14 && < 5 , containers >= 0.6 + , deepseq >= 1.2 , exceptions >= 0.10.4 + , mtl >= 2.2.1 , monad-control >= 1.0.3 , primitive >= 0.7.3.0 + , strict-mutable-base >= 1.1.0.0 , transformers-base >= 0.4.6 , unliftio-core >= 0.2.0.1 hs-source-dirs: src + if impl(ghc < 9) + c-sources: cbits/utils.c + exposed-modules: Effectful Effectful.Dispatch.Dynamic Effectful.Dispatch.Static @@ -88,12 +90,23 @@ Effectful.Dispatch.Static.Unsafe Effectful.Error.Dynamic Effectful.Error.Static + Effectful.Exception Effectful.Fail Effectful.Internal.Effect Effectful.Internal.Env + Effectful.Internal.MTL Effectful.Internal.Monad Effectful.Internal.Unlift + Effectful.Internal.Utils + Effectful.Labeled + Effectful.Labeled.Error + Effectful.Labeled.Reader + Effectful.Labeled.State + Effectful.Labeled.Writer + Effectful.NonDet Effectful.Prim + Effectful.Provider + Effectful.Provider.List Effectful.Reader.Dynamic Effectful.Reader.Static Effectful.State.Dynamic @@ -102,5 +115,3 @@ Effectful.Writer.Dynamic Effectful.Writer.Static.Local Effectful.Writer.Static.Shared - - reexported-modules: Effectful.Internal.Utils 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 @@ -63,6 +64,7 @@ import Effectful.Internal.Effect import Effectful.Internal.Env +import Effectful.Internal.MTL () import Effectful.Internal.Monad -- $intro @@ -95,7 +97,8 @@ -- -- It implements support for extensible effects with both dynamic and static -- dispatch. For more information about each type consult the documentation in --- "Effectful.Dispatch.Dynamic" and "Effectful.Dispatch.Static". +-- "Effectful.Dispatch.Dynamic" and "Effectful.Dispatch.Static" (when in doubt, +-- start with dynamic dispatch). -- -- The library provides: -- @@ -107,7 +110,8 @@ -- t'Effectful.Writer.Static.Local.Writer'. -- -- - Utilities for defining new effects and interpreting them, possibly in terms --- of already existing ones. +-- of already existing ones (see introduction of the +-- "Effectful.Dispatch.Dynamic" module for more information). -- -- While basic effects can be used out of the box, in general it's recommended -- to create your own that serve a more specific purpose. @@ -116,7 +120,7 @@ -- $integration -- -- Integration with most of existing libraries and frameworks can be done quite --- easily. The main difference on how that looks like depends on the way a +-- easily. The main difference in how that looks like depends on the way a -- library operates in a monadic context. -- -- There are three main groups a library might fall into. It either operates: @@ -144,7 +148,7 @@ -- -- These libraries can trivially be used with the 'Eff' monad since it provides -- typical instances that these libraries require the underlying monad to have, --- such as t'Control.Monad.Catch.MonadMask' or 'MonadUnliftIO'. +-- such as t'Effectful.Exception.MonadMask' or 'MonadUnliftIO'. -- -- In case the 'Eff' monad doesn't provide a specific instance out of the box, -- it can be supplied via an effect. As an example see how the instance of @@ -158,9 +162,9 @@ -- If a library operates in 'IO', there are a couple of ways to integrate it. -- -- The easiest way is to use its functions selectively in the 'Eff' monad with --- the help of 'liftIO' or 'withEffToIO' / 'withRunInIO'. However, this is not --- particularly robust, since it vastly broadens the scope in which the 'IOE' --- effect is needed (not to mention that explicit lifting is annoying). +-- the help of 'liftIO' or 'withEffToIO'. However, this is not particularly +-- robust, since it vastly broadens the scope in which the 'IOE' effect is +-- needed (not to mention that explicit lifting is annoying). -- -- A somewhat better approach is to create a dummy static effect with -- lightweight wrappers of the library functions. As an example have a look at @@ -195,8 +199,8 @@ -- -- As an example, consider the following monad: -- --- >>> import qualified Control.Monad.State as T --- >>> import qualified Control.Monad.Except as T +-- >>> import Control.Monad.State qualified as T +-- >>> import Control.Monad.Except qualified as T -- -- >>> data HandlerState -- >>> data HandlerError 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,38 @@ , localLiftUnlift , localLiftUnliftIO - -- *** Utils + -- *** Misc + , localSeqLend + , localLend + , localSeqBorrow + , localBorrow , SharedSuffix + , KnownSubset + -- ** Utils for first order effects + , EffectHandler_ + , interpret_ + , interpretWith_ + , reinterpret_ + , reinterpretWith_ + , interpose_ + , interposeWith_ + , impose_ + , imposeWith_ + -- * Re-exports , HasCallStack ) where -import Control.Exception (bracket) -import Control.Monad.IO.Unlift -import GHC.Stack (HasCallStack) +import Control.Monad +import Data.Primitive.PrimArray +import GHC.Stack import GHC.TypeLits import Effectful.Internal.Effect import Effectful.Internal.Env import Effectful.Internal.Monad +import Effectful.Internal.Utils -- $intro -- @@ -126,11 +154,9 @@ -- The following defines an 'EffectHandler' that reads and writes files from the -- drive: -- --- >>> import Control.Exception (IOException) --- >>> import Control.Monad.Catch (catch) --- >>> import qualified System.IO as IO --- -- >>> import Effectful.Error.Static +-- >>> import Effectful.Exception +-- >>> import System.IO qualified as IO -- -- >>> newtype FsError = FsError String deriving Show -- @@ -143,7 +169,7 @@ -- ReadFile path -> adapt $ IO.readFile path -- WriteFile path contents -> adapt $ IO.writeFile path contents -- where --- adapt m = liftIO m `catch` \(e::IOException) -> throwError . FsError $ show e +-- adapt m = liftIO m `catchIO` \e -> throwError . FsError $ show e -- :} -- -- Here, we use 'interpret' and simply execute corresponding 'IO' actions for @@ -152,8 +178,7 @@ -- On the other hand, maybe there is a situation in which instead of interacting -- with the outside world, a pure, in-memory storage is preferred: -- --- >>> import qualified Data.Map.Strict as M --- +-- >>> import Data.Map.Strict qualified as M -- >>> import Effectful.State.Static.Local -- -- >>> :{ @@ -200,10 +225,13 @@ -- -- If an effect makes use of the @m@ parameter, it is a /higher order effect/. -- --- Interpretation of higher order effects is slightly more involved. To see why, --- let's consider the @Profiling@ effect for logging how much time a specific --- action took to run: +-- /Note:/ for handling first order effects you can use 'interpret_' or +-- 'reinterpret_' whose 'EffectHandler_' doesn't take the 'LocalEnv' parameter. -- +-- Interpretation of higher order effects is slightly more involving. To see +-- why, let's consider the @Profiling@ effect for logging how much time a +-- specific action took to run: +-- -- >>> :{ -- data Profiling :: Effect where -- Profile :: String -> m a -> Profiling m a @@ -236,8 +264,8 @@ -- -- The problem is that @action@ has a type @Eff localEs a@, while the monad of -- the effect handler is @Eff es@. @localEs@ represents the /local environment/ --- in which the @Profile@ operation was called, which is opaque as the effect --- handler cannot possibly know how it looks like. +-- in which the @Profile@ operation was called, which is more or less opaque to +-- the effect handler. -- -- The solution is to use the 'LocalEnv' that an 'EffectHandler' is given to run -- the action using one of the functions from the 'localUnlift' family: @@ -320,8 +348,6 @@ -- __orphan__, __canonical__ instance of @MonadRNG@ for 'Eff' that delegates to -- the @RNG@ effect: -- --- >>> :set -XUndecidableInstances --- -- >>> :{ -- instance RNG :> es => MonadRNG (Eff es) where -- randomInt = send RandomInt @@ -331,7 +357,7 @@ -- -- >>> :{ -- runDummyRNG :: Eff (RNG : es) a -> Eff es a --- runDummyRNG = interpret $ \_ -> \case +-- runDummyRNG = interpret_ $ \case -- RandomInt -> pure 55 -- :} -- @@ -342,34 +368,161 @@ -- "777" -- +-- $mtl-fundeps +-- +-- For dealing with classes that employ functional dependencies an additional +-- trick is needed. +-- +-- Consider the following: +-- +-- >>> :set -XFunctionalDependencies +-- +-- >>> :{ +-- class Monad m => MonadInput i m | m -> i where +-- input :: m i +-- :} +-- +-- An attempt to define the instance as in the example above leads to violation +-- of the liberal coverage condition: +-- +-- >>> :{ +-- instance Reader i :> es => MonadInput i (Eff es) where +-- input = ask +-- :} +-- ... +-- ...Illegal instance declaration for ‘MonadInput i (Eff es)’... +-- ... The liberal coverage condition fails in class ‘MonadInput’... +-- ... for functional dependency: ‘m -> i’... +-- ... +-- +-- However, there exists a trick for bypassing the coverage condition, +-- i.e. including the instance head in its context: +-- +-- >>> :{ +-- instance (MonadInput i (Eff es), Reader i :> es) => MonadInput i (Eff es) where +-- input = ask +-- :} +-- +-- Now the @MonadInput@ class can be used with the 'Eff' monad: +-- +-- >>> :{ +-- double :: MonadInput Int m => m Int +-- double = (+) <$> input <*> input +-- :} +-- +-- >>> runPureEff . runReader @Int 3 $ double +-- 6 + +-- | A variant of 'send' for passing operations to the upstream handler within +-- 'interpose' and 'impose' without having to fully pattern match on them. +passthrough + :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es, e :> localEs, SharedSuffix es handlerEs) + => LocalEnv localEs handlerEs + -> e (Eff localEs) a + -- ^ The operation. + -> Eff es a +passthrough (LocalEnv les) op = unsafeEff $ \es -> do + Handler handlerEs (HandlerImpl handler) <- getEnv es + when (envStorage les /= envStorage handlerEs) $ do + error "les and handlerEs point to different Storages" + -- Prevent the addition of unnecessary 'handler' stack frame to the call + -- stack. Note that functions 'interpret', 'reinterpret', 'interpose' and + -- 'impose' need to thaw the call stack so that useful stack frames from + -- inside the effect handler continue to be added. + unEff (withFrozenCallStack handler (LocalEnv les) op) handlerEs +{-# NOINLINE passthrough #-} + ---------------------------------------- -- Handling effects -- | Interpret an effect. +-- +-- /Note:/ if you want to use intermediate effects in multiple handlers, then +-- hide them from downstream, have a look at 'inject'. interpret - :: DispatchOf e ~ Dynamic + :: (HasCallStack, DispatchOf e ~ Dynamic) => EffectHandler e es -- ^ The effect handler. -> Eff (e : es) a -> Eff es a -interpret handler m = unsafeEff $ \es -> do - (`unEff` es) $ runHandler (Handler es handler) m +interpret handler action = interpretImpl action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) +-- | 'interpret' with the effect handler as the last argument. +-- +-- @since 2.4.0.0 +interpretWith + :: (HasCallStack, DispatchOf e ~ Dynamic) + => Eff (e : es) a + -> EffectHandler e es + -- ^ The effect handler. + -> Eff es a +interpretWith action handler = interpretImpl action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) + -- | Interpret an effect using other, private effects. -- -- @'interpret' ≡ 'reinterpret' 'id'@ +-- +-- /Note:/ If you want to interpret multiple effects using other, private +-- effects, you can do so with a combination of 'interpret' and 'inject'. +-- +-- This is in particular useful for splitting a large effect into smaller +-- ones. For example, let's say you want to split a +-- t'Effectful.State.Static.Local.State' into a read only and read write +-- component: +-- +-- >>> :{ +-- data Get s :: Effect where +-- Get :: Get s m s +-- type instance DispatchOf (Get s) = Dynamic +-- :} +-- +-- >>> :{ +-- data Put s :: Effect where +-- Put :: s -> Put s m () +-- type instance DispatchOf (Put s) = Dynamic +-- :} +-- +-- >>> import Effectful.State.Static.Local qualified as S +-- +-- >>> :{ +-- runGetPut :: forall s es a. s -> Eff (Get s : Put s : es) a -> Eff es (a, s) +-- runGetPut s0 +-- = S.runState s0 +-- . interpret_ @(Put s) (\(Put s) -> S.put s) +-- . interpret_ @(Get s) (\Get -> S.get) +-- . inject +-- :} +-- +-- Here, a t'Effectful.State.Static.Local.State' effect is introduced, then +-- @Put@ and @Get@ effects that use it underneath and finally 'inject' hides the +-- original state from downstream code. reinterpret - :: DispatchOf e ~ Dynamic + :: (HasCallStack, DispatchOf e ~ Dynamic) => (Eff handlerEs a -> Eff es b) - -- ^ Introduction of effects encapsulated within the handler. + -- ^ Setup of effects encapsulated in the handler. -> EffectHandler e handlerEs -- ^ The effect handler. -> Eff (e : es) a -> Eff es b -reinterpret runHandlerEs handler m = unsafeEff $ \es -> do - (`unEff` es) . runHandlerEs . unsafeEff $ \handlerEs -> do - (`unEff` es) $ runHandler (Handler handlerEs handler) m +reinterpret runSetup handler action = reinterpretImpl runSetup action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) +-- | 'reinterpret' with the effect handler as the last argument. +-- +-- @since 2.4.0.0 +reinterpretWith + :: (HasCallStack, DispatchOf e ~ Dynamic) + => (Eff handlerEs a -> Eff es b) + -- ^ Setup of effects encapsulated in the handler. + -> Eff (e : es) a + -> EffectHandler e handlerEs + -- ^ The effect handler. + -> Eff es b +reinterpretWith runSetup action handler = reinterpretImpl runSetup action $ + HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) + -- | Replace the handler of an existing effect with a new one. -- -- /Note:/ this function allows for augmenting handlers with a new functionality @@ -377,82 +530,220 @@ -- -- >>> :{ -- data E :: Effect where --- Op :: E m () +-- Op1 :: E m () +-- Op2 :: E m () +-- Op3 :: E m () -- type instance DispatchOf E = Dynamic -- :} -- -- >>> :{ -- runE :: IOE :> es => Eff (E : es) a -> Eff es a --- runE = interpret $ \_ Op -> liftIO (putStrLn "op") +-- runE = interpret_ $ \case +-- Op1 -> liftIO (putStrLn "op1") +-- Op2 -> liftIO (putStrLn "op2") +-- Op3 -> error "Op3 not implemented" -- :} -- --- >>> runEff . runE $ send Op --- op +-- >>> let action = send Op1 >> send Op2 -- +-- >>> runEff . runE $ action +-- op1 +-- op2 +-- +-- You can modify only specific operations and send the rest to the upstream +-- handler with 'passthrough': +-- -- >>> :{ --- augmentE :: (E :> es, IOE :> es) => Eff es a -> Eff es a --- augmentE = interpose $ \_ Op -> liftIO (putStrLn "augmented op") >> send Op +-- augmentOp2 :: (E :> es, IOE :> es) => Eff es a -> Eff es a +-- augmentOp2 = interpose $ \env -> \case +-- Op2 -> liftIO (putStrLn "augmented op2") >> send Op2 +-- op -> passthrough env op -- :} -- --- >>> runEff . runE . augmentE $ send Op --- augmented op --- op +-- >>> runEff . runE . augmentOp2 $ action +-- op1 +-- augmented op2 +-- op2 -- +-- /Note:/ when an exception is raised while handling an operation, good +-- debugging experience is ensured by strategically placed 'HasCallStack' +-- constraints: +-- +-- >>> runEff . runE . augmentOp2 $ send Op3 +-- *** Exception: Op3 not implemented +-- ... +-- error, called at :... +-- 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 @@ -465,8 +756,10 @@ -- ^ Continuation with the unlifting function in scope. -> Eff es a localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do + requireMatchingStorages es les seqUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localSeqUnlift #-} -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the -- general version see 'localUnliftIO'. @@ -477,7 +770,10 @@ -> ((forall r. Eff localEs r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a -localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftIO les k +localSeqUnliftIO (LocalEnv les) k = unsafeEff $ \es -> do + requireMatchingStorages es les + seqUnliftIO les k +{-# INLINE localSeqUnliftIO #-} -- | Create a local unlifting function with the given strategy. localUnlift @@ -488,13 +784,16 @@ -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a) -- ^ Continuation with the unlifting function in scope. -> Eff es a -localUnlift (LocalEnv les) strategy k = case strategy of - SeqUnlift -> unsafeEff $ \es -> do - seqUnliftIO les $ \unlift -> do +localUnlift (LocalEnv les) strategy k = unsafeEff $ \es -> do + requireMatchingStorages es les + case strategy of + SeqUnlift -> seqUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift - ConcUnlift p l -> unsafeEff $ \es -> do - concUnliftIO les p l $ \unlift -> do + SeqForkUnlift -> seqForkUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift + ConcUnlift p l -> concUnliftIO les p l $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localUnlift #-} -- | Create a local unlifting function with the given strategy. localUnliftIO @@ -505,10 +804,56 @@ -> ((forall r. Eff localEs r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a -localUnliftIO (LocalEnv les) strategy k = case strategy of - SeqUnlift -> liftIO $ seqUnliftIO les k - ConcUnlift p l -> liftIO $ concUnliftIO les p l k +localUnliftIO (LocalEnv les) strategy k = unsafeEff $ \es -> do + requireMatchingStorages es les + case strategy of + SeqUnlift -> seqUnliftIO les k + SeqForkUnlift -> seqForkUnliftIO les k + ConcUnlift p l -> concUnliftIO les p l k +{-# INLINE localUnliftIO #-} +---------------------------------------- +-- Lifts + +-- | Create a local lifting function with the 'SeqUnlift' strategy. For the +-- general version see 'localLift'. +-- +-- @since 2.2.1.0 +localSeqLift + :: (HasCallStack, SharedSuffix es handlerEs) + => LocalEnv localEs handlerEs + -- ^ Local environment. + -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a) + -- ^ Continuation with the lifting function in scope. + -> Eff es a +localSeqLift (LocalEnv les) k = unsafeEff $ \es -> do + requireMatchingStorages es les + seqUnliftIO es $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localSeqLift #-} + +-- | Create a local lifting function with the given strategy. +-- +-- @since 2.2.1.0 +localLift + :: (HasCallStack, SharedSuffix es handlerEs) + => LocalEnv localEs handlerEs + -- ^ Local environment. + -> UnliftStrategy + -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a) + -- ^ Continuation with the lifting function in scope. + -> Eff es a +localLift (LocalEnv les) strategy k = unsafeEff $ \es -> do + requireMatchingStorages es les + case strategy of + SeqUnlift -> seqUnliftIO es $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift + SeqForkUnlift -> seqForkUnliftIO es $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift + ConcUnlift p l -> concUnliftIO es p l $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localLift #-} + -- | Utility for lifting 'Eff' computations of type -- -- @'Eff' es a -> 'Eff' es b@ @@ -526,12 +871,12 @@ -> ((forall a b. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r) -- ^ Continuation with the lifting function in scope. -> Eff es r -withLiftMap !_ k = unsafeEff $ \es -> do - -- The LocalEnv parameter is not used, but we need it to constraint the - -- localEs type variable. It's also strict so that callers don't cheat. +withLiftMap (LocalEnv les) k = unsafeEff $ \es -> do + requireMatchingStorages es les (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do seqUnliftIO localEs $ \unlift -> do (`unEff` es) . mapEff . unsafeEff_ $ unlift m +{-# INLINE withLiftMap #-} -- | Utility for lifting 'IO' computations of type -- @@ -566,10 +911,11 @@ -> ((forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r) -- ^ Continuation with the lifting function in scope. -> Eff es r -withLiftMapIO !_ k = k $ \mapIO m -> unsafeEff $ \es -> do - -- The LocalEnv parameter is not used, but we need it to constraint the - -- localEs type variable. It's also strict so that callers don't cheat. - seqUnliftIO es $ \unlift -> mapIO $ unlift m +withLiftMapIO (LocalEnv les) k = unsafeEff $ \es -> do + requireMatchingStorages es les + (`unEff` es) $ k $ \mapIO m -> unsafeEff $ \localEs -> do + seqUnliftIO localEs $ \unlift -> mapIO $ unlift m +{-# INLINE withLiftMapIO #-} ---------------------------------------- -- Bidirectional lifts @@ -589,15 +935,19 @@ -> ((forall r. Eff es r -> Eff localEs r) -> (forall r. Eff localEs r -> Eff es r) -> Eff es a) -- ^ Continuation with the lifting and unlifting function in scope. -> Eff es a -localLiftUnlift (LocalEnv les) strategy k = case strategy of - SeqUnlift -> unsafeEff $ \es -> do - seqUnliftIO es $ \unliftEs -> do +localLiftUnlift (LocalEnv les) strategy k = unsafeEff $ \es -> do + requireMatchingStorages es les + case strategy of + SeqUnlift -> seqUnliftIO es $ \unliftEs -> do seqUnliftIO les $ \unliftLocalEs -> do (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) - ConcUnlift p l -> unsafeEff $ \es -> do - concUnliftIO es p l $ \unliftEs -> do + SeqForkUnlift -> seqForkUnliftIO es $ \unliftEs -> do + seqForkUnliftIO les $ \unliftLocalEs -> do + (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) + ConcUnlift p l -> concUnliftIO es p l $ \unliftEs -> do concUnliftIO les p l $ \unliftLocalEs -> do (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) +{-# INLINE localLiftUnlift #-} -- | Create a local unlifting function with the given strategy along with an -- unrestricted lifting function. @@ -615,13 +965,136 @@ -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a) -- ^ Continuation with the lifting and unlifting function in scope. -> Eff es a -localLiftUnliftIO (LocalEnv les) strategy k = case strategy of - SeqUnlift -> liftIO $ seqUnliftIO les $ k unsafeEff_ - ConcUnlift p l -> liftIO $ concUnliftIO les p l $ k unsafeEff_ +localLiftUnliftIO (LocalEnv les) strategy k = unsafeEff $ \es -> do + requireMatchingStorages es les + case strategy of + SeqUnlift -> seqUnliftIO les $ k unsafeEff_ + SeqForkUnlift -> seqForkUnliftIO les $ k unsafeEff_ + ConcUnlift p l -> concUnliftIO les p l $ k unsafeEff_ +{-# INLINE localLiftUnliftIO #-} ---------------------------------------- --- Utils +-- Misc +-- | Lend effects to the local environment. +-- +-- Consider the following effect: +-- +-- >>> :{ +-- data D :: Effect where +-- D :: D m () +-- type instance DispatchOf D = Dynamic +-- :} +-- +-- and an auxiliary effect that requires both @IOE@ and @D@ to run: +-- +-- >>> :{ +-- data E :: Effect +-- runE :: (IOE :> es, D :> es) => Eff (E : es) a -> Eff es a +-- runE = error "runE" +-- :} +-- +-- Trying to use @runE@ inside the handler of @D@ doesn't work out of the box: +-- +-- >>> :{ +-- runD :: IOE :> es => Eff (D : es) a -> Eff es a +-- runD = interpret $ \env -> \case +-- D -> localSeqUnlift env $ \unlift -> do +-- unlift . runE $ pure () +-- :} +-- ... +-- ...Could not deduce ...IOE :> localEs... arising from a use of ‘runE’ +-- ...from the context: IOE :> es +-- ... +-- +-- The problem is that @runE@ needs @IOE :> localEs@, but only @IOE :> es@ is +-- available. This function allows us to bridge the gap: +-- +-- >>> :{ +-- runD :: IOE :> es => Eff (D : es) a -> Eff es a +-- runD = interpret $ \env -> \case +-- D -> localSeqUnlift env $ \unlift -> do +-- localSeqLend @'[IOE] env $ \useIOE -> do +-- unlift . useIOE . runE $ pure () +-- :} +-- +-- @since 2.4.0.0 +localSeqLend + :: forall lentEs es handlerEs localEs a + . (HasCallStack, KnownSubset lentEs es, SharedSuffix es handlerEs) + => LocalEnv localEs handlerEs + -> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a) + -- ^ Continuation with the lent handler in scope. + -> Eff es a +localSeqLend (LocalEnv les) k = unsafeEff $ \es -> do + eles <- copyRefs @lentEs es les + seqUnliftIO eles $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localSeqLend #-} + +-- | Lend effects to the local environment with a given unlifting strategy. +-- +-- Generalizes 'localSeqLend'. +-- +-- @since 2.4.0.0 +localLend + :: forall lentEs es handlerEs localEs a + . (HasCallStack, KnownSubset lentEs es, SharedSuffix es handlerEs) + => LocalEnv localEs handlerEs + -> UnliftStrategy + -> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a) + -- ^ Continuation with the lent handler in scope. + -> Eff es a +localLend (LocalEnv les) strategy k = unsafeEff $ \es -> do + eles <- copyRefs @lentEs es les + case strategy of + SeqUnlift -> seqUnliftIO eles $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift + SeqForkUnlift -> seqForkUnliftIO eles $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift + ConcUnlift p l -> concUnliftIO eles p l $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localLend #-} + +-- | Borrow effects from the local environment. +-- +-- @since 2.4.0.0 +localSeqBorrow + :: forall borrowedEs es handlerEs localEs a + . (HasCallStack, KnownSubset borrowedEs localEs, SharedSuffix es handlerEs) + => LocalEnv localEs handlerEs + -> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a) + -- ^ Continuation with the borrowed handler in scope. + -> Eff es a +localSeqBorrow (LocalEnv les) k = unsafeEff $ \es -> do + ees <- copyRefs @borrowedEs les es + seqUnliftIO ees $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localSeqBorrow #-} + +-- | Borrow effects from the local environment with a given unlifting +-- strategy. +-- +-- Generalizes 'localSeqBorrow'. +-- +-- @since 2.4.0.0 +localBorrow + :: forall borrowedEs es handlerEs localEs a + . (HasCallStack, KnownSubset borrowedEs localEs, SharedSuffix es handlerEs) + => LocalEnv localEs handlerEs + -> UnliftStrategy + -> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a) + -- ^ Continuation with the borrowed handler in scope. + -> Eff es a +localBorrow (LocalEnv les) strategy k = unsafeEff $ \es -> do + ees <- copyRefs @borrowedEs les es + case strategy of + SeqUnlift -> seqUnliftIO ees $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift + SeqForkUnlift -> seqForkUnliftIO ees $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift + ConcUnlift p l -> concUnliftIO ees p l $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE localBorrow #-} + -- | Require that both effect stacks share an opaque suffix. -- -- Functions from the 'localUnlift' family utilize this constraint to guarantee @@ -638,7 +1111,7 @@ -- Running local actions in a more specific environment is fine: -- -- >>> :{ --- runE1 :: Eff (E ': es) a -> Eff es a +-- runE1 :: Eff (E : es) a -> Eff es a -- runE1 = interpret $ \env -> \case -- E m -> runReader () $ do -- localSeqUnlift env $ \unlift -> unlift m @@ -647,7 +1120,7 @@ -- Running local actions in a more general environment is fine: -- -- >>> :{ --- runE2 :: Eff (E ': es) a -> Eff es a +-- runE2 :: Eff (E : es) a -> Eff es a -- runE2 = reinterpret (runReader ()) $ \env -> \case -- E m -> raise $ do -- localSeqUnlift env $ \unlift -> unlift m @@ -657,20 +1130,20 @@ -- this would make it possible to run anything within 'runPureEff': -- -- >>> :{ --- runE3 :: Eff (E ': es) a -> Eff es a +-- runE3 :: Eff (E : es) a -> Eff es a -- runE3 = reinterpret (runReader ()) $ \env -> \case -- E m -> pure . runPureEff $ do -- localSeqUnlift env $ \unlift -> unlift m -- :} -- ... --- ...Could not deduce (SharedSuffix '[] es)... +-- ...Could not deduce ...SharedSuffix '[] es... -- ... -- -- Running local actions in a monomorphic effect stack is also not fine as -- this makes a special case of the above possible: -- -- >>> :{ --- runE4 :: Eff '[E, IOE] a -> Eff '[IOE] a +-- runE4 :: Eff [E, IOE] a -> Eff '[IOE] a -- runE4 = interpret $ \env -> \case -- E m -> pure . runPureEff $ do -- localSeqUnlift env $ \unlift -> unlift m @@ -693,6 +1166,113 @@ Text "As a solution simply change the stack to have a polymorphic suffix." ) => SharedSuffix '[] '[] +---------------------------------------- +-- Helpers + +interpretImpl + :: (HasCallStack, DispatchOf e ~ Dynamic) + => Eff (e : es) a + -> HandlerImpl e es + -> Eff es a +interpretImpl action handlerImpl = unsafeEff $ \es -> do + (`unEff` es) $ runHandler (Handler es handlerImpl) action +{-# INLINE interpretImpl #-} + +reinterpretImpl + :: (HasCallStack, DispatchOf e ~ Dynamic) + => (Eff handlerEs a -> Eff es b) + -> Eff (e : es) a + -> HandlerImpl e handlerEs + -> Eff es b +reinterpretImpl runSetup action handlerImpl = unsafeEff $ \es -> do + (`unEff` es) . runSetup . unsafeEff $ \handlerEs -> do + (`unEff` es) $ runHandler (Handler handlerEs handlerImpl) action +{-# INLINE reinterpretImpl #-} + +interposeImpl + :: forall e es a. (HasCallStack, DispatchOf e ~ Dynamic, e :> es) + => Eff es a + -> HandlerImpl e es + -> Eff es a +interposeImpl action handlerImpl = unsafeEff $ \es -> do + inlineBracket + (do + origHandler <- getEnv @e es + replaceEnv origHandler relinkHandler es + ) + (\newEs -> do + -- Restore the original handler. + putEnv es =<< getEnv @e newEs + unreplaceEnv @e newEs + ) + (\newEs -> do + -- Replace the original handler with a new one. Note that 'newEs' + -- will still see the original handler. + putEnv es $ Handler newEs handlerImpl + unEff action es + ) +{-# INLINE interposeImpl #-} + +imposeImpl + :: forall e es handlerEs a b. (HasCallStack, DispatchOf e ~ Dynamic, e :> es) + => (Eff handlerEs a -> Eff es b) + -> Eff es a + -> HandlerImpl e handlerEs + -> Eff es b +imposeImpl runSetup action handlerImpl = unsafeEff $ \es -> do + inlineBracket + (do + origHandler <- getEnv @e es + replaceEnv origHandler relinkHandler es + ) + (\newEs -> do + -- Restore the original handler. + putEnv es =<< getEnv @e newEs + unreplaceEnv @e newEs + ) + (\newEs -> do + (`unEff` newEs) . runSetup . unsafeEff $ \handlerEs -> do + -- Replace the original handler with a new one. Note that + -- 'newEs' (and thus 'handlerEs') wil still see the original + -- handler. + putEnv es $ Handler handlerEs handlerImpl + unEff action es + ) +{-# INLINE imposeImpl #-} + +copyRefs + :: forall es srcEs destEs + . (HasCallStack, KnownSubset es srcEs) + => Env srcEs + -> Env destEs + -> IO (Env (es ++ destEs)) +copyRefs src@(Env soffset srefs _) dest@(Env doffset drefs storage) = do + requireMatchingStorages src dest + let es = reifyIndices @es @srcEs + esSize = length es + destSize = sizeofPrimArray drefs - doffset + mrefs <- newPrimArray (esSize + destSize) + copyPrimArray mrefs esSize drefs doffset destSize + let writeRefs i = \case + [] -> pure () + (x : xs) -> do + writePrimArray mrefs i $ indexPrimArray srefs (soffset + x) + writeRefs (i + 1) xs + writeRefs 0 es + refs <- unsafeFreezePrimArray mrefs + pure $ Env 0 refs storage +{-# NOINLINE copyRefs #-} + +requireMatchingStorages :: HasCallStack => Env es1 -> Env es2 -> IO () +requireMatchingStorages es1 es2 + | envStorage es1 /= envStorage es2 = error + $ "Env and LocalEnv point to different Storages.\n" + ++ "If you passed LocalEnv to a different thread and tried to create an " + ++ "unlifting function there, it's not allowed. You need to create it in " + ++ "the thread of the effect handler." + | otherwise = pure () + -- $setup -- >>> import Control.Concurrent (ThreadId, forkIOWithUnmask) +-- >>> import Control.Monad.IO.Class -- >>> import Effectful.Reader.Static 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: 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,7 +1,8 @@ -- | The dynamically dispatched variant of the 'Error' effect. -- --- /Note:/ unless you plan to change interpretations at runtime, it's --- recommended to use the statically dispatched variant, +-- /Note:/ unless you plan to change interpretations at runtime or you need the +-- t'Control.Monad.Except.MonadError' instance for compatibility with existing +-- code, it's recommended to use the statically dispatched variant, -- i.e. "Effectful.Error.Static". module Effectful.Error.Dynamic ( -- * Effect @@ -9,10 +10,14 @@ -- ** Handlers , runError + , runErrorWith , runErrorNoCallStack + , runErrorNoCallStackWith -- ** Operations + , throwErrorWith , throwError + , throwError_ , catchError , handleError , tryError @@ -28,38 +33,85 @@ import Effectful import Effectful.Dispatch.Dynamic -import qualified Effectful.Error.Static as E - --- | Provide the ability to handle errors of type @e@. -data Error e :: Effect where - ThrowError :: e -> Error e m a - CatchError :: m a -> (E.CallStack -> e -> m a) -> Error e m a - -type instance DispatchOf (Error e) = Dynamic +import Effectful.Error.Static qualified as E +import Effectful.Internal.MTL (Error(..)) -- | Handle errors of type @e@ (via "Effectful.Error.Static"). runError - :: Eff (Error e : es) a + :: HasCallStack + => Eff (Error e : es) a -> Eff es (Either (E.CallStack, e) a) runError = reinterpret E.runError $ \env -> \case - ThrowError e -> E.throwError e + ThrowErrorWith display e -> E.throwErrorWith display e CatchError m h -> localSeqUnlift env $ \unlift -> do E.catchError (unlift m) (\cs -> unlift . h cs) +-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific +-- error handler. +-- +-- @since 2.3.0.0 +runErrorWith + :: HasCallStack + => (E.CallStack -> e -> Eff es a) + -- ^ The error handler. + -> Eff (Error e : es) a + -> Eff es a +runErrorWith handler m = runError m >>= \case + Left (cs, e) -> handler cs e + Right a -> pure a + -- | Handle errors of type @e@ (via "Effectful.Error.Static"). In case of an -- error discard the 'E.CallStack'. +-- +-- @since 2.3.0.0 runErrorNoCallStack - :: Eff (Error e : es) a + :: HasCallStack + => Eff (Error e : es) a -> Eff es (Either e a) runErrorNoCallStack = fmap (either (Left . snd) Right) . runError --- | Throw an error of type @e@. +-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific +-- error handler. In case of an error discard the 'CallStack'. +runErrorNoCallStackWith + :: HasCallStack + => (e -> Eff es a) + -- ^ The error handler. + -> Eff (Error e : es) a + -> Eff es a +runErrorNoCallStackWith handler m = runErrorNoCallStack m >>= \case + Left e -> handler e + Right a -> pure a + +-- | Throw an error of type @e@ and specify a display function in case a +-- third-party code catches the internal exception and 'show's it. +-- +-- @since 2.4.0.0 +throwErrorWith + :: (HasCallStack, Error e :> es) + => (e -> String) + -- ^ The display function. + -> e + -- ^ The error. + -> Eff es a +throwErrorWith display = withFrozenCallStack send . ThrowErrorWith display + +-- | Throw an error of type @e@ with 'show' as a display function. throwError + :: (HasCallStack, Error e :> es, Show e) + => e + -- ^ The error. + -> Eff es a +throwError = withFrozenCallStack throwErrorWith show + +-- | Throw an error of type @e@ with no display function. +-- +-- @since 2.4.0.0 +throwError_ :: (HasCallStack, Error e :> es) => e -- ^ The error. -> Eff es a -throwError e = withFrozenCallStack $ send (ThrowError e) +throwError_ = withFrozenCallStack throwErrorWith (const "") -- | Handle an error of type @e@. catchError @@ -74,7 +126,7 @@ -- | The same as @'flip' 'catchError'@, which is useful in situations where the -- code for the handler is shorter. handleError - :: Error e :> es + :: (HasCallStack, Error e :> es) => (E.CallStack -> e -> Eff es a) -- ^ A handler for errors in the inner computation. -> Eff es a 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,21 @@ -- -- /Hint:/ if you'd like to reproduce the transactional behavior with the -- t'Effectful.State.Static.Local.State' effect, appropriate usage of --- 'Control.Monad.Catch.bracketOnError' will do the trick. +-- 'Effectful.Exception.bracketOnError' will do the trick. module Effectful.Error.Static ( -- * Effect Error -- ** Handlers , runError + , runErrorWith , runErrorNoCallStack + , runErrorNoCallStackWith -- ** Operations + , throwErrorWith , throwError + , throwError_ , catchError , handleError , tryError @@ -96,17 +100,16 @@ , prettyCallStack ) where -import Control.Exception -import Data.Unique +import Data.Kind import GHC.Stack import Effectful import Effectful.Dispatch.Static -import Effectful.Dispatch.Static.Primitive +import Effectful.Exception import Effectful.Internal.Utils -- | Provide the ability to handle errors of type @e@. -data Error e :: Effect +data Error (e :: Type) :: Effect type instance DispatchOf (Error e) = Static NoSideEffects newtype instance StaticRep (Error e) = Error ErrorId @@ -114,54 +117,98 @@ -- | Handle errors of type @e@. runError :: forall e es a - . Eff (Error e : es) a + . HasCallStack + => Eff (Error e : es) a -> Eff es (Either (CallStack, e) a) -runError m = unsafeEff $ \es0 -> mask $ \unmask -> do - eid <- newErrorId - es <- consEnv (Error @e eid) dummyRelinker es0 - r <- tryErrorIO unmask eid es `onException` unconsEnv es - unconsEnv es - pure r - where - tryErrorIO unmask eid es = try (unmask $ unEff m es) >>= \case - Right a -> pure $ Right a - Left ex -> tryHandler ex eid (\cs e -> Left (cs, e)) - $ throwIO ex +runError action = do + eid <- unsafeEff_ newErrorId + evalStaticRep (Error @e eid) $ do + tryJust (matchError eid) action +-- | Handle errors of type @e@ with a specific error handler. +-- +-- @since 2.3.0.0 +runErrorWith + :: HasCallStack + => (CallStack -> e -> Eff es a) + -- ^ The error handler. + -> Eff (Error e : es) a + -> Eff es a +runErrorWith handler action = runError action >>= \case + Left (cs, e) -> handler cs e + Right a -> pure a + -- | Handle errors of type @e@. In case of an error discard the 'CallStack'. +-- +-- @since 2.3.0.0 runErrorNoCallStack :: forall e es a - . Eff (Error e : es) a + . HasCallStack + => Eff (Error e : es) a -> Eff es (Either e a) runErrorNoCallStack = fmap (either (Left . snd) Right) . runError --- | Throw an error of type @e@. +-- | Handle errors of type @e@ with a specific error handler. In case of an +-- error discard the 'CallStack'. +runErrorNoCallStackWith + :: HasCallStack + => (e -> Eff es a) + -- ^ The error handler. + -> Eff (Error e : es) a + -> Eff es a +runErrorNoCallStackWith handler action = runErrorNoCallStack action >>= \case + Left e -> handler e + Right a -> pure a + +-- | Throw an error of type @e@ and specify a display function in case a +-- third-party code catches the internal exception and 'show's it. +-- +-- @since 2.4.0.0 +throwErrorWith + :: forall e es a. (HasCallStack, Error e :> es) + => (e -> String) + -- ^ The display function. + -> e + -- ^ The error. + -> Eff es a +throwErrorWith display e = do + Error eid <- getStaticRep @(Error e) + withFrozenCallStack throwIO $ ErrorWrapper eid callStack (display e) (toAny e) + +-- | Throw an error of type @e@ with 'show' as a display function. throwError + :: forall e es a. (HasCallStack, Error e :> es, Show e) + => e + -- ^ The error. + -> Eff es a +throwError = withFrozenCallStack throwErrorWith show + +-- | Throw an error of type @e@ with no display function. +-- +-- @since 2.4.0.0 +throwError_ :: forall e es a. (HasCallStack, Error e :> es) => e -- ^ The error. -> Eff es a -throwError e = unsafeEff $ \es -> do - Error eid <- getEnv @(Error e) es - throwIO $ ErrorWrapper eid callStack (toAny e) +throwError_ = withFrozenCallStack throwErrorWith (const "") -- | Handle an error of type @e@. catchError - :: forall e es a. Error e :> es + :: forall e es a. (HasCallStack, Error e :> es) => Eff es a -- ^ The inner computation. -> (CallStack -> e -> Eff es a) -- ^ A handler for errors in the inner computation. -> Eff es a -catchError m handler = unsafeEff $ \es -> do - Error eid <- getEnv @(Error e) es - catchErrorIO eid (unEff m es) $ \cs e -> do - unEff (handler cs e) es +catchError action handler = do + Error eid <- getStaticRep @(Error e) + catchJust (matchError eid) action $ \(cs, e) -> handler cs e -- | The same as @'flip' 'catchError'@, which is useful in situations where the -- code for the handler is shorter. handleError - :: forall e es a. Error e :> es + :: forall e es a. (HasCallStack, Error e :> es) => (CallStack -> e -> Eff es a) -- ^ A handler for errors in the inner computation. -> Eff es a @@ -172,49 +219,40 @@ -- | Similar to 'catchError', but returns an 'Either' result which is a 'Right' -- if no error was thrown and a 'Left' otherwise. tryError - :: forall e es a. Error e :> es + :: forall e es a. (HasCallStack, Error e :> es) => Eff es a -- ^ The inner computation. -> Eff es (Either (CallStack, e) a) -tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e) +tryError action = do + Error eid <- getStaticRep @(Error e) + tryJust (matchError eid) action ---------------------------------------- -- Helpers newtype ErrorId = ErrorId Unique - deriving Eq + deriving newtype Eq -- | A unique is picked so that distinct 'Error' handlers for the same type -- don't catch each other's exceptions. newErrorId :: IO ErrorId newErrorId = ErrorId <$> newUnique -tryHandler - :: SomeException - -> ErrorId - -> (CallStack -> e -> r) - -> IO r - -> IO r -tryHandler ex eid0 handler next = case fromException ex of - Just (ErrorWrapper eid cs e) - | eid0 == eid -> pure $ handler cs (fromAny e) - | otherwise -> next - Nothing -> next +data ErrorWrapper = ErrorWrapper !ErrorId CallStack String Any -data ErrorWrapper = ErrorWrapper !ErrorId CallStack Any instance Show ErrorWrapper where - showsPrec p (ErrorWrapper _ cs _) - = ("Effectful.Error.Static.ErrorWrapper\n\n" ++) - . ("If you see this, most likely there is a stray 'Async' action that\n" ++) - . ("outlived the scope of the 'Error' effect, was interacted with and threw\n" ++) - . ("an error to the parent thread. If that scenario sounds unlikely, please\n" ++) - . ("file a ticket at https://github.com/haskell-effectful/effectful/issues.\n\n" ++) - . showsPrec p (prettyCallStack cs) -instance Exception ErrorWrapper + showsPrec _ (ErrorWrapper _ cs errRep _) + = ("Effectful.Error.Static.ErrorWrapper: " ++) + . (errRep ++) + . ("\n" ++) + . (prettyCallStack cs ++) -catchErrorIO :: ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a -catchErrorIO eid m handler = do - m `catch` \err@(ErrorWrapper etag cs e) -> do - if eid == etag - then handler cs (fromAny e) - else throwIO err +instance Exception ErrorWrapper where + -- See discussion in https://github.com/haskell-effectful/effectful/pull/232. + toException = asyncExceptionToException + fromException = asyncExceptionFromException + +matchError :: ErrorId -> ErrorWrapper -> Maybe (CallStack, e) +matchError eid (ErrorWrapper etag cs _ e) + | eid == etag = Just (cs, fromAny e) + | otherwise = Nothing 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,644 @@ +{-# LANGUAGE CPP #-} +-- | Support for runtime exceptions. +-- +-- This module supplies thin wrappers over functions from "Control.Exception" as +-- well as several utility functions for convenience. +-- +-- /Note:/ the 'Eff' monad provides instances for 'C.MonadThrow', 'C.MonadCatch' +-- and 'C.MonadMask', so any existing code that uses them remains compatible. +module Effectful.Exception + ( -- * Throwing + throwIO +#if MIN_VERSION_base(4,21,0) + , rethrowIO +#endif + + -- * Catching (with recovery) + -- $catchAll + , catch +#if MIN_VERSION_base(4,21,0) + , catchNoPropagate +#endif + , catchDeep + , catchJust + , catchIf + , catchIO + , catchSync + , catchSyncDeep + + , handle + , handleDeep + , handleJust + , handleIf + , handleIO + , handleSync + , handleSyncDeep + + , try +#if MIN_VERSION_base(4,21,0) + , tryWithContext +#endif + , tryDeep + , tryJust + , tryIf + , tryIO + , trySync + , trySyncDeep + + , C.Handler(..) + , catches + , catchesDeep + + -- | #cleanup# + + -- * Cleanup (no recovery) + , bracket + , bracket_ + , bracketOnError + , generalBracket + , C.ExitCase(..) + , finally + , onException + , withException + + -- * Utils + + -- ** Evaluation + , evaluate + , evaluateDeep + +#if MIN_VERSION_base(4,20,0) + -- ** Annotations + , annotateIO +#endif + + -- | #checkExceptionType# + + -- ** Check exception type + -- $syncVsAsync + , isSyncException + , isAsyncException + + -- * Low-level API + , mask + , mask_ + , uninterruptibleMask + , uninterruptibleMask_ + , E.MaskingState(..) + , getMaskingState + , interruptible + , allowInterrupt + + -- * Re-exports from "Control.Exception" + + -- ** The 'SomeException' type + , E.SomeException(..) + + -- ** The 'Exception' class + , E.Exception(..) + , E.mapException + +#if MIN_VERSION_base(4,20,0) + -- ** Exception context and annotation + , E.addExceptionContext + , E.someExceptionContext + , E.ExceptionWithContext(..) +#if MIN_VERSION_base(4,21,0) + , E.WhileHandling(..) +#endif + , E.ExceptionContext(..) + , E.emptyExceptionContext + , E.addExceptionAnnotation + , E.getExceptionAnnotations + , E.getAllExceptionAnnotations + , E.displayExceptionContext + , E.SomeExceptionAnnotation(..) + , E.ExceptionAnnotation(..) +#endif + + -- ** Concrete exception types + , E.IOException + , E.ArithException(..) + , E.ArrayException(..) + , E.AssertionFailed(..) + , E.NoMethodError(..) + , E.PatternMatchFail(..) + , E.RecConError(..) + , E.RecSelError(..) + , E.RecUpdError(..) + , E.ErrorCall(..) + , E.TypeError(..) + + -- ** Asynchronous exceptions + , E.SomeAsyncException(..) + , E.AsyncException(..) + , E.asyncExceptionToException + , E.asyncExceptionFromException + , E.NonTermination(..) + , E.NestedAtomically(..) + , E.BlockedIndefinitelyOnMVar(..) + , E.BlockedIndefinitelyOnSTM(..) + , E.AllocationLimitExceeded(..) + , E.CompactionFailed(..) + , E.Deadlock(..) + + -- ** Assertions + , E.assert + ) where + +#if MIN_VERSION_base(4,20,0) +import Control.Exception.Annotation qualified as E +import Control.Exception.Context qualified as E +#endif + +import Control.DeepSeq +import Control.Exception qualified as E +import Control.Monad.Catch qualified as C +import GHC.Stack (withFrozenCallStack) + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Unsafe + +---------------------------------------- +-- Throwing + +-- | Lifted 'E.throwIO'. +throwIO + :: (HasCallStack, E.Exception e) + => e + -- ^ The error. + -> Eff es a +throwIO = unsafeEff_ . withFrozenCallStack E.throwIO + +#if MIN_VERSION_base(4,21,0) +-- | Lifted 'E.rethrowIO'. +rethrowIO + :: E.Exception e + => E.ExceptionWithContext e + -> Eff es a +rethrowIO = unsafeEff_ . E.rethrowIO +#endif + +---------------------------------------- +-- Catching + +-- $catchAll +-- +-- /Note:/ __do not use 'catch', 'handle' or 'try' to catch 'E.SomeException'__ +-- unless you're really sure you want to catch __all__ exceptions (including +-- asynchronous ones). Instead: +-- +-- - If you want to catch all exceptions, run a cleanup action and rethrow, use +-- one of the functions from the [cleanup](#cleanup) section. +-- +-- - If you want to catch all synchronous exceptions, use 'catchSync', +-- 'handleSync' or 'trySync'. + +-- | Lifted 'E.catch'. +catch + :: E.Exception e + => Eff es a + -> (e -> Eff es a) + -- ^ The exception handler. + -> Eff es a +catch action handler = reallyUnsafeUnliftIO $ \unlift -> do + E.catch (unlift action) (unlift . handler) + +-- | A variant of 'catch' that fully forces evaluation of the result value to +-- find all impure exceptions. +catchDeep + :: (E.Exception e, NFData a) + => Eff es a + -> (e -> Eff es a) + -- ^ The exception handler. + -> Eff es a +catchDeep action = catch (evaluateDeep =<< action) + +#if MIN_VERSION_base(4,21,0) +-- | Lifted 'E.catchNoPropagate'. +catchNoPropagate + :: E.Exception e + => Eff es a + -> (E.ExceptionWithContext e -> Eff es a) + -- ^ The exception handler. + -> Eff es a +catchNoPropagate action handler = reallyUnsafeUnliftIO $ \unlift -> do + E.catchNoPropagate (unlift action) (unlift . handler) +#endif + +-- | Lifted 'E.catchJust'. +catchJust + :: E.Exception e + => (e -> Maybe b) + -- ^ The predicate. + -> Eff es a + -> (b -> Eff es a) + -- ^ The exception handler. + -> Eff es a +catchJust f action handler = reallyUnsafeUnliftIO $ \unlift -> do + E.catchJust f (unlift action) (unlift . handler) + +-- | Catch an exception only if it satisfies a specific predicate. +catchIf + :: E.Exception e + => (e -> Bool) + -- ^ The predicate. + -> Eff es a + -> (e -> Eff es a) + -- ^ The exception handler. + -> Eff es a +catchIf p = catchJust (\e -> if p e then Just e else Nothing) + +-- | 'catch' specialized to catch 'IOException'. +catchIO + :: Eff es a + -> (E.IOException -> Eff es a) + -- ^ The exception handler. + -> Eff es a +catchIO = catch + +-- | 'catch' specialized to catch all exceptions considered to be synchronous. +-- +-- @'catchSync' ≡ 'catchIf' \@'E.SomeException' 'isSyncException'@ +-- +-- See the [check exception type](#checkExceptionType) section for more +-- information. +catchSync + :: Eff es a + -> (E.SomeException -> Eff es a) + -- ^ The exception handler. + -> Eff es a +catchSync = catchIf @E.SomeException isSyncException + +-- | A variant of 'catchSync' that fully forces evaluation of the result value +-- to find all impure exceptions. +catchSyncDeep + :: NFData a + => Eff es a + -> (E.SomeException -> Eff es a) + -- ^ The exception handler. + -> Eff es a +catchSyncDeep action = catchSync (evaluateDeep =<< action) + +-- | Flipped version of 'catch'. +handle + :: E.Exception e + => (e -> Eff es a) + -- ^ The exception handler. + -> Eff es a + -> Eff es a +handle = flip catch + +-- | Flipped version of 'catchDeep'. +handleDeep + :: (E.Exception e, NFData a) + => (e -> Eff es a) + -- ^ The exception handler. + -> Eff es a + -> Eff es a +handleDeep = flip catchDeep + +-- | Flipped version of 'catchJust'. +handleJust + :: (HasCallStack, E.Exception e) + => (e -> Maybe b) + -- ^ The predicate. + -> (b -> Eff es a) + -- ^ The exception handler. + -> Eff es a + -> Eff es a +handleJust f = flip (catchJust f) + +-- | Flipped version of 'catchIf'. +handleIf + :: E.Exception e + => (e -> Bool) + -- ^ The predicate. + -> (e -> Eff es a) + -- ^ The exception handler. + -> Eff es a + -> Eff es a +handleIf p = flip (catchIf p) + +-- | Flipped version of 'catchIO'. +handleIO + :: (E.IOException -> Eff es a) + -- ^ The exception handler. + -> Eff es a + -> Eff es a +handleIO = flip catchIO + +-- | Flipped version of 'catchSync'. +handleSync + :: (E.SomeException -> Eff es a) + -- ^ The exception handler. + -> Eff es a + -> Eff es a +handleSync = flip catchSync + +-- | Flipped version of 'catchSyncDeep'. +handleSyncDeep + :: NFData a + => (E.SomeException -> Eff es a) + -- ^ The exception handler. + -> Eff es a + -> Eff es a +handleSyncDeep = flip catchSyncDeep + +-- | Lifted 'E.try'. +try + :: E.Exception e + => Eff es a + -- ^ The action. + -> Eff es (Either e a) +try action = reallyUnsafeUnliftIO $ \unlift -> do + E.try (unlift action) + +#if MIN_VERSION_base(4,21,0) +-- | Lifted 'E.tryWithContext'. +tryWithContext + :: E.Exception e + => Eff es a + -> Eff es (Either (E.ExceptionWithContext e) a) +tryWithContext action = reallyUnsafeUnliftIO $ \unlift -> do + E.tryWithContext (unlift action) +#endif + +-- | A variant of 'try' that fully forces evaluation of the result value to find +-- all impure exceptions. +tryDeep + :: (E.Exception e, NFData a) + => Eff es a + -- ^ The action. + -> Eff es (Either e a) +tryDeep action = try (evaluateDeep =<< action) + +-- | Lifted 'E.tryJust'. +tryJust + :: E.Exception e + => (e -> Maybe b) + -- ^ The predicate. + -> Eff es a + -> Eff es (Either b a) +tryJust f action = reallyUnsafeUnliftIO $ \unlift -> do + E.tryJust f (unlift action) + +-- | Catch an exception only if it satisfies a specific predicate. +tryIf + :: E.Exception e + => (e -> Bool) + -- ^ The predicate. + -> Eff es a + -> Eff es (Either e a) +tryIf p = tryJust (\e -> if p e then Just e else Nothing) + +-- | 'try' specialized to catch 'IOException'. +tryIO + :: Eff es a + -- ^ The action. + -> Eff es (Either E.IOException a) +tryIO = try + +-- | 'try' specialized to catch all exceptions considered to be synchronous. +-- +-- @'trySync' ≡ 'tryIf' \@'E.SomeException' 'isSyncException'@ +-- +-- See the [check exception type](#checkExceptionType) section for more +-- information. +trySync + :: Eff es a + -- ^ The action. + -> Eff es (Either E.SomeException a) +trySync = tryIf @E.SomeException isSyncException + +-- | A variant of 'trySync' that fully forces evaluation of the result value to +-- find all impure exceptions. +trySyncDeep + :: NFData a + => Eff es a + -- ^ The action. + -> Eff es (Either E.SomeException a) +trySyncDeep action = trySync (evaluateDeep =<< action) + +-- | Lifted 'E.catches'. +catches + :: Eff es a + -> [C.Handler (Eff es) a] + -- ^ The exception handlers. + -> Eff es a +catches action handlers = reallyUnsafeUnliftIO $ \unlift -> do + let unliftHandler (C.Handler handler) = E.Handler (unlift . handler) + E.catches (unlift action) (map unliftHandler handlers) + +-- | A variant of 'catches' that fully forces evaluation of the result value to +-- find all impure exceptions. +catchesDeep + :: NFData a + => Eff es a + -> [C.Handler (Eff es) a] + -- ^ The exception handlers. + -> Eff es a +catchesDeep action = catches (evaluateDeep =<< action) + +---------------------------------------- +-- Cleanup + +-- | Lifted 'E.bracket'. +bracket + :: Eff es a + -- ^ Computation to run first. + -> (a -> Eff es b) + -- ^ Computation to run last. + -> (a -> Eff es c) + -- ^ Computation to run in-between. + -> Eff es c +bracket before after action = reallyUnsafeUnliftIO $ \unlift -> do + E.bracket (unlift before) (unlift . after) (unlift . action) + +-- | Lifted 'E.bracket_'. +bracket_ + :: Eff es a + -- ^ Computation to run first. + -> Eff es b + -- ^ Computation to run last. + -> Eff es c + -- ^ Computation to run in-between. + -> Eff es c +bracket_ before after action = reallyUnsafeUnliftIO $ \unlift -> do + E.bracket_ (unlift before) (unlift after) (unlift action) + +-- | Lifted 'E.bracketOnError'. +bracketOnError + :: Eff es a + -- ^ Computation to run first. + -> (a -> Eff es b) + -- ^ Computation to run last when an exception or + -- t'Effectful.Error.Static.Error' was thrown. + -> (a -> Eff es c) + -- ^ Computation to run in-between. + -> Eff es c +bracketOnError before after action = reallyUnsafeUnliftIO $ \unlift -> do + E.bracketOnError (unlift before) (unlift . after) (unlift . action) + +-- | Generalization of 'bracket'. +-- +-- See 'C.generalBracket' for more information. +generalBracket + :: Eff es a + -- ^ Computation to run first. + -> (a -> C.ExitCase c -> Eff es b) + -- ^ Computation to run last. + -> (a -> Eff es c) + -- ^ Computation to run in-between. + -> Eff es (c, b) +generalBracket = C.generalBracket + +-- | Lifted 'E.finally'. +finally + :: Eff es a + -> Eff es b + -- ^ Computation to run last. + -> Eff es a +finally action handler = reallyUnsafeUnliftIO $ \unlift -> do + E.finally (unlift action) (unlift handler) + +-- | Lifted 'E.onException'. +onException + :: Eff es a + -> Eff es b + -- ^ Computation to run last when an exception or + -- t'Effectful.Error.Static.Error' was thrown. + -> Eff es a +onException action handler = reallyUnsafeUnliftIO $ \unlift -> do + E.onException (unlift action) (unlift handler) + +-- | A variant of 'onException' that gives access to the exception. +-- +-- @since 2.6.0.0 +withException + :: E.Exception e + => Eff es a + -> (e -> Eff es b) + -- ^ Computation to run last when an exception or + -- t'Effectful.Error.Static.Error' was thrown. + -> Eff es a +withException action cleanup = do +#if MIN_VERSION_base(4,21,0) + action `catchNoPropagate` \ec@(E.ExceptionWithContext _ e) -> do + _ <- annotateIO (E.WhileHandling (E.toException ec)) (cleanup e) + rethrowIO ec +#else + action `catch` \e -> do + _ <- cleanup e + throwIO e +#endif + +---------------------------------------- +-- Utils + +-- | Lifted 'E.evaluate'. +evaluate :: a -> Eff es a +evaluate = unsafeEff_ . E.evaluate + +-- | Deeply evaluate a value using 'evaluate' and 'NFData'. +evaluateDeep :: NFData a => a -> Eff es a +evaluateDeep = unsafeEff_ . E.evaluate . force + +#if MIN_VERSION_base(4,20,0) +-- | Lifted 'E.annotateIO'. +annotateIO :: E.ExceptionAnnotation e => e -> Eff es a -> Eff es a +annotateIO e action = reallyUnsafeUnliftIO $ \unlift -> do + E.annotateIO e (unlift action) +#endif + +---------------------------------------- +-- Check exception type + +-- $syncVsAsync +-- +-- /Note:/ there's no way to determine whether an exception was thrown +-- synchronously or asynchronously, so these functions rely on a +-- heuristic. Namely, an exception type is determined by its 'E.Exception' +-- instance. +-- +-- Exception types with the default 'E.Exception' instance are considered +-- synchronous: +-- +-- >>> data SyncEx = SyncEx deriving (Show) +-- >>> instance Exception SyncEx +-- +-- >>> isSyncException SyncEx +-- True +-- +-- >>> isAsyncException SyncEx +-- False +-- +-- Whereas for asynchronous exceptions you need to define their 'E.Exception' +-- instance as follows: +-- +-- >>> data AsyncEx = AsyncEx deriving (Show) +-- >>> :{ +-- instance Exception AsyncEx where +-- toException = asyncExceptionToException +-- fromException = asyncExceptionFromException +-- :} +-- +-- >>> isSyncException AsyncEx +-- False +-- +-- >>> isAsyncException AsyncEx +-- True + +-- | Check if the given exception is considered synchronous. +isSyncException :: E.Exception e => e -> Bool +isSyncException e = case E.fromException (E.toException e) of + Just E.SomeAsyncException{} -> False + Nothing -> True + +-- | Check if the given exception is considered asynchronous. +isAsyncException :: E.Exception e => e -> Bool +isAsyncException e = case E.fromException (E.toException e) of + Just E.SomeAsyncException{} -> True + Nothing -> False + +---------------------------------------- +-- Low-level API + +-- | Lifted 'E.mask'. +mask :: ((forall r. Eff es r -> Eff es r) -> Eff es a) -> Eff es a +mask k = reallyUnsafeUnliftIO $ \unlift -> do + E.mask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release) + +-- | Lifted 'E.mask_'. +mask_ :: Eff es a -> Eff es a +mask_ action = reallyUnsafeUnliftIO $ \unlift -> do + E.mask_ (unlift action) + +-- | Lifted 'E.uninterruptibleMask'. +uninterruptibleMask :: ((forall r. Eff es r -> Eff es r) -> Eff es a) -> Eff es a +uninterruptibleMask k = reallyUnsafeUnliftIO $ \unlift -> do + E.uninterruptibleMask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release) + +-- | Lifted 'E.uninterruptibleMask_'. +uninterruptibleMask_ :: Eff es a -> Eff es a +uninterruptibleMask_ action = reallyUnsafeUnliftIO $ \unlift -> do + E.uninterruptibleMask_ (unlift action) + +-- | Lifted 'E.getMaskingState'. +getMaskingState :: Eff es E.MaskingState +getMaskingState = unsafeEff_ E.getMaskingState + +-- | Lifted 'E.interruptible'. +interruptible :: Eff es a -> Eff es a +interruptible action = reallyUnsafeUnliftIO $ \unlift -> do + E.interruptible (unlift action) + +-- | Lifted 'E.allowInterrupt'. +allowInterrupt :: Eff es () +allowInterrupt = unsafeEff_ E.allowInterrupt + +-- $setup +-- >>> import Control.Exception (Exception) +-- >>> import Control.Exception (asyncExceptionFromException) +-- >>> import Control.Exception (asyncExceptionToException) 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/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,11 @@ , (:>)(..) , (:>>) , Subset(..) + , KnownSubset + , KnownPrefix(..) + , IsUnknownSuffixOf + , type (++) + , KnownEffects(..) -- * Re-exports , Type @@ -38,8 +42,9 @@ -- /Note:/ GHC is kind enough to cache these values as they're top level CAFs, -- so the lookup is amortized @O(1)@ without any language level tricks. reifyIndex :: Int - reifyIndex = -- Don't show "minimal complete definition" in haddock. - error "unimplemented" + reifyIndex = + -- Don't show "minimal complete definition" in haddock. + error "reifyIndex" instance TypeError ( Text "There is no handler for '" :<>: ShowType e :<>: Text "' in the context" @@ -61,17 +66,84 @@ type family xs :>> es :: Constraint where '[] :>> es = () (x : xs) :>> es = (x :> es, xs :>> es) +{-# DEPRECATED (:>>) "Usage of (:>>) slows down GHC too much. See https://github.com/haskell-effectful/effectful/issues/52#issuecomment-1269155485 for more information." #-} ---------------------------------------- --- | Provide evidence that @xs@ is a subset of @es@. -class Subset (xs :: [Effect]) (es :: [Effect]) where +-- | Provide evidence that @subEs@ is a subset of @es@. +class KnownPrefix es => Subset (subEs :: [Effect]) (es :: [Effect]) where + subsetFullyKnown :: Bool + subsetFullyKnown = + -- Don't show "minimal complete definition" in haddock. + error "subsetFullyKnown" + reifyIndices :: [Int] - reifyIndices = -- Don't show "minimal complete definition" in haddock. - error "unimplemented" + reifyIndices = + -- Don't show "minimal complete definition" in haddock. + error "reifyIndices" -instance Subset '[] es where +-- If the subset is not fully known, make sure the subset and the base stack +-- have the same unknown suffix. +instance {-# INCOHERENT #-} + ( KnownPrefix es + , subEs `IsUnknownSuffixOf` es + ) => Subset subEs es where + subsetFullyKnown = False reifyIndices = [] -instance (e :> es, Subset xs es) => Subset (e : xs) es where - reifyIndices = reifyIndex @e @es : reifyIndices @xs @es +-- If the subset is fully known, we're done. +instance KnownPrefix es => Subset '[] es where + subsetFullyKnown = True + reifyIndices = [] + +instance (e :> es, Subset subEs es) => Subset (e : subEs) es where + subsetFullyKnown = subsetFullyKnown @subEs @es + reifyIndices = reifyIndex @e @es : reifyIndices @subEs @es + +---- + +-- | Provide evidence that @subEs@ is a known subset of @es@. +class Subset subEs es => KnownSubset (subEs :: [Effect]) (es :: [Effect]) +instance KnownSubset '[] es +instance (e :> es, KnownSubset subEs es) => KnownSubset (e : subEs) es + +---- + +-- | Calculate length of a statically known prefix of @es@. +class KnownPrefix (es :: [Effect]) where + prefixLength :: Int + +instance KnownPrefix es => KnownPrefix (e : es) where + prefixLength = 1 + prefixLength @es + +instance {-# INCOHERENT #-} KnownPrefix es where + prefixLength = 0 + +---- + +-- | Require that @subEs@ is the unknown suffix of @es@. +class (subEs :: [Effect]) `IsUnknownSuffixOf` (es :: [Effect]) +instance {-# INCOHERENT #-} subEs ~ es => subEs `IsUnknownSuffixOf` es +instance subEs `IsUnknownSuffixOf` es => subEs `IsUnknownSuffixOf` (e : es) + +---- + +-- | Append two type-level lists together. +type family (xs :: [Effect]) ++ (ys :: [Effect]) :: [Effect] where + '[] ++ ys = ys + (x : xs) ++ ys = x : xs ++ ys + +infixr 5 ++ + +-- | Calculate length of a list of known effects. +class KnownEffects (es :: [Effect]) where + knownEffectsLength :: Int + knownEffectsLength = + -- Don't show "minimal complete definition" in haddock. + error "knownEffectsLength" + +instance KnownEffects es => KnownEffects (e : es) where + knownEffectsLength = 1 + knownEffectsLength @es + +instance KnownEffects '[] where + knownEffectsLength = 0 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,28 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} module Effectful.Internal.Env ( -- * The environment Env(..) + , Ref(..) + , Version , Storage(..) + -- ** StorageData + , StorageData(..) + , copyStorageData + , restoreStorageData + + -- *** Utils + , AnyRelinker + , toAnyRelinker + , fromAnyRelinker + , AnyEffect + , toAnyEffect + , fromAnyEffect + -- ** Relinker , Relinker(..) , dummyRelinker @@ -38,10 +56,12 @@ import Control.Monad import Control.Monad.Primitive -import Data.IORef +import Data.IORef.Strict import Data.Primitive.PrimArray import Data.Primitive.SmallArray -import GHC.Stack (HasCallStack) +import Data.Primitive.Types +import GHC.Exts ((*#), (+#)) +import GHC.Stack import Effectful.Internal.Effect import Effectful.Internal.Utils @@ -73,27 +93,128 @@ -- data Env (es :: [Effect]) = Env { envOffset :: !Int - , envRefs :: !(PrimArray Int) - , envStorage :: !(IORef Storage) + , envRefs :: !(PrimArray Ref) + , envStorage :: !(IORef' Storage) } +-- | Reference to the effect in 'Storage'. +data Ref = Ref !Int !Version + +instance Prim Ref where + sizeOf# _ = 2# *# sizeOf# (undefined :: Int) + alignment# _ = alignment# (undefined :: Int) + indexByteArray# arr i = + let n = 2# *# i + ref = indexByteArray# arr n + version = indexByteArray# arr (n +# 1#) + in Ref ref version + readByteArray# arr i s0 = + let n = 2# *# i + !(# s1, ref #) = readByteArray# arr n s0 + !(# s2, version #) = readByteArray# arr (n +# 1#) s1 + in (# s2, Ref ref version #) + writeByteArray# arr i (Ref ref version) s0 = + let n = 2# *# i + s1 = writeByteArray# arr n ref s0 + s2 = writeByteArray# arr (n +# 1#) version s1 + in s2 + setByteArray# = defaultSetByteArray# + indexOffAddr# addr i = + let n = 2# *# i + ref = indexOffAddr# addr n + version = indexOffAddr# addr (n +# 1#) + in Ref ref version + readOffAddr# addr i s0 = + let n = 2# *# i + !(# s1, ref #) = readOffAddr# addr n s0 + !(# s2, version #) = readOffAddr# addr (n +# 1#) s1 + in (# s2, Ref ref version #) + writeOffAddr# addr i (Ref ref version) s0 = + let n = 2# *# i + s1 = writeOffAddr# addr n ref s0 + s2 = writeOffAddr# addr (n +# 1#) version s1 + in s2 + setOffAddr# = defaultSetOffAddr# + +-- | Version of the effect. +newtype Version = Version Int + deriving newtype (Eq, Ord, Prim, Show) + -- | A storage of effects. data Storage = Storage - { stSize :: !Int - , stVersion :: !Int - , stVersions :: !(MutablePrimArray RealWorld Int) - , stEffects :: !(SmallMutableArray RealWorld Any) - , stRelinkers :: !(SmallMutableArray RealWorld Any) + { stVersion :: !Version + , stData :: {-# UNPACK #-} !StorageData } ---------------------------------------- +-- StorageData + +-- | Effect in 'Storage'. +newtype AnyEffect = AnyEffect Any + +toAnyEffect :: EffectRep (DispatchOf e) e -> AnyEffect +toAnyEffect = AnyEffect . toAny + +fromAnyEffect :: AnyEffect -> EffectRep (DispatchOf e) e +fromAnyEffect (AnyEffect e) = fromAny e + +-- | Relinker in 'Storage'. +newtype AnyRelinker = AnyRelinker Any + +toAnyRelinker :: Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker +toAnyRelinker = AnyRelinker . toAny + +fromAnyRelinker :: AnyRelinker -> Relinker (EffectRep (DispatchOf e)) e +fromAnyRelinker (AnyRelinker f) = fromAny f + +---------------------------------------- + +data StorageData = StorageData + { sdSize :: !Int + , sdVersions :: !(MutablePrimArray RealWorld Version) + , sdEffects :: !(SmallMutableArray RealWorld AnyEffect) + , sdRelinkers :: !(SmallMutableArray RealWorld AnyRelinker) + } + +-- | Make a shallow copy of the 'StorageData'. +-- +-- @since 2.5.0.0 +copyStorageData :: HasCallStack => StorageData -> IO StorageData +copyStorageData (StorageData storageSize vs0 es0 fs0) = do + vsSize <- getSizeofMutablePrimArray vs0 + esSize <- getSizeofSmallMutableArray es0 + fsSize <- getSizeofSmallMutableArray fs0 + when (vsSize /= esSize) $ do + error $ "vsSize (" ++ show vsSize ++ ") /= esSize (" ++ show esSize ++ ")" + when (esSize /= fsSize) $ do + error $ "esSize (" ++ show esSize ++ ") /= fsSize (" ++ show fsSize ++ ")" + vs <- cloneMutablePrimArray vs0 0 vsSize + es <- cloneSmallMutableArray es0 0 esSize + fs <- cloneSmallMutableArray fs0 0 fsSize + pure $ StorageData storageSize vs es fs + +-- | Restore a shallow copy of the 'StorageData'. +-- +-- The copy needs to be from the same 'Env' as the target. +-- +-- @since 2.5.0.0 +restoreStorageData :: HasCallStack => StorageData -> Env es -> IO () +restoreStorageData newStorageData env = do + modifyIORef' (envStorage env) $ \(Storage version oldStorageData) -> + let oldSize = sdSize oldStorageData + newSize = sdSize newStorageData + in if newSize /= oldSize + then error $ "newSize (" ++ show newSize ++ ") /= oldSize (" ++ show oldSize ++ ")" + else Storage version newStorageData + +---------------------------------------- -- Relinker -- | A function for relinking 'Env' objects stored in the handlers and/or making -- a deep copy of the representation of the effect when cloning the environment. newtype Relinker :: (Effect -> Type) -> Effect -> Type where Relinker - :: ((forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e)) + :: (HasCallStack => (forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e)) -> Relinker rep e -- | A dummy 'Relinker'. @@ -124,34 +245,25 @@ -- Operations -- | Create an empty environment. -emptyEnv :: IO (Env '[]) +emptyEnv :: HasCallStack => IO (Env '[]) emptyEnv = Env 0 <$> (unsafeFreezePrimArray =<< newPrimArray 0) - <*> (newIORef =<< emptyStorage) + <*> (newIORef' =<< emptyStorage) -- | Clone the environment to use it in a different thread. -cloneEnv :: Env es -> IO (Env es) +cloneEnv :: HasCallStack => Env es -> IO (Env es) cloneEnv (Env offset refs storage0) = do - Storage storageSize version vs0 es0 fs0 <- readIORef storage0 - let vsSize = sizeofMutablePrimArray vs0 - esSize = sizeofSmallMutableArray es0 - fsSize = sizeofSmallMutableArray fs0 - when (vsSize /= esSize) $ do - error $ "vsSize (" ++ show vsSize ++ ") /= esSize (" ++ show esSize ++ ")" - when (esSize /= fsSize) $ do - error $ "esSize (" ++ show esSize ++ ") /= fsSize (" ++ show fsSize ++ ")" - vs <- cloneMutablePrimArray vs0 0 vsSize - es <- cloneSmallMutableArray es0 0 esSize - fs <- cloneSmallMutableArray fs0 0 fsSize - storage <- newIORef $ Storage storageSize version vs es fs + Storage version storageData0 <- readIORef' storage0 + storageData@(StorageData storageSize _ es fs) <- copyStorageData storageData0 + storage <- newIORef' $ Storage version storageData let relinkEffects = \case 0 -> pure () k -> do let i = k - 1 - Relinker f <- fromAny <$> readSmallArray fs i + Relinker relinker <- fromAnyRelinker <$> readSmallArray fs i readSmallArray es i - >>= f (relinkEnv storage) . fromAny - >>= writeSmallArray es i . toAny + >>= relinker (relinkEnv storage) . fromAnyEffect + >>= writeSmallArray' es i . toAnyEffect relinkEffects i relinkEffects storageSize pure $ Env offset refs storage @@ -160,30 +272,30 @@ -- | Get the current size of the environment. sizeEnv :: Env es -> IO Int sizeEnv (Env offset refs _) = do - pure $ (sizeofPrimArray refs - offset) `div` 2 + pure $ sizeofPrimArray refs - offset -- | Access the tail of the environment. tailEnv :: Env (e : es) -> IO (Env es) tailEnv (Env offset refs storage) = do - pure $ Env (offset + 2) refs storage + pure $ Env (offset + 1) refs storage ---------------------------------------- -- Extending and shrinking -- | Extend the environment with a new data type. consEnv - :: EffectRep (DispatchOf e) e + :: HasCallStack + => EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env (e : es)) consEnv e f (Env offset refs0 storage) = do let size = sizeofPrimArray refs0 - offset - mrefs <- newPrimArray (size + 2) - copyPrimArray mrefs 2 refs0 offset size - (ref, version) <- insertEffect storage e f + mrefs <- newPrimArray (size + 1) + copyPrimArray mrefs 1 refs0 offset size + ref <- insertEffect storage e f writePrimArray mrefs 0 ref - writePrimArray mrefs 1 version refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage {-# NOINLINE consEnv #-} @@ -192,7 +304,7 @@ -- -- /Note:/ after calling this function @e@ from the input environment is no -- longer usable. -unconsEnv :: Env (e : es) -> IO () +unconsEnv :: HasCallStack => Env (e : es) -> IO () unconsEnv (Env _ refs storage) = do deleteEffect storage (indexPrimArray refs 0) {-# NOINLINE unconsEnv #-} @@ -204,7 +316,7 @@ -- /Note:/ unlike in 'putEnv' the value in not changed in place, so only the new -- environment will see it. replaceEnv - :: forall e es. e :> es + :: forall e es. (HasCallStack, e :> es) => EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e @@ -214,10 +326,8 @@ let size = sizeofPrimArray refs0 - offset mrefs <- newPrimArray size copyPrimArray mrefs 0 refs0 offset size - (ref, version) <- insertEffect storage e f - let i = 2 * reifyIndex @e @es - writePrimArray mrefs i ref - writePrimArray mrefs (i + 1) version + ref <- insertEffect storage e f + writePrimArray mrefs (reifyIndex @e @es) ref refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage {-# NOINLINE replaceEnv #-} @@ -226,9 +336,9 @@ -- -- /Note:/ after calling this function the input environment is no longer -- usable. -unreplaceEnv :: forall e es. e :> es => Env es -> IO () +unreplaceEnv :: forall e es. (HasCallStack, e :> es) => Env es -> IO () unreplaceEnv (Env offset refs storage) = do - deleteEffect storage $ indexPrimArray refs (offset + 2 * reifyIndex @e @es) + deleteEffect storage $ indexPrimArray refs (offset + reifyIndex @e @es) {-# NOINLINE unreplaceEnv #-} ---------------------------------------- @@ -237,11 +347,9 @@ subsumeEnv :: forall e es. e :> es => Env es -> IO (Env (e : es)) subsumeEnv (Env offset refs0 storage) = do let size = sizeofPrimArray refs0 - offset - mrefs <- newPrimArray (size + 2) - copyPrimArray mrefs 2 refs0 offset size - let ix = offset + 2 * reifyIndex @e @es - writePrimArray mrefs 0 $ indexPrimArray refs0 ix - writePrimArray mrefs 1 $ indexPrimArray refs0 (ix + 1) + mrefs <- newPrimArray (size + 1) + copyPrimArray mrefs 1 refs0 offset size + writePrimArray mrefs 0 $ indexPrimArray refs0 (offset + reifyIndex @e @es) refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage {-# NOINLINE subsumeEnv #-} @@ -250,18 +358,22 @@ -- | Construct an environment containing a permutation (with possible -- duplicates) of a subset of effects from the input environment. -injectEnv :: forall xs es. Subset xs es => Env es -> IO (Env xs) +injectEnv :: forall subEs es. Subset subEs es => Env es -> IO (Env subEs) injectEnv (Env offset refs0 storage) = do - let xs = reifyIndices @xs @es - mrefs <- newPrimArray (2 * length xs) + let subEs = reifyIndices @subEs @es + subEsSize = length subEs + prefixSize = prefixLength @es + suffixSize = if subsetFullyKnown @subEs @es + then 0 + else sizeofPrimArray refs0 - offset - prefixSize + mrefs <- newPrimArray (subEsSize + suffixSize) + copyPrimArray mrefs subEsSize refs0 (offset + prefixSize) suffixSize let writeRefs i = \case [] -> pure () - (e : es) -> do - let ix = offset + 2 * e - writePrimArray mrefs i $ indexPrimArray refs0 ix - writePrimArray mrefs (i + 1) $ indexPrimArray refs0 (ix + 1) - writeRefs (i + 2) es - writeRefs 0 xs + (x : xs) -> do + writePrimArray mrefs i $ indexPrimArray refs0 (offset + x) + writeRefs (i + 1) xs + writeRefs 0 subEs refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage {-# NOINLINE injectEnv #-} @@ -271,129 +383,164 @@ -- | Extract a specific data type from the environment. getEnv - :: forall e es. e :> es + :: forall e es. (HasCallStack, e :> es) => Env es -- ^ The environment. -> IO (EffectRep (DispatchOf e) e) getEnv env = do (i, es) <- getLocation @e env - fromAny <$> readSmallArray es i + fromAnyEffect <$> readSmallArray es i -- | Replace the data type in the environment with a new value (in place). putEnv - :: forall e es. e :> es + :: forall e es. (HasCallStack, e :> es) => Env es -- ^ The environment. -> EffectRep (DispatchOf e) e -> IO () putEnv env e = do (i, es) <- getLocation @e env - e `seq` writeSmallArray es i (toAny e) + writeSmallArray' es i (toAnyEffect e) -- | Modify the data type in the environment and return a value (in place). stateEnv - :: forall e es a. e :> es + :: forall e es a. (HasCallStack, e :> es) => Env es -- ^ The environment. - -> (EffectRep (DispatchOf e) e -> IO (a, EffectRep (DispatchOf e) e)) + -> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e)) -> IO a stateEnv env f = do (i, es) <- getLocation @e env - (a, e) <- f . fromAny =<< readSmallArray es i - e `seq` writeSmallArray es i (toAny e) + (a, e) <- f . fromAnyEffect <$> readSmallArray es i + writeSmallArray' es i (toAnyEffect e) pure a -- | Modify the data type in the environment (in place). modifyEnv - :: forall e es. e :> es + :: forall e es. (HasCallStack, e :> es) => Env es -- ^ The environment. - -> (EffectRep (DispatchOf e) e -> IO (EffectRep (DispatchOf e) e)) + -> (EffectRep (DispatchOf e) e -> (EffectRep (DispatchOf e) e)) -> IO () modifyEnv env f = do (i, es) <- getLocation @e env - e <- f . fromAny =<< readSmallArray es i - e `seq` writeSmallArray es i (toAny e) + e <- f . fromAnyEffect <$> readSmallArray es i + writeSmallArray' es i (toAnyEffect e) -- | Determine location of the effect in the environment. getLocation - :: forall e es. e :> es + :: forall e es. (HasCallStack, e :> es) => Env es - -> IO (Int, SmallMutableArray RealWorld Any) + -> IO (Int, SmallMutableArray RealWorld AnyEffect) getLocation (Env offset refs storage) = do - let i = offset + 2 * reifyIndex @e @es - ref = indexPrimArray refs i - version = indexPrimArray refs (i + 1) - Storage _ _ vs es _ <- readIORef storage + Storage _ (StorageData _ vs es _) <- readIORef' storage storageVersion <- readPrimArray vs ref -- If version of the reference is different than version in the storage, it -- means that the effect in the storage is not the one that was initially -- referenced. when (version /= storageVersion) $ do error $ "version (" ++ show version ++ ") /= storageVersion (" - ++ show storageVersion ++ ")" + ++ show storageVersion ++ ")\n" + ++ "If you're attempting to run an unlifting function outside " + ++ "of the scope of effects it captures, have a look at " + ++ "UnliftStrategy (SeqForkUnlift)." pure (ref, es) + where + Ref ref version = indexPrimArray refs (offset + reifyIndex @e @es) ---------------------------------------- -- Internal helpers -- | Create an empty storage. -emptyStorage :: IO Storage -emptyStorage = Storage 0 (noVersion + 1) - <$> newPrimArray 0 - <*> newSmallArray 0 undefinedData - <*> newSmallArray 0 undefinedData +emptyStorage :: HasCallStack => IO Storage +emptyStorage = Storage initialVersion <$> storageData + where + storageData = StorageData 0 + <$> newPrimArray 0 + <*> newSmallArray 0 undefinedEffect + <*> newSmallArray 0 undefinedRelinker -- | Insert an effect into the storage and return its reference. insertEffect - :: IORef Storage + :: HasCallStack + => IORef' Storage -> EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e - -> IO (Int, Int) + -> IO Ref insertEffect storage e f = do - Storage size version vs0 es0 fs0 <- readIORef storage - let len0 = sizeofSmallMutableArray es0 + Storage version (StorageData size vs0 es0 fs0) <- readIORef' storage + len0 <- getSizeofSmallMutableArray es0 case size `compare` len0 of GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")" LT -> do - writePrimArray vs0 size version - e `seq` writeSmallArray es0 size (toAny e) - f `seq` writeSmallArray fs0 size (toAny f) - writeIORef storage $! Storage (size + 1) (version + 1) vs0 es0 fs0 - pure (size, version) + writePrimArray vs0 size version + writeSmallArray' es0 size (toAnyEffect e) + writeSmallArray' fs0 size (toAnyRelinker f) + writeIORef' storage $ + Storage (bumpVersion version) (StorageData (size + 1) vs0 es0 fs0) + pure $ Ref size version EQ -> do - let len = doubleCapacity len0 + let len = growCapacity len0 vs <- newPrimArray len - es <- newSmallArray len undefinedData - fs <- newSmallArray len undefinedData + es <- newSmallArray len undefinedEffect + fs <- newSmallArray len undefinedRelinker copyMutablePrimArray vs 0 vs0 0 size copySmallMutableArray es 0 es0 0 size copySmallMutableArray fs 0 fs0 0 size - writePrimArray vs size version - e `seq` writeSmallArray es size (toAny e) - f `seq` writeSmallArray fs size (toAny f) - writeIORef storage $! Storage (size + 1) (version + 1) vs es fs - pure (size, version) + writePrimArray vs size version + writeSmallArray' es size (toAnyEffect e) + writeSmallArray' fs size (toAnyRelinker f) + writeIORef' storage $ + Storage (bumpVersion version) (StorageData (size + 1) vs es fs) + pure $ Ref size version -- | Given a reference to an effect from the top of the stack, delete it from -- the storage. -deleteEffect :: IORef Storage -> Int -> IO () -deleteEffect storage ref = do - Storage size version vs es fs <- readIORef storage +deleteEffect :: HasCallStack => IORef' Storage -> Ref -> IO () +deleteEffect storage (Ref ref version) = do + Storage currentVersion (StorageData size vs es fs) <- readIORef' storage when (ref /= size - 1) $ do error $ "ref (" ++ show ref ++ ") /= size - 1 (" ++ show (size - 1) ++ ")" - writePrimArray vs ref noVersion - writeSmallArray es ref undefinedData - writeSmallArray fs ref undefinedData - writeIORef storage $! Storage (size - 1) version vs es fs + storageVersion <- readPrimArray vs ref + when (version /= storageVersion) $ do + error $ "version (" ++ show version ++ ") /= storageVersion (" + ++ show storageVersion ++ ")\n" + writePrimArray vs ref undefinedVersion + writeSmallArray es ref undefinedEffect + writeSmallArray fs ref undefinedRelinker + writeIORef' storage $ Storage currentVersion (StorageData (size - 1) vs es fs) -- | Relink the environment to use the new storage. -relinkEnv :: IORef Storage -> Env es -> IO (Env es) +relinkEnv :: IORef' Storage -> Env es -> IO (Env es) relinkEnv storage (Env offset refs _) = pure $ Env offset refs storage --- | Double the capacity of an array. -doubleCapacity :: Int -> Int -doubleCapacity n = max 1 n * 2 +undefinedVersion :: Version +undefinedVersion = Version 0 -noVersion :: Int -noVersion = 0 +initialVersion :: Version +initialVersion = Version 1 -undefinedData :: HasCallStack => a -undefinedData = error "undefined data" +bumpVersion :: Version -> Version +bumpVersion (Version n) = Version (n + 1) + +undefinedEffect :: HasCallStack => AnyEffect +undefinedEffect = toAnyEffect . errorWithoutStackTrace $ unlines + [ "Undefined effect" + , "Created at: " ++ prettyCallStack callStack + ] + +undefinedRelinker :: HasCallStack => AnyRelinker +undefinedRelinker = toAnyRelinker $ Relinker $ \_ _ -> do + errorWithoutStackTrace $ unlines + [ "Undefined relinker" + , "Created at: " ++ prettyCallStack creationCallStack + , "Called at: " ++ prettyCallStack callStack + ] + where + creationCallStack = callStack + +-- | A strict version of 'writeSmallArray'. +writeSmallArray' :: SmallMutableArray RealWorld a -> Int -> a -> IO () +writeSmallArray' arr i a = a `seq` writeSmallArray arr i a + +#if !MIN_VERSION_primitive(0,9,0) +getSizeofSmallMutableArray :: SmallMutableArray RealWorld a -> IO Int +getSizeofSmallMutableArray arr = pure $! sizeofSmallMutableArray arr +#endif diff --git a/src/Effectful/Internal/MTL.hs b/src/Effectful/Internal/MTL.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Internal/MTL.hs @@ -0,0 +1,90 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +-- | Definitions and instances for MTL compatibility. +-- +-- This module is intended for internal use only, and may change without warning +-- in subsequent releases. +module Effectful.Internal.MTL where + +import Control.Monad.Except qualified as MTL +import Control.Monad.Reader qualified as MTL +import Control.Monad.State qualified as MTL +import Control.Monad.Writer qualified as MTL +import GHC.Stack (CallStack) + +import Effectful.Internal.Effect +import Effectful.Internal.Env +import Effectful.Internal.Monad + +-- | Provide the ability to handle errors of type @e@. +data Error e :: Effect where + -- | @since 2.4.0.0 + ThrowErrorWith :: (e -> String) -> e -> Error e m a + CatchError :: m a -> (CallStack -> e -> m a) -> Error e m a + +type instance DispatchOf (Error e) = Dynamic + +-- | Instance included for compatibility with existing code. +instance + ( Show e + , Error e :> es + , MTL.MonadError e (Eff es) + ) => MTL.MonadError e (Eff es) where + throwError = send . ThrowErrorWith show + catchError action = send . CatchError action . const + +---------------------------------------- + +data Reader r :: Effect where + Ask :: Reader r m r + Local :: (r -> r) -> m a -> Reader r m a + +type instance DispatchOf (Reader r) = Dynamic + +-- | Instance included for compatibility with existing code. +instance + ( Reader r :> es + , MTL.MonadReader r (Eff es) + ) => MTL.MonadReader r (Eff es) where + ask = send Ask + local f = send . Local f + reader f = f <$> send Ask + +---------------------------------------- + +-- | Provide access to a mutable value of type @s@. +data State s :: Effect where + Get :: State s m s + Put :: s -> State s m () + State :: (s -> (a, s)) -> State s m a + StateM :: (s -> m (a, s)) -> State s m a + +type instance DispatchOf (State s) = Dynamic + +-- | Instance included for compatibility with existing code. +instance + ( State s :> es + , MTL.MonadState s (Eff es) + ) => MTL.MonadState s (Eff es) where + get = send Get + put = send . Put + state = send . State + +---------------------------------------- + +-- | Provide access to a write only value of type @w@. +data Writer w :: Effect where + Tell :: w -> Writer w m () + Listen :: m a -> Writer w m (a, w) + +type instance DispatchOf (Writer w) = Dynamic + +-- | Instance included for compatibility with existing code. +instance + ( Monoid w + , Writer w :> es + , MTL.MonadWriter w (Eff es) + ) => MTL.MonadWriter w (Eff es) where + writer (a, w) = a <$ send (Tell w) + tell = send . Tell + listen = send . Listen + pass = error "pass is not implemented due to ambiguous semantics in presence of runtime exceptions" 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,10 +43,14 @@ , Limit(..) , unliftStrategy , withUnliftStrategy + , withSeqEffToIO , withEffToIO + , reallyUnsafeLiftMapIO + , reallyUnsafeUnliftIO -- ** Low-level unlifts , seqUnliftIO + , seqForkUnliftIO , concUnliftIO -- * Dispatch @@ -50,6 +59,7 @@ , EffectHandler , LocalEnv(..) , Handler(..) + , HandlerImpl(..) , relinkHandler , runHandler , send @@ -65,17 +75,14 @@ , stateStaticRep , stateStaticRepM , localStaticRep - - -- *** Primitive operations - , consEnv - , getEnv - , putEnv - , stateEnv - , modifyEnv ) where -import Control.Applicative (liftA2) +import Control.Applicative +import Control.Concurrent (myThreadId) +import Control.Exception qualified as E +import Control.Monad import Control.Monad.Base +import Control.Monad.Catch qualified as C import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.IO.Unlift @@ -84,14 +91,14 @@ import Data.Kind (Constraint) import GHC.Exts (oneShot) import GHC.IO (IO(..)) -import GHC.Stack (HasCallStack) +import GHC.Stack import System.IO.Unsafe (unsafeDupablePerformIO) -import qualified Control.Exception as E -import qualified Control.Monad.Catch as C +import Unsafe.Coerce (unsafeCoerce) import Effectful.Internal.Effect import Effectful.Internal.Env import Effectful.Internal.Unlift +import Effectful.Internal.Utils type role Eff nominal representational @@ -113,12 +120,12 @@ -- -- - Allows the effects to be handled in any order. newtype Eff (es :: [Effect]) a = Eff (Env es -> IO a) - deriving (Monoid, Semigroup) + deriving newtype (Monoid, Semigroup) -- | Run a pure 'Eff' computation. -- -- For running computations with side effects see 'runEff'. -runPureEff :: Eff '[] a -> a +runPureEff :: HasCallStack => Eff '[] a -> a runPureEff (Eff m) = -- unsafeDupablePerformIO is safe here since IOE was not on the stack, so no -- IO with side effects was performed (unless someone sneakily introduced side @@ -133,7 +140,7 @@ -- | Peel off the constructor of 'Eff'. unEff :: Eff es a -> Env es -> IO a -unEff = \(Eff m) -> m +unEff (Eff m) = m -- | Access the underlying 'IO' monad along with the environment. -- @@ -153,29 +160,49 @@ -- Unlifting IO -- | Get the current 'UnliftStrategy'. +-- +-- /Note:/ this strategy is implicitly used by the 'MonadUnliftIO' and +-- 'MonadBaseControl' instance for 'Eff'. unliftStrategy :: IOE :> es => Eff es UnliftStrategy unliftStrategy = do IOE unlift <- getStaticRep pure unlift --- | Locally override the 'UnliftStrategy' with the given value. +-- | Locally override the current 'UnliftStrategy' with the given value. withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a withUnliftStrategy unlift = localStaticRep $ \_ -> IOE unlift --- | Create an unlifting function with the current 'UnliftStrategy'. +-- | Create an unlifting function with the 'SeqUnlift' strategy. For the general +-- version see 'withEffToIO'. -- --- This function is equivalent to 'Effectful.withRunInIO', but has a --- 'HasCallStack' constraint for accurate stack traces in case an insufficiently --- powerful 'UnliftStrategy' is used and the unlifting function fails. -withEffToIO +-- /Note:/ usage of this function is preferrable to 'Effectful.withRunInIO' +-- because of explicit unlifting strategy and better error reporting. +-- +-- @since 2.2.2.0 +withSeqEffToIO :: (HasCallStack, IOE :> es) => ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a -withEffToIO f = unliftStrategy >>= \case - SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es f - ConcUnlift p b -> unsafeEff $ \es -> concUnliftIO es p b f +withSeqEffToIO k = unsafeEff $ \es -> seqUnliftIO es k +{-# INLINE withSeqEffToIO #-} +-- | Create an unlifting function with the given strategy. +-- +-- /Note:/ usage of this function is preferrable to 'Effectful.withRunInIO' +-- because of explicit unlifting strategy and better error reporting. +withEffToIO + :: (HasCallStack, IOE :> es) + => UnliftStrategy + -> ((forall r. Eff es r -> IO r) -> IO a) + -- ^ Continuation with the unlifting function in scope. + -> Eff es a +withEffToIO strategy k = case strategy of + SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es k + SeqForkUnlift -> unsafeEff $ \es -> seqForkUnliftIO es k + ConcUnlift p b -> unsafeEff $ \es -> concUnliftIO es p b k +{-# INLINE withEffToIO #-} + -- | Create an unlifting function with the 'SeqUnlift' strategy. seqUnliftIO :: HasCallStack @@ -184,8 +211,27 @@ -> ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> IO a -seqUnliftIO es k = seqUnlift k es unEff +seqUnliftIO es k = do + tid0 <- myThreadId + k $ \m -> do + tid <- myThreadId + if tid `eqThreadId` tid0 + then unEff m es + else error + $ "If you want to use the unlifting function to run Eff computations " + ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)." +-- | Create an unlifting function with the 'SeqForkUnlift' strategy. +seqForkUnliftIO + :: HasCallStack + => Env es + -- ^ The environment. + -> ((forall r. Eff es r -> IO r) -> IO a) + -- ^ Continuation with the unlifting function in scope. + -> IO a +seqForkUnliftIO es0 k = cloneEnv es0 >>= \es -> seqUnliftIO es k +{-# INLINE seqForkUnliftIO #-} + -- | Create an unlifting function with the 'ConcUnlift' strategy. concUnliftIO :: HasCallStack @@ -196,8 +242,58 @@ -> ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> IO a -concUnliftIO es persistence limit k = concUnlift persistence limit k es unEff +concUnliftIO es Ephemeral (Limited uses) = ephemeralConcUnlift es uses +concUnliftIO es Ephemeral Unlimited = ephemeralConcUnlift es maxBound +concUnliftIO es Persistent (Limited threads) = persistentConcUnlift es False threads +concUnliftIO es Persistent Unlimited = persistentConcUnlift es True maxBound +-- | Utility for lifting 'IO' computations of type +-- +-- @'IO' a -> 'IO' b@ +-- +-- to +-- +-- @'Eff' es a -> 'Eff' es b@ +-- +-- This function is __really unsafe__ because: +-- +-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' +-- computations. +-- +-- - The 'IO' computation must run its argument in a way that's perceived as +-- sequential to the outside observer, e.g. in the same thread or in a worker +-- thread that finishes before the argument is run again. +-- +-- __Warning:__ if you disregard the second point, you will experience weird +-- bugs, data races or internal consistency check failures. +-- +-- When in doubt, use 'Effectful.Dispatch.Static.unsafeLiftMapIO', especially +-- since this version saves only a simple safety check per call of +-- @reallyUnsafeLiftMapIO f@. +reallyUnsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b +reallyUnsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es) + +-- | Create an unlifting function. +-- +-- This function is __really unsafe__ because: +-- +-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff' +-- computations. +-- +-- - Unlifted 'Eff' computations must be run in a way that's perceived as +-- sequential to the outside observer, e.g. in the same thread as the caller +-- of 'reallyUnsafeUnliftIO' or in a worker thread that finishes before +-- another unlifted computation is run. +-- +-- __Warning:__ if you disregard the second point, you will experience weird +-- bugs, data races or internal consistency check failures. +-- +-- When in doubt, use 'Effectful.Dispatch.Static.unsafeSeqUnliftIO', especially +-- since this version saves only a simple safety check per call of the unlifting +-- function. +reallyUnsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a +reallyUnsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es) + ---------------------------------------- -- Base @@ -213,51 +309,88 @@ liftA2 f (Eff ma) (Eff mb) = unsafeEff $ \es -> liftA2 f (ma es) (mb es) instance Monad (Eff es) where - return = unsafeEff_ . pure Eff m >>= k = unsafeEff $ \es -> m es >>= \a -> unEff (k a) es -- https://gitlab.haskell.org/ghc/ghc/-/issues/20008 - Eff ma >> Eff mb = unsafeEff $ \es -> ma es >> mb es + {-# INLINE (>>=) #-} instance MonadFix (Eff es) where mfix f = unsafeEff $ \es -> mfix $ \a -> unEff (f a) es ---------------------------------------- +-- NonDet + +-- | Provide the ability to use the 'Alternative' and 'MonadPlus' instance for +-- 'Eff'. +-- +-- /Note:/ 'NonDet' does not backtrack. Formally, it obeys the "left-catch" law +-- for 'MonadPlus', rather than the "left-distribution" law. This means that it +-- behaves more like 'Maybe' than @[]@. +-- +-- @since 2.2.0.0 +data NonDet :: Effect where + Empty :: NonDet m a + (:<|>:) :: m a -> m a -> NonDet m a + +type instance DispatchOf NonDet = Dynamic + +-- | @since 2.2.0.0 +instance NonDet :> es => Alternative (Eff es) where + empty = send Empty + a <|> b = send (a :<|>: b) + +-- | @since 2.2.0.0 +instance NonDet :> es => MonadPlus (Eff es) + +---------------------------------------- -- Exception instance C.MonadThrow (Eff es) where - throwM = unsafeEff_ . E.throwIO + throwM = unsafeEff_ . withFrozenCallStack E.throwIO instance C.MonadCatch (Eff es) where - catch m handler = unsafeEff $ \es -> do - unEff m es `E.catch` \e -> do - unEff (handler e) es + catch action handler = reallyUnsafeUnliftIO $ \unlift -> do + E.catch (unlift action) (unlift . handler) instance C.MonadMask (Eff es) where - mask k = unsafeEff $ \es -> E.mask $ \unmask -> - unEff (k $ \m -> unsafeEff $ unmask . unEff m) es + mask k = reallyUnsafeUnliftIO $ \unlift -> do + E.mask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release) - uninterruptibleMask k = unsafeEff $ \es -> E.uninterruptibleMask $ \unmask -> - unEff (k $ \m -> unsafeEff $ unmask . unEff m) es + uninterruptibleMask k = reallyUnsafeUnliftIO $ \unlift -> do + E.uninterruptibleMask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release) - generalBracket acquire release use = unsafeEff $ \es -> E.mask $ \unmask -> do - resource <- unEff acquire es - b <- unmask (unEff (use resource) es) `E.catch` \e -> do - _ <- unEff (release resource $ C.ExitCaseException e) es - E.throwIO e - c <- unEff (release resource $ C.ExitCaseSuccess b) es - pure (b, c) + generalBracket before after action = reallyUnsafeUnliftIO $ \unlift -> do + E.mask $ \unmask -> do + a <- unlift before +#if MIN_VERSION_base(4,21,0) + b <- E.catchNoPropagate + (unmask . unlift $ action a) + (\ec@(E.ExceptionWithContext _ e) -> do + _ <- E.annotateIO (E.WhileHandling (E.toException ec)) $ do + unlift . after a $ C.ExitCaseException e + E.rethrowIO ec + ) +#else + b <- E.catch + (unmask . unlift $ action a) + (\e -> do + _ <- unlift . after a $ C.ExitCaseException e + E.throwIO e + ) +#endif + c <- unlift . after a $ C.ExitCaseSuccess b + pure (b, c) ---------------------------------------- -- Fail --- | Provide the ability to use the 'MonadFail' instance of 'Eff'. +-- | Provide the ability to use the 'MonadFail' instance for 'Eff'. data Fail :: Effect where Fail :: String -> Fail m a type instance DispatchOf Fail = Dynamic instance Fail :> es => MonadFail (Eff es) where - fail = send . Fail + fail msg = send (Fail msg) ---------------------------------------- -- IO @@ -275,26 +408,38 @@ -- | Run an 'Eff' computation with side effects. -- -- For running pure computations see 'runPureEff'. -runEff :: Eff '[IOE] a -> IO a +runEff :: HasCallStack => Eff '[IOE] a -> IO a runEff m = unEff m =<< consEnv (IOE SeqUnlift) dummyRelinker =<< emptyEnv instance IOE :> es => MonadIO (Eff es) where liftIO = unsafeEff_ --- | Use 'withEffToIO' if you want accurate stack traces on errors. +-- | Instance included for compatibility with existing code. +-- +-- Usage of 'withEffToIO' is preferrable as it allows specifying the +-- 'UnliftStrategy' on a case-by-case basis and has better error reporting. +-- +-- /Note:/ the unlifting strategy for 'withRunInIO' is taken from the 'IOE' +-- context (see 'unliftStrategy'). instance IOE :> es => MonadUnliftIO (Eff es) where - withRunInIO = withEffToIO + withRunInIO k = unliftStrategy >>= (`withEffToIO` k) --- | Instance included for compatibility with existing code, usage of 'liftIO' --- is preferrable. +-- | Instance included for compatibility with existing code. +-- +-- Usage of 'liftIO' is preferrable as it's a standard. instance IOE :> es => MonadBase IO (Eff es) where liftBase = unsafeEff_ --- | Instance included for compatibility with existing code, usage of --- 'Effectful.withRunInIO' is preferrable. +-- | Instance included for compatibility with existing code. +-- +-- Usage of 'withEffToIO' is preferrable as it allows specifying the +-- 'UnliftStrategy' on a case-by-case basis and has better error reporting. +-- +-- /Note:/ the unlifting strategy for 'liftBaseWith' is taken from the 'IOE' +-- context (see 'unliftStrategy'). instance IOE :> es => MonadBaseControl IO (Eff es) where type StM (Eff es) a = a - liftBaseWith = withEffToIO + liftBaseWith k = unliftStrategy >>= (`withEffToIO` k) restoreM = pure ---------------------------------------- @@ -306,19 +451,23 @@ type instance DispatchOf Prim = Static WithSideEffects data instance StaticRep Prim = Prim +-- | 'PrimState' token for 'Eff'. Used instead of 'RealWorld' to prevent the +-- 'Prim' effect from executing arbitrary 'IO' actions via 'ioToPrim'. +data PrimStateEff + -- | Run an 'Eff' computation with primitive state-transformer actions. -runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a +runPrim :: (HasCallStack, IOE :> es) => Eff (Prim : es) a -> Eff es a runPrim = evalStaticRep Prim instance Prim :> es => PrimMonad (Eff es) where - type PrimState (Eff es) = RealWorld - primitive = unsafeEff_ . IO + type PrimState (Eff es) = PrimStateEff + primitive = unsafeEff_ . IO . unsafeCoerce ---------------------------------------- -- Lifting -- | Lift an 'Eff' computation into an effect stack with one more effect. -raise :: Eff es a -> Eff (e : es) a +raise :: forall e es a. Eff es a -> Eff (e : es) a raise m = unsafeEff $ \es -> unEff m =<< tailEnv es -- | Lift an 'Eff' computation into an effect stack with one more effect and @@ -331,30 +480,72 @@ -> ((forall r. Eff (e : es) r -> Eff es r) -> Eff es a) -- ^ Continuation with the unlifting function in scope. -> Eff (e : es) a -raiseWith strategy k = case strategy of - SeqUnlift -> unsafeEff $ \ees -> do - es <- tailEnv ees - seqUnliftIO ees $ \unlift -> do +raiseWith strategy k = unsafeEff $ \ees -> do + es <- tailEnv ees + case strategy of + SeqUnlift -> seqUnliftIO ees $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift - ConcUnlift p l -> unsafeEff $ \ees -> do - es <- tailEnv ees - concUnliftIO ees p l $ \unlift -> do + SeqForkUnlift -> seqForkUnliftIO ees $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift + ConcUnlift p l -> concUnliftIO ees p l $ \unlift -> do + (`unEff` es) $ k $ unsafeEff_ . unlift +{-# INLINE raiseWith #-} -- | Eliminate a duplicate effect from the top of the effect stack. subsume :: e :> es => Eff (e : es) a -> Eff es a subsume m = unsafeEff $ \es -> unEff m =<< subsumeEnv es --- | Allow for running an effect stack @xs@ within @es@ as long as @xs@ is a --- permutation (with possible duplicates) of a subset of @es@. +-- | Allow for running an effect stack @subEs@ within @es@ as long as @subEs@ is +-- a permutation (with possible duplicates) of a subset of @es@. -- -- Generalizes 'raise' and 'subsume'. -- --- /Note:/ this function should be needed rarely, usually when you have to cross --- API boundaries and monomorphic effect stacks are involved. Using monomorphic --- stacks is discouraged (see 'Eff'), but sometimes might be necessary due to --- external constraints. -inject :: Subset xs es => Eff xs a -> Eff es a +-- >>> data E1 :: Effect +-- >>> data E2 :: Effect +-- >>> data E3 :: Effect +-- +-- It makes it possible to rearrange the effect stack however you like: +-- +-- >>> :{ +-- shuffle :: Eff (E3 : E1 : E2 : es) a -> Eff (E1 : E2 : E3 : es) a +-- shuffle = inject +-- :} +-- +-- It can also turn a monomorphic effect stack into a polymorphic one: +-- +-- >>> :{ +-- toPoly :: (E1 :> es, E2 :> es, E3 :> es) => Eff [E1, E2, E3] a -> Eff es a +-- toPoly = inject +-- :} +-- +-- Moreover, it allows for hiding specific effects from downstream: +-- +-- >>> :{ +-- onlyE1 :: Eff (E1 : es) a -> Eff (E1 : E2 : E3 : es) a +-- onlyE1 = inject +-- :} +-- +-- >>> :{ +-- onlyE2 :: Eff (E2 : es) a -> Eff (E1 : E2 : E3 : es) a +-- onlyE2 = inject +-- :} +-- +-- >>> :{ +-- onlyE3 :: Eff (E3 : es) a -> Eff (E1 : E2 : E3 : es) a +-- onlyE3 = inject +-- :} +-- +-- However, it's not possible to inject a computation into an incompatible +-- effect stack: +-- +-- >>> :{ +-- coerceEs :: Eff es1 a -> Eff es2 a +-- coerceEs = inject +-- :} +-- ... +-- ...Couldn't match type ‘es1’ with ‘es2’ +-- ... +inject :: Subset subEs es => Eff subEs a -> Eff es a inject m = unsafeEff $ \es -> unEff m =<< injectEnv es ---------------------------------------- @@ -372,42 +563,57 @@ newtype LocalEnv (localEs :: [Effect]) (handlerEs :: [Effect]) = LocalEnv (Env localEs) -- | Type signature of the effect handler. -type EffectHandler e es +type EffectHandler (e :: Effect) (es :: [Effect]) = forall a localEs. (HasCallStack, e :> localEs) => LocalEnv localEs es -- ^ Capture of the local environment for handling local 'Eff' computations -- when @e@ is a higher order effect. -> e (Eff localEs) a - -- ^ The effect performed in the local environment. + -- ^ The operation. -> Eff es a +-- | Wrapper to prevent a space leak on reconstruction of 'Handler' in +-- 'relinkHandler' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520). +newtype HandlerImpl e es = HandlerImpl (EffectHandler e es) + -- | An internal representation of dynamically dispatched effects, i.e. the -- effect handler bundled with its environment. data Handler :: Effect -> Type where - Handler :: !(Env es) -> !(EffectHandler e es) -> Handler e + Handler :: !(Env handlerEs) -> !(HandlerImpl e handlerEs) -> Handler e type instance EffectRep Dynamic = Handler relinkHandler :: Relinker Handler e -relinkHandler = Relinker $ \relink (Handler handlerEs handle) -> do +relinkHandler = Relinker $ \relink (Handler handlerEs handler) -> do newHandlerEs <- relink handlerEs - pure $ Handler newHandlerEs handle + pure $ Handler newHandlerEs handler -- | Run a dynamically dispatched effect with the given handler. -runHandler :: DispatchOf e ~ Dynamic => Handler e -> Eff (e : es) a -> Eff es a +runHandler + :: (HasCallStack, DispatchOf e ~ Dynamic) + => Handler e + -> Eff (e : es) a + -> Eff es a runHandler e m = unsafeEff $ \es0 -> do - E.bracket (consEnv e relinkHandler es0) - unconsEnv - (\es -> unEff m es) + inlineBracket + (consEnv e relinkHandler es0) + unconsEnv + (\es -> unEff m es) -- | Send an operation of the given effect to its handler for execution. send :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => e (Eff es) a - -- ^ The effect. + -- ^ The operation. -> Eff es a send op = unsafeEff $ \es -> do - Handler handlerEs handle <- getEnv es - unEff (handle (LocalEnv es) op) handlerEs + Handler handlerEs (HandlerImpl handler) <- getEnv es + when (envStorage es /= envStorage handlerEs) $ do + error "es and handlerEs point to different Storages" + -- Prevent the addition of unnecessary 'handler' stack frame to the call + -- stack. Note that functions 'interpret', 'reinterpret', 'interpose' and + -- 'impose' need to thaw the call stack so that useful stack frames from + -- inside the effect handler continue to be added. + unEff (withFrozenCallStack handler (LocalEnv es) op) handlerEs {-# NOINLINE send #-} ---------------------------------------- @@ -426,75 +632,85 @@ -- | Run a statically dispatched effect with the given initial representation -- and return the final value along with the final representation. runStaticRep - :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) => StaticRep e -- ^ The initial representation. -> Eff (e : es) a -> Eff es (a, StaticRep e) runStaticRep e0 m = unsafeEff $ \es0 -> do - E.bracket (consEnv e0 dummyRelinker es0) - unconsEnv - (\es -> (,) <$> unEff m es <*> getEnv es) + inlineBracket + (consEnv e0 dummyRelinker es0) + unconsEnv + (\es -> (,) <$> unEff m es <*> getEnv es) -- | Run a statically dispatched effect with the given initial representation -- and return the final value, discarding the final representation. evalStaticRep - :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) => StaticRep e -- ^ The initial representation. -> Eff (e : es) a -> Eff es a evalStaticRep e m = unsafeEff $ \es0 -> do - E.bracket (consEnv e dummyRelinker es0) - unconsEnv - (\es -> unEff m es) + inlineBracket + (consEnv e dummyRelinker es0) + unconsEnv + (\es -> unEff m es) -- | Run a statically dispatched effect with the given initial representation -- and return the final representation, discarding the final value. execStaticRep - :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) => StaticRep e -- ^ The initial representation. -> Eff (e : es) a -> Eff es (StaticRep e) execStaticRep e0 m = unsafeEff $ \es0 -> do - E.bracket (consEnv e0 dummyRelinker es0) - unconsEnv - (\es -> unEff m es *> getEnv es) + inlineBracket + (consEnv e0 dummyRelinker es0) + unconsEnv + (\es -> unEff m es *> getEnv es) -- | Fetch the current representation of the effect. -getStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => Eff es (StaticRep e) +getStaticRep + :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) + => Eff es (StaticRep e) getStaticRep = unsafeEff $ \es -> getEnv es -- | Set the current representation of the effect to the given value. -putStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => StaticRep e -> Eff es () +putStaticRep + :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) + => StaticRep e -> Eff es () putStaticRep s = unsafeEff $ \es -> putEnv es s -- | Apply the function to the current representation of the effect and return a -- value. stateStaticRep - :: (DispatchOf e ~ Static sideEffects, e :> es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) => (StaticRep e -> (a, StaticRep e)) -- ^ The function to modify the representation. -> Eff es a -stateStaticRep f = unsafeEff $ \es -> stateEnv es (pure . f) +stateStaticRep f = unsafeEff $ \es -> stateEnv es f -- | Apply the monadic function to the current representation of the effect and -- return a value. stateStaticRepM - :: (DispatchOf e ~ Static sideEffects, e :> es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) => (StaticRep e -> Eff es (a, StaticRep e)) -- ^ The function to modify the representation. -> Eff es a stateStaticRepM f = unsafeEff $ \es -> E.mask $ \unmask -> do - stateEnv es $ unmask . (`unEff` es) . f + (a, e) <- unmask . (`unEff` es) . f =<< getEnv es + putEnv es e + pure a -- | Execute a computation with a temporarily modified representation of the -- effect. localStaticRep - :: (DispatchOf e ~ Static sideEffects, e :> es) + :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) => (StaticRep e -> StaticRep e) -- ^ The function to temporarily modify the representation. -> Eff es a -> Eff es a localStaticRep f m = unsafeEff $ \es -> do - E.bracket (stateEnv es $ \s -> pure (s, f s)) - (\s -> putEnv es s) - (\_ -> unEff m es) + inlineBracket + (stateEnv es $ \s -> (s, f s)) + (\s -> putEnv es s) + (\_ -> unEff m es) 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,15 @@ , Limit(..) -- * Unlifting functions - , seqUnlift - , concUnlift , ephemeralConcUnlift , persistentConcUnlift ) where import Control.Concurrent +import Control.Concurrent.MVar.Strict import Control.Monad +import Data.Coerce +import Data.IntMap.Strict qualified as IM import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (mkWeak#, mkWeakNoFinalizer#) import GHC.Generics (Generic) @@ -27,7 +29,6 @@ import GHC.Stack (HasCallStack) import GHC.Weak (Weak(..)) import System.Mem.Weak (deRefWeak) -import qualified Data.IntMap.Strict as IM import Effectful.Internal.Env import Effectful.Internal.Utils @@ -36,21 +37,66 @@ -- Unlift strategies -- | The strategy to use when unlifting 'Effectful.Eff' computations via --- 'Effectful.withEffToIO', 'Effectful.withRunInIO' or the --- 'Effectful.Dispatch.Dynamic.localUnlift' family. --- --- /Note:/ unlifting functions should not be used outside of continuations that --- brought them into scope. +-- 'Effectful.withEffToIO' or the 'Effectful.Dispatch.Dynamic.localUnlift' +-- family. data UnliftStrategy = SeqUnlift - -- ^ The fastest strategy and a default setting for t'Effectful.IOE'. An - -- attempt to call the unlifting function in threads distinct from its creator - -- will result in a runtime error. + -- ^ The sequential strategy is the fastest and a default setting for + -- t'Effectful.IOE'. Any attempt of calling the unlifting function in threads + -- distinct from its creator will result in a runtime error. + | SeqForkUnlift + -- ^ Like 'SeqUnlift', but all unlifted actions will be executed in a cloned + -- environment. + -- + -- The main consequence is that thread local state is forked at the point of + -- creation of the unlifting function and its modifications in unlifted + -- actions will not affect the main thread of execution (and vice versa): + -- + -- >>> import Effectful + -- >>> import Effectful.State.Dynamic + -- >>> :{ + -- action :: (IOE :> es, State Int :> es) => Eff es () + -- action = do + -- modify @Int (+1) + -- withEffToIO SeqForkUnlift $ \unlift -> unlift $ modify @Int (+2) + -- modify @Int (+4) + -- :} + -- + -- >>> runEff . execStateLocal @Int 0 $ action + -- 5 + -- + -- >>> runEff . execStateShared @Int 0 $ action + -- 7 + -- + -- Because of this it's possible to safely use the unlifting function outside + -- of the scope of effects it captures, e.g. by creating an @IO@ action that + -- executes effectful operations and running it later: + -- + -- >>> :{ + -- delayed :: UnliftStrategy -> IO (IO String) + -- delayed strategy = runEff . evalStateLocal "Hey" $ do + -- r <- withEffToIO strategy $ \unlift -> pure $ unlift get + -- modify (++ "!!!") + -- pure r + -- :} + -- + -- This doesn't work with the 'SeqUnlift' strategy because when the returned + -- action runs, @State@ is no longer in scope: + -- + -- >>> join $ delayed SeqUnlift + -- *** Exception: version (...) /= storageVersion (0) + -- ... + -- + -- However, it does with the 'SeqForkUnlift' strategy: + -- + -- >>> join $ delayed SeqForkUnlift + -- "Hey" + -- | ConcUnlift !Persistence !Limit - -- ^ A strategy that makes it possible for the unlifting function to be called - -- in threads distinct from its creator. See 'Persistence' and 'Limit' - -- settings for more information. - deriving (Eq, Generic, Ord, Show) + -- ^ The concurrent strategy makes it possible for the unlifting function to + -- be called in threads distinct from its creator. See 'Persistence' and + -- 'Limit' settings for more information. + deriving stock (Eq, Generic, Ord, Show) -- | Persistence setting for the 'ConcUnlift' strategy. -- @@ -70,7 +116,7 @@ | Persistent -- ^ Persist the environment between calls to the unlifting function within a -- particular thread. - deriving (Eq, Generic, Ord, Show) + deriving stock (Eq, Generic, Ord, Show) -- | Limit setting for the 'ConcUnlift' strategy. data Limit @@ -89,57 +135,21 @@ -- when called in @N@ threads and @K+1@ copies when called in @K < N@ threads. | Unlimited -- ^ Unlimited use of the unlifting function. - deriving (Eq, Generic, Ord, Show) + deriving stock (Eq, Generic, Ord, Show) ---------------------------------------- -- Unlift functions --- | Sequential unlift. -seqUnlift - :: HasCallStack - => ((forall r. m r -> IO r) -> IO a) - -> Env es - -> (forall r. m r -> Env es -> IO r) - -> IO a -seqUnlift k es unEff = do - tid0 <- myThreadId - k $ \m -> do - tid <- myThreadId - if tid `eqThreadId` tid0 - then unEff m es - else error - $ "If you want to use the unlifting function to run Eff computations " - ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)." - --- | Concurrent unlift for various strategies and limits. -concUnlift - :: HasCallStack - => Persistence - -> Limit - -> ((forall r. m r -> IO r) -> IO a) - -> Env es - -> (forall r. m r -> Env es -> IO r) - -> IO a -concUnlift Ephemeral (Limited uses) k = - ephemeralConcUnlift uses k -concUnlift Ephemeral Unlimited k = - ephemeralConcUnlift maxBound k -concUnlift Persistent (Limited threads) k = - persistentConcUnlift False threads k -concUnlift Persistent Unlimited k = - persistentConcUnlift True maxBound k - -- | Concurrent unlift that doesn't preserve the environment between calls to -- the unlifting function in threads other than its creator. ephemeralConcUnlift - :: HasCallStack - => Int + :: (HasCallStack, forall r. Coercible (m r) (Env es -> IO r)) + => Env es + -> Int -- ^ Number of permitted uses of the unlift function. -> ((forall r. m r -> IO r) -> IO a) - -> Env es - -> (forall r. m r -> Env es -> IO r) -> IO a -ephemeralConcUnlift uses k es0 unEff = do +ephemeralConcUnlift es0 uses k = do unless (uses > 0) $ do error $ "Invalid number of uses: " ++ show uses tid0 <- myThreadId @@ -147,34 +157,33 @@ -- use. This can't be done from inside the callback as the environment might -- have already changed by then. esTemplate <- cloneEnv es0 - mvUses <- newMVar uses + mvUses <- newMVar' uses k $ \m -> do es <- myThreadId >>= \case tid | tid0 `eqThreadId` tid -> pure es0 - _ -> modifyMVar mvUses $ \case + _ -> modifyMVar' mvUses $ \case 0 -> error $ "Number of permitted calls (" ++ show uses ++ ") to the unlifting " ++ "function in other threads was exceeded. Please increase the limit " ++ "or use the unlimited variant." 1 -> pure (0, esTemplate) n -> do - let newUses = n - 1 es <- cloneEnv esTemplate - newUses `seq` pure (newUses, es) - unEff m es + pure (n - 1, es) + coerce m es +{-# NOINLINE ephemeralConcUnlift #-} -- | Concurrent unlift that preserves the environment between calls to the -- unlifting function within a particular thread. persistentConcUnlift - :: HasCallStack - => Bool + :: (HasCallStack, forall r. Coercible (m r) (Env es -> IO r)) + => Env es + -> Bool -> Int -- ^ Number of threads that are allowed to use the unlift function. -> ((forall r. m r -> IO r) -> IO a) - -> Env es - -> (forall r. m r -> Env es -> IO r) -> IO a -persistentConcUnlift cleanUp threads k es0 unEff = do +persistentConcUnlift es0 cleanUp threads k = do unless (threads > 0) $ do error $ "Invalid number of threads: " ++ show threads tid0 <- myThreadId @@ -182,11 +191,11 @@ -- use. This can't be done from inside the callback as the environment might -- have already changed by then. esTemplate <- cloneEnv es0 - mvEntries <- newMVar $ ThreadEntries threads IM.empty + mvEntries <- newMVar' $ ThreadEntries threads IM.empty k $ \m -> do es <- myThreadId >>= \case tid | tid0 `eqThreadId` tid -> pure es0 - tid -> modifyMVar mvEntries $ \te -> do + tid -> modifyMVar' mvEntries $ \te -> do let wkTid = weakThreadId tid (mes, i) <- case wkTid `IM.lookup` teEntries te of Just (ThreadEntry i td) -> (, i) <$> lookupEnv tid td @@ -204,7 +213,7 @@ { teCapacity = teCapacity te - 1 , teEntries = addThreadData wkTid i wkTidEs $ teEntries te } - newEntries `seq` pure (newEntries, esTemplate) + pure (newEntries, esTemplate) _ -> do es <- cloneEnv esTemplate wkTidEs <- mkWeakThreadIdEnv tid es wkTid i mvEntries cleanUp @@ -212,14 +221,15 @@ { teCapacity = teCapacity te - 1 , teEntries = addThreadData wkTid i wkTidEs $ teEntries te } - newEntries `seq` pure (newEntries, es) - unEff m es + pure (newEntries, es) + coerce m es +{-# NOINLINE persistentConcUnlift #-} ---------------------------------------- -- Data types newtype EntryId = EntryId Int - deriving Eq + deriving newtype Eq newEntryId :: EntryId newEntryId = EntryId 0 @@ -249,7 +259,7 @@ -> Env es -> Int -> EntryId - -> MVar (ThreadEntries es) + -> MVar' (ThreadEntries es) -> Bool -> IO (Weak (ThreadId, Env es)) mkWeakThreadIdEnv t@(ThreadId t#) es wkTid i v = \case @@ -295,17 +305,16 @@ ---------------------------------------- -deleteThreadData :: Int -> EntryId -> MVar (ThreadEntries es) -> IO () -deleteThreadData wkTid i v = modifyMVar_ v $ \te -> do - let newEntries = ThreadEntries - { teCapacity = case teCapacity te of - -- If the template copy of the environment hasn't been consumed - -- yet, the capacity can be restored. - 0 -> 0 - n -> n + 1 - , teEntries = IM.update (cleanThreadEntry i) wkTid $ teEntries te - } - newEntries `seq` pure newEntries +deleteThreadData :: Int -> EntryId -> MVar' (ThreadEntries es) -> IO () +deleteThreadData wkTid i v = modifyMVar'_ v $ \te -> do + pure ThreadEntries + { teCapacity = case teCapacity te of + -- If the template copy of the environment hasn't been consumed + -- yet, the capacity can be restored. + 0 -> 0 + n -> n + 1 + , teEntries = IM.update (cleanThreadEntry i) wkTid $ teEntries te + } cleanThreadEntry :: EntryId -> ThreadEntry es -> Maybe (ThreadEntry es) cleanThreadEntry i0 (ThreadEntry i td0) = case cleanThreadData i0 td0 of 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,142 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +{-# OPTIONS_HADDOCK not-home #-} +module Effectful.Internal.Utils + ( inlineBracket + + -- * Utils for 'ThreadId' + , weakThreadId + , eqThreadId + + -- * Utils for 'Any' + , Any + , toAny + , fromAny + + -- * Unique + , Unique + , newUnique + + -- * CallStack + , thawCallStack + + -- * Array capacity + , growCapacity + ) where + +import Control.Exception +import Data.Primitive.ByteArray +import GHC.Conc.Sync (ThreadId(..)) +import GHC.Exts (Any, RealWorld) +import GHC.Stack.Types (CallStack(..)) +import Unsafe.Coerce (unsafeCoerce) + +#if MIN_VERSION_base(4,19,0) +import GHC.Conc.Sync (fromThreadId) +#else +import GHC.Exts (Addr#, ThreadId#, unsafeCoerce#) +#if __GLASGOW_HASKELL__ >= 904 +import Data.Word +#else +import Foreign.C.Types +#endif +#endif + +-- | Version of bracket with an INLINE pragma to work around +-- https://gitlab.haskell.org/ghc/ghc/-/issues/22824. +inlineBracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c +inlineBracket before after action = mask $ \unmask -> do + a <- before + r <- unmask (action a) `onException` after a + _ <- after a + pure r +{-# INLINE inlineBracket #-} + +---------------------------------------- + +-- | Get an id of a thread that doesn't prevent its garbage collection. +weakThreadId :: ThreadId -> Int +#if MIN_VERSION_base(4,19,0) +weakThreadId = fromIntegral . fromThreadId +#else +weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId (threadIdToAddr# t#) + +foreign import ccall unsafe "rts_getThreadId" +#if __GLASGOW_HASKELL__ >= 904 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6163 + rts_getThreadId :: Addr# -> Word64 +#elif __GLASGOW_HASKELL__ >= 900 + -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1254 + rts_getThreadId :: Addr# -> CLong +#else + rts_getThreadId :: Addr# -> CInt +#endif + +-- Note: FFI imports take Addr# instead of ThreadId# because of +-- https://gitlab.haskell.org/ghc/ghc/-/issues/8281, which would prevent loading +-- effectful-core into GHCi. +-- +-- Previous workaround was to use an internal library with just this module, but +-- this is not viable because of bugs in stack (sigh). +-- +-- The coercion is fine because GHC represents ThreadId# as a pointer. +threadIdToAddr# :: ThreadId# -> Addr# +threadIdToAddr# = unsafeCoerce# +#endif + +---------------------------------------- + +#if __GLASGOW_HASKELL__ < 900 + +-- | 'Eq' instance for 'ThreadId' is broken in GHC < 9, see +-- https://gitlab.haskell.org/ghc/ghc/-/issues/16761 for more info. +eqThreadId :: ThreadId -> ThreadId -> Bool +eqThreadId (ThreadId t1#) (ThreadId t2#) = + eq_thread (threadIdToAddr# t1#) (threadIdToAddr# t2#) == 1 + +foreign import ccall unsafe "effectful_eq_thread" + eq_thread :: Addr# -> Addr# -> CLong + +#else + +eqThreadId :: ThreadId -> ThreadId -> Bool +eqThreadId = (==) + +#endif + +---------------------------------------- + +toAny :: a -> Any +toAny = unsafeCoerce + +fromAny :: Any -> a +fromAny = unsafeCoerce + +---------------------------------------- + +-- | A unique with no possibility for CAS contention. +-- +-- Credits for this go to Edward Kmett. +newtype Unique = Unique (MutableByteArray RealWorld) + +instance Eq Unique where + Unique a == Unique b = sameMutableByteArray a b + +newUnique :: IO Unique +newUnique = Unique <$> newByteArray 0 + +---------------------------------------- + +thawCallStack :: CallStack -> CallStack +thawCallStack = \case + FreezeCallStack cs -> cs + cs -> cs + +---------------------------------------- + +-- | Grow capacity of an array. +-- +-- See https://archive.ph/Z2R8w. +growCapacity :: Int -> Int +growCapacity n = 1 + quot (n * 3) 2 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,79 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Labeled effects. +-- +-- Any effect can be assigned multiple labels so you have more than one +-- available simultaneously. +-- +-- @since 2.3.0.0 +module Effectful.Labeled + ( -- * Effect + Labeled(..) + + -- ** Handlers + , runLabeled + + -- ** Operations + , labeled + ) where + +import Unsafe.Coerce (unsafeCoerce) + +import Effectful +import Effectful.Dispatch.Static + +-- | Assign a label to an effect. +-- +-- The constructor is for sending labeled operations of a dynamically dispatched +-- effect to the handler: +-- +-- >>> import Effectful.Dispatch.Dynamic +-- +-- >>> :{ +-- data X :: Effect where +-- X :: X m Int +-- type instance DispatchOf X = Dynamic +-- :} +-- +-- >>> :{ +-- runPureEff . runLabeled @"x" (interpret_ $ \X -> pure 333) $ do +-- send $ Labeled @"x" X +-- :} +-- 333 +-- +newtype Labeled (label :: k) (e :: Effect) :: Effect where + -- | @since 2.4.0.0 + Labeled :: forall label e m a. e m a -> Labeled label e m a + +type instance DispatchOf (Labeled label e) = DispatchOf e + +data instance StaticRep (Labeled label e) + +-- | Run a 'Labeled' effect with a given effect handler. +runLabeled + :: forall label e es a b + . HasCallStack + => (Eff (e : es) a -> Eff es b) + -- ^ The effect handler. + -> Eff (Labeled label e : es) a + -> Eff es b +runLabeled runE m = runE (fromLabeled m) + +-- | Bring an effect into scope without a label. +-- +-- Useful for running code written with the non-labeled effect in mind. +labeled + :: forall label e es a + . (HasCallStack, Labeled label e :> es) + => Eff (e : es) a + -- ^ The action using the effect. + -> Eff es a +labeled m = subsume @(Labeled label e) (toLabeled m) + +---------------------------------------- +-- Helpers + +fromLabeled :: Eff (Labeled label e : es) a -> Eff (e : es) a +fromLabeled = unsafeCoerce + +toLabeled :: Eff (e : es) a -> Eff (Labeled label e : es) a +toLabeled = unsafeCoerce 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,139 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'Error' effect. +-- +-- @since 2.4.0.0 +module Effectful.Labeled.Error + ( -- * Effect + Error(..) + + -- ** Handlers + , runError + , runErrorWith + , runErrorNoCallStack + , runErrorNoCallStackWith + + -- ** Operations + , throwErrorWith + , throwError + , throwError_ + , catchError + , handleError + , tryError + + -- * Re-exports + , E.HasCallStack + , E.CallStack + , E.getCallStack + , E.prettyCallStack + ) where + +import GHC.Stack (withFrozenCallStack) + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Error.Dynamic (Error(..)) +import Effectful.Error.Dynamic qualified as E + +-- | Handle errors of type @e@ (via "Effectful.Error.Static"). +runError + :: forall label e es a + . HasCallStack + => Eff (Labeled label (Error e) : es) a + -> Eff es (Either (E.CallStack, e) a) +runError = runLabeled @label E.runError + +-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific +-- error handler. +runErrorWith + :: forall label e es a + . HasCallStack + => (E.CallStack -> e -> Eff es a) + -- ^ The error handler. + -> Eff (Labeled label (Error e) : es) a + -> Eff es a +runErrorWith = runLabeled @label . E.runErrorWith + +-- | Handle errors of type @e@ (via "Effectful.Error.Static"). In case of an +-- error discard the 'E.CallStack'. +runErrorNoCallStack + :: forall label e es a + . HasCallStack + => Eff (Labeled label (Error e) : es) a + -> Eff es (Either e a) +runErrorNoCallStack = runLabeled @label E.runErrorNoCallStack + +-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific +-- error handler. In case of an error discard the 'CallStack'. +runErrorNoCallStackWith + :: forall label e es a + . HasCallStack + => (e -> Eff es a) + -- ^ The error handler. + -> Eff (Labeled label (Error e) : es) a + -> Eff es a +runErrorNoCallStackWith = runLabeled @label . E.runErrorNoCallStackWith + +-- | Throw an error of type @e@ and specify a display function in case a +-- third-party code catches the internal exception and 'show's it. +throwErrorWith + :: forall label e es a + . (HasCallStack, Labeled label (Error e) :> es) + => (e -> String) + -- ^ The display function. + -> e + -- ^ The error. + -> Eff es a +throwErrorWith display = + withFrozenCallStack send . Labeled @label . ThrowErrorWith display + +-- | Throw an error of type @e@ with 'show' as a display function. +throwError + :: forall label e es a + . (HasCallStack, Labeled label (Error e) :> es, Show e) + => e + -- ^ The error. + -> Eff es a +throwError = withFrozenCallStack (throwErrorWith @label) show + +-- | Throw an error of type @e@ with no display function. +throwError_ + :: forall label e es a + . (HasCallStack, Labeled label (Error e) :> es) + => e + -- ^ The error. + -> Eff es a +throwError_ = withFrozenCallStack (throwErrorWith @label) (const "") + +-- | 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/Reader.hs b/src/Effectful/Labeled/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Labeled/Reader.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'Reader' effect. +-- +-- @since 2.4.0.0 +module Effectful.Labeled.Reader + ( -- * Effect + Reader(..) + + -- ** Handlers + , runReader + + -- ** Operations + , ask + , asks + , local + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Reader.Dynamic (Reader(..)) +import Effectful.Reader.Dynamic qualified as R + +-- | Run the 'Reader' effect with the given initial environment (via +-- "Effectful.Reader.Static"). +runReader + :: forall label r es a + . HasCallStack + => r + -- ^ The initial environment. + -> Eff (Labeled label (Reader r) : es) a + -> Eff es a +runReader = runLabeled @label . R.runReader + +---------------------------------------- +-- Operations + +-- | Fetch the value of the environment. +ask + :: forall label r es + . (HasCallStack, Labeled label (Reader r) :> es) + => Eff es r +ask = send $ Labeled @label Ask + +-- | Retrieve a function of the current environment. +-- +-- @'asks' f ≡ f '<$>' 'ask'@ +asks + :: forall label r es a + . (HasCallStack, Labeled label (Reader r) :> es) + => (r -> a) + -- ^ The function to apply to the environment. + -> Eff es a +asks f = f <$> ask @label + +-- | Execute a computation in a modified environment. +-- +-- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@ +-- +local + :: forall label r es a + . (HasCallStack, Labeled label (Reader r) :> es) + => (r -> r) + -- ^ The function to modify the environment. + -> Eff es a + -> Eff es a +local f = send . Labeled @label . Local f 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,177 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'State' effect. +-- +-- @since 2.4.0.0 +module Effectful.Labeled.State + ( -- * Effect + State(..) + + -- ** Handlers + + -- *** Local + , runStateLocal + , evalStateLocal + , execStateLocal + + -- *** Shared + , runStateShared + , evalStateShared + , execStateShared + + -- ** Operations + , get + , gets + , put + , state + , modify + , stateM + , modifyM + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.State.Dynamic (State(..)) +import Effectful.State.Dynamic qualified as S + +---------------------------------------- +-- Local + +-- | Run the 'State' effect with the given initial state and return the final +-- value along with the final state (via "Effectful.State.Static.Local"). +runStateLocal + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es (a, s) +runStateLocal = runLabeled @label . S.runStateLocal + +-- | Run the 'State' effect with the given initial state and return the final +-- value, discarding the final state (via "Effectful.State.Static.Local"). +evalStateLocal + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es a +evalStateLocal = runLabeled @label . S.evalStateLocal + +-- | Run the 'State' effect with the given initial state and return the final +-- state, discarding the final value (via "Effectful.State.Static.Local"). +execStateLocal + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es s +execStateLocal = runLabeled @label . S.execStateLocal + +---------------------------------------- +-- Shared + +-- | Run the 'State' effect with the given initial state and return the final +-- value along with the final state (via "Effectful.State.Static.Shared"). +runStateShared + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es (a, s) +runStateShared = runLabeled @label . S.runStateShared + +-- | Run the 'State' effect with the given initial state and return the final +-- value, discarding the final state (via "Effectful.State.Static.Shared"). +evalStateShared + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es a +evalStateShared = runLabeled @label . S.evalStateShared + +-- | Run the 'State' effect with the given initial state and return the final +-- state, discarding the final value (via "Effectful.State.Static.Shared"). +execStateShared + :: forall label s es a + . HasCallStack + => s + -- ^ The initial state. + -> Eff (Labeled label (State s) : es) a + -> Eff es s +execStateShared = runLabeled @label . S.execStateShared + +---------------------------------------- +-- Operations + +-- | Fetch the current value of the state. +get + :: forall label s es + . (HasCallStack, Labeled label (State s) :> es) + => Eff es s +get = send $ Labeled @label Get + +-- | Get a function of the current state. +-- +-- @'gets' f ≡ f '<$>' 'get'@ +gets + :: forall label s es a + . (HasCallStack, Labeled label (State s) :> es) + => (s -> a) + -- ^ . + -> Eff es a +gets f = f <$> get @label + +-- | Set the current state to the given value. +put + :: forall label s es + . (HasCallStack, Labeled label (State s) :> es) + => s + -- ^ . + -> Eff es () +put = send . Labeled @label . Put + +-- | Apply the function to the current state and return a value. +state + :: forall label s es a + . (HasCallStack, Labeled label (State s) :> es) + => (s -> (a, s)) + -- ^ . + -> Eff es a +state = send . Labeled @label . State + +-- | Apply the function to the current state. +-- +-- @'modify' f ≡ 'state' (\\s -> ((), f s))@ +modify + :: forall label s es + . (HasCallStack, Labeled label (State s) :> es) + => (s -> s) + -- ^ . + -> Eff es () +modify f = state @label (\s -> ((), f s)) + +-- | Apply the monadic function to the current state and return a value. +stateM + :: forall label s es a + . (HasCallStack, Labeled label (State s) :> es) + => (s -> Eff es (a, s)) + -- ^ . + -> Eff es a +stateM = send . Labeled @label . StateM + +-- | Apply the monadic function to the current state. +-- +-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ +modifyM + :: forall label s es + . (HasCallStack, Labeled label (State s) :> es) + => (s -> Eff es s) + -- ^ . + -> Eff es () +modifyM f = stateM @label (\s -> ((), ) <$> f s) 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,106 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Convenience functions for the 'Labeled' 'Writer' effect. +-- +-- @since 2.4.0.0 +module Effectful.Labeled.Writer + ( -- * Effect + Writer(..) + + -- ** Handlers + + -- *** Local + , runWriterLocal + , execWriterLocal + + -- *** Shared + , runWriterShared + , execWriterShared + + -- * Operations + , tell + , listen + , listens + ) where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Writer.Dynamic (Writer(..)) +import Effectful.Writer.Dynamic qualified as W + +---------------------------------------- +-- Local + +-- | Run the 'Writer' effect and return the final value along with the final +-- output (via "Effectful.Writer.Static.Local"). +runWriterLocal + :: forall label w es a + . (HasCallStack, Monoid w) + => Eff (Labeled label (Writer w) : es) + a -> Eff es (a, w) +runWriterLocal = runLabeled @label W.runWriterLocal + +-- | Run a 'Writer' effect and return the final output, discarding the final +-- value (via "Effectful.Writer.Static.Local"). +execWriterLocal + :: forall label w es a + . (HasCallStack, Monoid w) + => Eff (Labeled label (Writer w) : es) a + -> Eff es w +execWriterLocal = runLabeled @label W.execWriterLocal + +---------------------------------------- +-- Shared + +-- | Run the 'Writer' effect and return the final value along with the final +-- output (via "Effectful.Writer.Static.Shared"). +runWriterShared + :: forall label w es a + . (HasCallStack, Monoid w) + => Eff (Labeled label (Writer w) : es) a + -> Eff es (a, w) +runWriterShared = runLabeled @label W.runWriterShared + +-- | Run the 'Writer' effect and return the final output, discarding the final +-- value (via "Effectful.Writer.Static.Shared"). +execWriterShared + :: forall label w es a + . (HasCallStack, Monoid w) + => Eff (Labeled label (Writer w) : es) a + -> Eff es w +execWriterShared = runLabeled @label W.execWriterShared + +---------------------------------------- +-- Operations + +-- | Append the given output to the overall output of the 'Writer'. +tell + :: forall label w es + . (HasCallStack, Labeled label (Writer w) :> es) + => w + -> Eff es () +tell = send . Labeled @label . Tell + +-- | Execute an action and append its output to the overall output of the +-- 'Writer'. +listen + :: forall label w es a + . (HasCallStack, Labeled label (Writer w) :> es) + => Eff es a + -> Eff es (a, w) +listen = send . Labeled @label . Listen + +-- | Execute an action and append its output to the overall output of the +-- 'Writer', then return the final value along with a function of the recorded +-- output. +-- +-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@ +listens + :: forall label w es a b + . (HasCallStack, Labeled label (Writer w) :> es) + => (w -> b) + -> Eff es a + -> Eff es (a, b) +listens f m = do + (a, w) <- listen @label m + pure (a, f w) 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,144 @@ +-- | Provider of the t'Control.Applicative.Alternative' and +-- t'Control.Monad.MonadPlus' instance for 'Eff'. +module Effectful.NonDet + ( -- * Effect + NonDet(..) + , OnEmptyPolicy(..) + + -- ** Handlers + , runNonDet + + -- * Operations + , emptyEff + , plusEff + , sumEff + + -- * Re-exports + , Alternative(..) + , HasCallStack + , CallStack + , getCallStack + , prettyCallStack + ) where + +import Control.Applicative +import Data.IORef.Strict +import GHC.Generics +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Error.Static +import Effectful.Internal.Env qualified as I +import Effectful.Internal.Monad (NonDet(..)) + +-- | Policy of dealing with modifications to __thread local__ state in the +-- environment in branches that end up calling the 'Empty' operation. +-- +-- /Note:/ 'OnEmptyKeep' is faster as there is no need to back up the +-- environment on each call to ':<|>:'. +-- +-- @since 2.2.0.0 +data OnEmptyPolicy + = OnEmptyKeep + -- ^ Keep modifications on 'Empty'. + | OnEmptyRollback + -- ^ Rollback modifications on 'Empty'. + -- + -- /Note:/ state modifications are rolled back on 'Empty' only. In particular, + -- they are __not__ rolled back on exceptions. + deriving stock (Eq, Generic, Ord, Show) + +-- | Run the 'NonDet' effect with a given 'OnEmptyPolicy'. +-- +-- /Note:/ ':<|>:' executes the second computation if (and only if) the first +-- computation calls 'Empty'. +-- +-- @since 2.2.0.0 +runNonDet + :: HasCallStack + => OnEmptyPolicy + -> Eff (NonDet : es) a + -> Eff es (Either CallStack a) +runNonDet = \case + OnEmptyKeep -> runNonDetKeep + OnEmptyRollback -> runNonDetRollback + +runNonDetKeep + :: HasCallStack + => Eff (NonDet : es) a + -> Eff es (Either CallStack a) +runNonDetKeep = reinterpret (fmap noError . runError @ErrorEmpty) $ \env -> \case + Empty -> throwError ErrorEmpty + m1 :<|>: m2 -> localSeqUnlift env $ \unlift -> do + mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> pure Nothing + case mr of + Just r -> pure r + Nothing -> unlift m2 + +runNonDetRollback + :: HasCallStack + => Eff (NonDet : es) a + -> Eff es (Either CallStack a) +runNonDetRollback = reinterpret setup $ \env -> \case + Empty -> throwError ErrorEmpty + m1 :<|>: m2 -> do + backupData <- unsafeEff backupStorageData + localSeqUnlift env $ \unlift -> do + mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> do + -- If m1 failed, restore the data. + unsafeEff $ I.restoreStorageData backupData + pure Nothing + case mr of + Just r -> pure r + Nothing -> unlift m2 + where + setup action = do + backupData <- unsafeEff backupStorageData + runError @ErrorEmpty action >>= \case + Right r -> pure $ Right r + Left (cs, _) -> do + -- If the whole action failed, restore the data. + unsafeEff $ I.restoreStorageData backupData + pure $ Left cs + +---------------------------------------- + +-- | Specialized version of 'empty' with the 'HasCallStack' constraint for +-- tracking purposes. +-- +-- @since 2.2.0.0 +emptyEff :: (HasCallStack, NonDet :> es) => Eff es a +emptyEff = withFrozenCallStack send Empty + +-- | Specialized version of '<|>' with the `HasCallStack` constraint for +-- tracking purposes. +-- +-- @since 2.5.0.0 +plusEff :: (HasCallStack, NonDet :> es) => Eff es a -> Eff es a -> Eff es a +plusEff m1 m2 = send (m1 :<|>: m2) +infixl 3 `plusEff` -- same as <|> + +-- | Specialized version of 'asum' with the 'HasCallStack' constraint for +-- tracking purposes. +-- +-- @since 2.2.0.0 +sumEff :: (HasCallStack, Foldable t, NonDet :> es) => t (Eff es a) -> Eff es a +sumEff = foldr plusEff emptyEff + +---------------------------------------- +-- Internal helpers + +-- | Internal error type for the Empty action. Better than '()' in case it +-- escapes the scope of 'runNonDet' and shows up in error messages. +data ErrorEmpty = ErrorEmpty +instance Show ErrorEmpty where + show ErrorEmpty = "Effectful.NonDet.ErrorEmpty" + +noError :: Either (cs, e) a -> Either cs a +noError = either (Left . fst) Right + +backupStorageData :: HasCallStack => Env es -> IO I.StorageData +backupStorageData env = I.copyStorageData . I.stData =<< readIORef' (I.envStorage env) 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,230 @@ +{-# LANGUAGE ImplicitParams #-} +-- | Turn an effect handler into an effectful operation. +-- +-- @since 2.3.0.0 +module Effectful.Provider + ( -- * Example + -- $example + + -- * Effect + Provider + , Provider_ + + -- ** Handlers + , runProvider + , runProvider_ + + -- ** Operations + , provide + , provide_ + , provideWith + , provideWith_ + ) where + +import Control.Monad +import Data.Coerce +import Data.Functor.Identity +import Data.Kind (Type) +import Data.Primitive.PrimArray +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Internal.Env (Env(..)) +import Effectful.Internal.Utils + +-- $example +-- +-- >>> import Control.Monad.IO.Class +-- >>> import Data.Map.Strict qualified as M +-- >>> import Effectful.Dispatch.Dynamic +-- >>> import Effectful.State.Static.Local +-- +-- Given an effect: +-- +-- >>> :{ +-- data Write :: Effect where +-- Write :: String -> Write m () +-- type instance DispatchOf Write = Dynamic +-- :} +-- +-- >>> :{ +-- write :: Write :> es => String -> Eff es () +-- write = send . Write +-- :} +-- +-- its handler can be turned into an effectful operation with the 'Provider' +-- effect: +-- +-- >>> :{ +-- action :: Provider_ Write FilePath :> es => Eff es () +-- action = do +-- provideWith_ @Write "in.txt" $ do +-- write "hi" +-- write "there" +-- provideWith_ @Write "out.txt" $ do +-- write "good" +-- write "bye" +-- :} +-- +-- Then, given multiple interpreters: +-- +-- >>> :{ +-- runWriteIO +-- :: IOE :> es +-- => FilePath +-- -> Eff (Write : es) a +-- -> Eff es a +-- runWriteIO fp = interpret_ $ \case +-- Write msg -> liftIO . putStrLn $ fp ++ ": " ++ msg +-- :} +-- +-- >>> :{ +-- runWritePure +-- :: State (M.Map FilePath [String]) :> es +-- => FilePath +-- -> Eff (Write : es) a +-- -> Eff es a +-- runWritePure fp = interpret_ $ \case +-- Write msg -> modify $ M.insertWith (++) fp [msg] +-- :} +-- +-- @action@ can be supplied with either of them for the appropriate behavior: +-- +-- >>> :{ +-- runEff +-- . runProvider_ runWriteIO +-- $ action +-- :} +-- in.txt: hi +-- in.txt: there +-- out.txt: good +-- out.txt: bye +-- +-- >>> :{ +-- runPureEff +-- . fmap (fmap reverse) +-- . execState @(M.Map FilePath [String]) M.empty +-- . runProvider_ runWritePure +-- $ action +-- :} +-- fromList [("in.txt",["hi","there"]),("out.txt",["good","bye"])] + +-- | Provide a way to run a handler of @e@ with a given @input@. +-- +-- /Note:/ @f@ can be used to alter the return type of the effect handler. If +-- that's unnecessary, use 'Provider_'. +data Provider (e :: Effect) (input :: Type) (f :: Type -> Type) :: Effect + +-- | A restricted variant of 'Provider' with unchanged return type of the effect +-- handler. +type Provider_ e input = Provider e input Identity + +type instance DispatchOf (Provider e input f) = Static NoSideEffects + +-- | Wrapper to prevent a space leak on reconstruction of 'Provider' in +-- 'relinkProvider' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520). +newtype ProviderImpl input f e es where + ProviderImpl + :: (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r)) + -> ProviderImpl input f e es + +data instance StaticRep (Provider e input f) where + Provider + :: !(Env handlerEs) + -> !(ProviderImpl input f e handlerEs) + -> StaticRep (Provider e input f) + +-- | Run the 'Provider' effect with a given effect handler. +runProvider + :: HasCallStack + => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r)) + -- ^ The effect handler. + -> Eff (Provider e input f : es) a + -> Eff es a +runProvider provider action = runProviderImpl action $ + ProviderImpl (let ?callStack = thawCallStack ?callStack in provider) + +-- | Run the 'Provider' effect with a given effect handler that doesn't change +-- its return type. +runProvider_ + :: HasCallStack + => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r) + -- ^ The effect handler. + -> Eff (Provider_ e input : es) a + -> Eff es a +runProvider_ provider action = runProviderImpl action $ + ProviderImpl $ let ?callStack = thawCallStack ?callStack + in \input -> coerce . provider input + +-- | Run the effect handler. +provide :: (HasCallStack, Provider e () f :> es) => Eff (e : es) a -> Eff es (f a) +provide = provideWith () + +-- | Run the effect handler with unchanged return type. +provide_ :: (HasCallStack, Provider_ e () :> es) => Eff (e : es) a -> Eff es a +provide_ = provideWith_ () + +-- | Run the effect handler with a given input. +provideWith + :: (HasCallStack, Provider e input f :> es) + => input + -- ^ The input to the effect handler. + -> Eff (e : es) a + -> Eff es (f a) +provideWith input action = unsafeEff $ \es -> do + Provider handlerEs (ProviderImpl handler) <- getEnv es + (`unEff` handlerEs) + -- Corresponds to thawCallStack in runProvider. + . withFrozenCallStack handler input + . unsafeEff $ \eProviderEs -> do + unEff action =<< copyRef eProviderEs es + +-- | Run the effect handler that doesn't change its return type with a given +-- input. +provideWith_ + :: (HasCallStack, Provider_ e input :> es) + => input + -- ^ The input to the effect handler. + -> Eff (e : es) a + -> Eff es a +provideWith_ input = adapt . provideWith input + where + adapt :: Eff es (Identity a) -> Eff es a + adapt = coerce + +---------------------------------------- +-- Helpers + +runProviderImpl + :: HasCallStack + => Eff (Provider e input f : es) a + -> ProviderImpl input f e es + -> Eff es a +runProviderImpl action providerImpl = unsafeEff $ \es -> do + inlineBracket + (consEnv (Provider es providerImpl) relinkProvider es) + unconsEnv + (unEff action) +{-# INLINE runProviderImpl #-} + +relinkProvider :: Relinker StaticRep (Provider e input f) +relinkProvider = Relinker $ \relink (Provider handlerEs run) -> do + newHandlerEs <- relink handlerEs + pure $ Provider newHandlerEs run + +copyRef + :: HasCallStack + => Env (e : handlerEs) + -> Env es + -> IO (Env (e : es)) +copyRef (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do + when (hstorage /= storage) $ do + error "storages do not match" + let size = sizeofPrimArray refs0 - offset + mrefs <- newPrimArray (size + 1) + writePrimArray mrefs 0 $ indexPrimArray hrefs hoffset + copyPrimArray mrefs 1 refs0 offset size + refs <- unsafeFreezePrimArray mrefs + pure $ Env 0 refs storage 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,171 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ImplicitParams #-} +-- | Turn a handler of multiple effects into an effectful operation. +-- +-- Generalizes "Effectful.Provider". +-- +-- @since 2.3.1.0 +module Effectful.Provider.List + ( -- * Effect + ProviderList + , ProviderList_ + + -- ** Handlers + , runProviderList + , runProviderList_ + + -- ** Operations + , provideList + , provideList_ + , provideListWith + , provideListWith_ + + -- * Misc + , type (++) + , KnownEffects + ) where + +import Control.Monad +import Data.Coerce +import Data.Functor.Identity +import Data.Primitive.PrimArray +import GHC.Stack + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Internal.Effect +import Effectful.Internal.Env (Env(..)) +import Effectful.Internal.Utils + +-- | Provide a way to run a handler of multiple @providedEs@ with a given +-- @input@. +-- +-- /Note:/ @f@ can be used to alter the return type of the handler. If that's +-- unnecessary, use 'ProviderList_'. +data ProviderList (providedEs :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect + +-- | A restricted variant of 'ProviderList' with unchanged return type of the +-- handler. +type ProviderList_ providedEs input = ProviderList providedEs input Identity + +type instance DispatchOf (ProviderList providedEs input f) = Static NoSideEffects + +-- | Wrapper to prevent a space leak on reconstruction of 'ProviderList' in +-- 'relinkProviderList' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520). +newtype ProviderListImpl input f providedEs es where + ProviderListImpl + :: (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r)) + -> ProviderListImpl input f providedEs es + +data instance StaticRep (ProviderList providedEs input f) where + ProviderList + :: KnownEffects providedEs + => !(Env handlerEs) + -> !(ProviderListImpl input f providedEs handlerEs) + -> StaticRep (ProviderList providedEs input f) + +-- | Run the 'ProviderList' effect with a given handler. +runProviderList + :: (HasCallStack, KnownEffects providedEs) + => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r)) + -- ^ The handler. + -> Eff (ProviderList providedEs input f : es) a + -> Eff es a +runProviderList providerList action = runProviderListImpl action $ + ProviderListImpl (let ?callStack = thawCallStack ?callStack in providerList) + +-- | Run the 'Provider' effect with a given handler that doesn't change its +-- return type. +runProviderList_ + :: (HasCallStack, KnownEffects providedEs) + => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r) + -- ^ The handler. + -> Eff (ProviderList_ providedEs input : es) a + -> Eff es a +runProviderList_ providerList action = runProviderListImpl action $ + ProviderListImpl $ let ?callStack = thawCallStack ?callStack + in \input -> coerce . providerList input + +-- | Run the handler. +provideList + :: forall providedEs f es a + . (HasCallStack, ProviderList providedEs () f :> es) + => Eff (providedEs ++ es) a + -> Eff es (f a) +provideList = provideListWith @providedEs () + +-- | Run the handler with unchanged return type. +provideList_ + :: forall providedEs es a + . (HasCallStack, ProviderList_ providedEs () :> es) + => Eff (providedEs ++ es) a + -> Eff es a +provideList_ = provideListWith_ @providedEs () + +-- | Run the handler with a given input. +provideListWith + :: forall providedEs input f es a + . (HasCallStack, ProviderList providedEs input f :> es) + => input + -- ^ The input to the handler. + -> Eff (providedEs ++ es) a + -> Eff es (f a) +provideListWith input action = unsafeEff $ \es -> do + ProviderList (handlerEs :: Env handlerEs) (ProviderListImpl providerList) <- do + getEnv @(ProviderList providedEs input f) es + (`unEff` handlerEs) + -- Corresponds to a thawCallStack in runProviderList. + . withFrozenCallStack providerList input + . unsafeEff $ \eHandlerEs -> do + unEff action =<< copyRefs @providedEs @handlerEs eHandlerEs es + +-- | Run the handler that doesn't change its return type with a given input. +provideListWith_ + :: forall providedEs input es a + . (HasCallStack, ProviderList_ providedEs input :> es) + => input + -- ^ The input to the handler. + -> Eff (providedEs ++ es) a + -> Eff es a +provideListWith_ input = adapt . provideListWith @providedEs input + where + adapt :: Eff es (Identity a) -> Eff es a + adapt = coerce + +---------------------------------------- +-- Helpers + +runProviderListImpl + :: (HasCallStack, KnownEffects providedEs) + => Eff (ProviderList providedEs input f : es) a + -> ProviderListImpl input f providedEs es + -> Eff es a +runProviderListImpl action providerListImpl = unsafeEff $ \es -> do + inlineBracket + (consEnv (ProviderList es providerListImpl) relinkProviderList es) + unconsEnv + (unEff action) +{-# INLINE runProviderListImpl #-} + +relinkProviderList :: Relinker StaticRep (ProviderList e input f) +relinkProviderList = Relinker $ \relink (ProviderList handlerEs run) -> do + newHandlerEs <- relink handlerEs + pure $ ProviderList newHandlerEs run + +copyRefs + :: forall providedEs handlerEs es + . (HasCallStack, KnownEffects providedEs) + => Env (providedEs ++ handlerEs) + -> Env es + -> IO (Env (providedEs ++ es)) +copyRefs (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do + when (hstorage /= storage) $ do + error "storages do not match" + let providedEsSize = knownEffectsLength @providedEs + esSize = sizeofPrimArray refs0 - offset + mrefs <- newPrimArray (providedEsSize + esSize) + copyPrimArray mrefs 0 hrefs hoffset providedEsSize + copyPrimArray mrefs providedEsSize refs0 offset esSize + refs <- unsafeFreezePrimArray mrefs + pure $ Env 0 refs storage 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.MTL (Reader(..)) --- | Run the 'Reader' effect with the given initial environment (via --- "Effectful.Reader.Static"). +-- | Run the 'Reader' effect with the given initial environment. runReader - :: r -- ^ The initial environment. + :: HasCallStack + => r -- ^ The initial environment. -> Eff (Reader r : es) a -> Eff es a -runReader r = reinterpret (R.runReader r) $ \env -> \case - Ask -> R.ask - Local f m -> localSeqUnlift env $ \unlift -> R.local f (unlift m) +runReader r0 = interpret $ handler r0 + where + handler :: r -> EffectHandler (Reader r) es + handler r env = \case + Ask -> pure r + Local f action -> localSeqUnlift env $ \unlift -> do + unlift $ interpose (handler $ f r) action -- | Execute a computation in a modified environment. -- -- @since 1.1.0.0 withReader - :: (r1 -> r2) + :: HasCallStack + => (r1 -> r2) -- ^ The function to modify the environment. -> Eff (Reader r2 : es) a -- ^ Computation to run in the modified environment. @@ -49,6 +49,7 @@ withReader f m = do r <- ask raise $ runReader (f r) m +{-# DEPRECATED withReader "withReader doesn't work correctly for all potential interpreters" #-} ---------------------------------------- -- Operations 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 @@ -13,19 +13,22 @@ , local ) where +import Data.Kind + import Effectful import Effectful.Dispatch.Static -- | Provide access to a strict (WHNF), thread local, read only value of type -- @r@. -data Reader r :: Effect +data Reader (r :: Type) :: Effect type instance DispatchOf (Reader r) = Static NoSideEffects newtype instance StaticRep (Reader r) = Reader r -- | Run a 'Reader' effect with the given initial environment. runReader - :: r -- ^ The initial environment. + :: HasCallStack + => r -- ^ The initial environment. -> Eff (Reader r : es) a -> Eff es a runReader r = evalStaticRep (Reader r) @@ -34,7 +37,8 @@ -- -- @since 1.1.0.0 withReader - :: (r1 -> r2) + :: HasCallStack + => (r1 -> r2) -- ^ The function to modify the environment. -> Eff (Reader r2 : es) a -- ^ Computation to run in the modified environment. @@ -44,7 +48,7 @@ raise $ runReader (f r) m -- | Fetch the value of the environment. -ask :: Reader r :> es => Eff es r +ask :: (HasCallStack, Reader r :> es) => Eff es r ask = do Reader r <- getStaticRep pure r @@ -53,7 +57,7 @@ -- -- @'asks' f ≡ f '<$>' 'ask'@ asks - :: Reader r :> es + :: (HasCallStack, Reader r :> es) => (r -> a) -- ^ The function to apply to the environment. -> Eff es a asks f = f <$> ask @@ -63,7 +67,7 @@ -- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@ -- local - :: Reader r :> es + :: (HasCallStack, Reader r :> es) => (r -> r) -- ^ The function to modify the environment. -> Eff es a -> Eff es a 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,8 @@ -- | The dynamically dispatched variant of the 'State' effect. -- --- /Note:/ unless you plan to change interpretations at runtime, it's --- recommended to use one of the statically dispatched variants, +-- /Note:/ unless you plan to change interpretations at runtime or you need the +-- t'Control.Monad.State.MonadState' instance for compatibility with existing +-- code, it's recommended to use one of the statically dispatched variants, -- i.e. "Effectful.State.Static.Local" or "Effectful.State.Static.Shared". module Effectful.State.Dynamic ( -- * Effect @@ -31,41 +32,29 @@ import Effectful import Effectful.Dispatch.Dynamic -import qualified Effectful.State.Static.Local as L -import qualified Effectful.State.Static.Shared as S - --- | Provide access to a mutable value of type @s@. -data State s :: Effect where - Get :: State s m s - Put :: s -> State s m () - State :: (s -> (a, s)) -> State s m a - StateM :: (s -> m (a, s)) -> State s m a - -type instance DispatchOf (State s) = Dynamic +import Effectful.Internal.MTL (State(..)) +import Effectful.State.Static.Local qualified as L +import Effectful.State.Static.Shared qualified as S ---------------------------------------- -- Local -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state (via "Effectful.State.Static.Local"). -runStateLocal :: s -> Eff (State s : es) a -> Eff es (a, s) +runStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runStateLocal s0 = reinterpret (L.runState s0) localState -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state (via "Effectful.State.Static.Local"). -evalStateLocal :: s -> Eff (State s : es) a -> Eff es a +evalStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalStateLocal s0 = reinterpret (L.evalState s0) localState -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value (via "Effectful.State.Static.Local"). -execStateLocal :: s -> Eff (State s : es) a -> Eff es s +execStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execStateLocal s0 = reinterpret (L.execState s0) localState -localState - :: L.State s :> es - => LocalEnv localEs es - -> State s (Eff localEs) a - -> Eff es a +localState :: L.State s :> es => EffectHandler (State s) es localState env = \case Get -> L.get Put s -> L.put s @@ -77,24 +66,20 @@ -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state (via "Effectful.State.Static.Shared"). -runStateShared :: s -> Eff (State s : es) a -> Eff es (a, s) +runStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runStateShared s0 = reinterpret (S.runState s0) sharedState -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state (via "Effectful.State.Static.Shared"). -evalStateShared :: s -> Eff (State s : es) a -> Eff es a +evalStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalStateShared s0 = reinterpret (S.evalState s0) sharedState -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value (via "Effectful.State.Static.Shared"). -execStateShared :: s -> Eff (State s : es) a -> Eff es s +execStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execStateShared s0 = reinterpret (S.execState s0) sharedState -sharedState - :: S.State s :> es - => LocalEnv localEs es - -> State s (Eff localEs) a - -> Eff es a +sharedState :: S.State s :> es => EffectHandler (State s) es sharedState env = \case Get -> S.get Put s -> S.put s 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,7 @@ -- -- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ modifyM - :: State s :> es + :: (HasCallStack, State s :> es) => (s -> Eff es s) -- ^ The monadic function to modify the state. -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s) - --- $setup --- >>> import Control.Exception (ErrorCall) --- >>> import Control.Monad.Catch 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,109 @@ , modifyM ) where -import Control.Concurrent.MVar +import Control.Concurrent.MVar.Strict +import Data.Kind import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive -- | Provide access to a strict (WHNF), shared, mutable value of type @s@. -data State s :: Effect +data State (s :: Type) :: Effect type instance DispatchOf (State s) = Static NoSideEffects -newtype instance StaticRep (State s) = State (MVar s) +newtype instance StaticRep (State s) = State (MVar' s) -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state. -runState :: s -> Eff (State s : es) a -> Eff es (a, s) +runState :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runState s m = do - v <- unsafeEff_ $ newMVar s + v <- unsafeEff_ $ newMVar' s a <- evalStaticRep (State v) m - (a, ) <$> unsafeEff_ (readMVar v) + (a, ) <$> unsafeEff_ (readMVar' v) -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state. -evalState :: s -> Eff (State s : es) a -> Eff es a +evalState :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalState s m = do - v <- unsafeEff_ $ newMVar s + v <- unsafeEff_ $ newMVar' s evalStaticRep (State v) m -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value. -execState :: s -> Eff (State s : es) a -> Eff es s +execState :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execState s m = do - v <- unsafeEff_ $ newMVar s + v <- unsafeEff_ $ newMVar' s _ <- evalStaticRep (State v) m - unsafeEff_ $ readMVar v + unsafeEff_ $ readMVar' v --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | Run the 'State' effect with the given initial state 'MVar'' and return the -- final value along with the final state. -runStateMVar :: MVar s -> Eff (State s : es) a -> Eff es (a, s) +runStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es (a, s) runStateMVar v m = do a <- evalStaticRep (State v) m - (a, ) <$> unsafeEff_ (readMVar v) + (a, ) <$> unsafeEff_ (readMVar' v) --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | Run the 'State' effect with the given initial state 'MVar'' and return the -- final value, discarding the final state. -evalStateMVar :: MVar s -> Eff (State s : es) a -> Eff es a -evalStateMVar v m = do - evalStaticRep (State v) m +evalStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es a +evalStateMVar v = evalStaticRep (State v) --- | Run the 'State' effect with the given initial state 'MVar' and return the +-- | Run the 'State' effect with the given initial state 'MVar'' and return the -- final state, discarding the final value. -execStateMVar :: MVar s -> Eff (State s : es) a -> Eff es s +execStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es s execStateMVar v m = do _ <- evalStaticRep (State v) m - unsafeEff_ $ readMVar v + unsafeEff_ $ readMVar' v -- | Fetch the current value of the state. -get :: State s :> es => Eff es s +get :: (HasCallStack, State s :> es) => Eff es s get = unsafeEff $ \es -> do State v <- getEnv es - readMVar v + readMVar' v -- | Get a function of the current state. -- -- @'gets' f ≡ f '<$>' 'get'@ -gets :: State s :> es => (s -> a) -> Eff es a +gets :: (HasCallStack, State s :> es) => (s -> a) -> Eff es a gets f = f <$> get -- | Set the current state to the given value. -put :: State s :> es => s -> Eff es () +put :: (HasCallStack, State s :> es) => s -> Eff es () put s = unsafeEff $ \es -> do State v <- getEnv es - modifyMVar_ v $ \_ -> s `seq` pure s + modifyMVar'_ v $ \_ -> pure s -- | Apply the function to the current state and return a value. -- -- /Note:/ this function gets an exclusive access to the state for its duration. -state :: State s :> es => (s -> (a, s)) -> Eff es a +state :: (HasCallStack, State s :> es) => (s -> (a, s)) -> Eff es a state f = unsafeEff $ \es -> do State v <- getEnv es - modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a) + modifyMVar' v $ \s0 -> let (a, s) = f s0 in pure (s, a) -- | Apply the function to the current state. -- -- @'modify' f ≡ 'state' (\\s -> ((), f s))@ -- -- /Note:/ this function gets an exclusive access to the state for its duration. -modify :: State s :> es => (s -> s) -> Eff es () +modify :: (HasCallStack, State s :> es) => (s -> s) -> Eff es () modify f = state (\s -> ((), f s)) -- | Apply the monadic function to the current state and return a value. -- -- /Note:/ this function gets an exclusive access to the state for its duration. -stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a +stateM :: (HasCallStack, State s :> es) => (s -> Eff es (a, s)) -> Eff es a stateM f = unsafeEff $ \es -> do State v <- getEnv es - modifyMVar v $ \s0 -> do + modifyMVar' v $ \s0 -> do (a, s) <- unEff (f s0) es - s `seq` pure (s, a) + pure (s, a) -- | Apply the monadic function to the current state. -- -- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ -- -- /Note:/ this function gets an exclusive access to the state for its duration. -modifyM :: State s :> es => (s -> Eff es s) -> Eff es () +modifyM :: (HasCallStack, State s :> es) => (s -> Eff es s) -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s) - --- $setup --- >>> import Control.Exception (ErrorCall) --- >>> import Control.Monad.Catch 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,7 +1,9 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- | The dynamically dispatched variant of the 'Writer' effect. -- --- /Note:/ unless you plan to change interpretations at runtime, it's --- recommended to use one of the statically dispatched variants, +-- /Note:/ unless you plan to change interpretations at runtime or you need the +-- t'Control.Monad.Writer.MonadWriter' instance for compatibility with existing +-- code, it's recommended to use one of the statically dispatched variants, -- i.e. "Effectful.Writer.Static.Local" or "Effectful.Writer.Static.Shared". module Effectful.Writer.Dynamic ( -- * Effect @@ -25,34 +27,24 @@ import Effectful import Effectful.Dispatch.Dynamic -import qualified Effectful.Writer.Static.Local as L -import qualified Effectful.Writer.Static.Shared as S - --- | Provide access to a write only value of type @w@. -data Writer w :: Effect where - Tell :: w -> Writer w m () - Listen :: m a -> Writer w m (a, w) - -type instance DispatchOf (Writer w) = Dynamic +import Effectful.Internal.MTL (Writer(..)) +import Effectful.Writer.Static.Local qualified as L +import Effectful.Writer.Static.Shared qualified as S ---------------------------------------- -- Local -- | Run the 'Writer' effect and return the final value along with the final -- output (via "Effectful.Writer.Static.Local"). -runWriterLocal :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w) +runWriterLocal :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriterLocal = reinterpret L.runWriter localWriter -- | Run a 'Writer' effect and return the final output, discarding the final -- value (via "Effectful.Writer.Static.Local"). -execWriterLocal :: Monoid w => Eff (Writer w : es) a -> Eff es w +execWriterLocal :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriterLocal = reinterpret L.execWriter localWriter -localWriter - :: (L.Writer w :> es, Monoid w) - => LocalEnv localEs es - -> Writer w (Eff localEs) a - -> Eff es a +localWriter :: (L.Writer w :> es, Monoid w) => EffectHandler (Writer w) es localWriter env = \case Tell w -> L.tell w Listen m -> localSeqUnlift env $ \unlift -> L.listen (unlift m) @@ -62,19 +54,15 @@ -- | Run the 'Writer' effect and return the final value along with the final -- output (via "Effectful.Writer.Static.Shared"). -runWriterShared :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w) +runWriterShared :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriterShared = reinterpret S.runWriter sharedWriter -- | Run the 'Writer' effect and return the final output, discarding the final -- value (via "Effectful.Writer.Static.Shared"). -execWriterShared :: Monoid w => Eff (Writer w : es) a -> Eff es w +execWriterShared :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriterShared = reinterpret S.execWriter sharedWriter -sharedWriter - :: (S.Writer w :> es, Monoid w) - => LocalEnv localEs es - -> Writer w (Eff localEs) a - -> Eff es a +sharedWriter :: (S.Writer w :> es, Monoid w) => EffectHandler (Writer w) es sharedWriter env = \case Tell w -> S.tell w Listen m -> localSeqUnlift env $ \unlift -> S.listen (unlift m) 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 @@ -28,6 +28,7 @@ ) where import Control.Exception (onException, mask) +import Data.Kind import Effectful import Effectful.Dispatch.Static @@ -35,27 +36,27 @@ -- | Provide access to a strict (WHNF), thread local, write only value of type -- @w@. -data Writer w :: Effect +data Writer (w :: Type) :: Effect type instance DispatchOf (Writer w) = Static NoSideEffects newtype instance StaticRep (Writer w) = Writer w -- | Run a 'Writer' effect and return the final value along with the final -- output. -runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w) +runWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriter m = do (a, Writer w) <- runStaticRep (Writer mempty) m pure (a, w) -- | Run a 'Writer' effect and return the final output, discarding the final -- value. -execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w +execWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriter m = do Writer w <- execStaticRep (Writer mempty) m pure w -- | Append the given output to the overall output of the 'Writer'. -tell :: (Writer w :> es, Monoid w) => w -> Eff es () +tell :: (HasCallStack, Writer w :> es, Monoid w) => w -> Eff es () tell w = stateStaticRep $ \(Writer w0) -> ((), Writer (w0 <> w)) -- | Execute an action and append its output to the overall output of the @@ -75,26 +76,30 @@ -- error "oops" -- :} -- "Hi there!" -listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) +listen :: (HasCallStack, Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) listen m = unsafeEff $ \es -> mask $ \unmask -> do - w0 <- stateEnv es $ \(Writer w) -> pure (w, Writer mempty) + w0 <- stateEnv es $ \(Writer w) -> (w, Writer mempty) a <- unmask (unEff m es) `onException` merge es w0 (a, ) <$> merge es w0 where merge es w0 = -- If an exception is thrown, restore w0 and keep parts of w1. - stateEnv es $ \(Writer w1) -> pure (w1, Writer (w0 <> w1)) + stateEnv es $ \(Writer w1) -> (w1, Writer (w0 <> w1)) -- | Execute an action and append its output to the overall output of the -- 'Writer', then return the final value along with a function of the recorded -- output. -- -- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@ -listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b) +listens + :: (HasCallStack, Writer w :> es, Monoid w) + => (w -> b) + -> Eff es a + -> Eff es (a, b) listens f m = do (a, w) <- listen m pure (a, f w) -- $setup -- >>> import Control.Exception (ErrorCall) --- >>> import Control.Monad.Catch +-- >>> import Effectful.Exception 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 @@ -27,40 +27,41 @@ , listens ) where -import Control.Concurrent.MVar +import Control.Concurrent.MVar.Strict import Control.Exception (onException, uninterruptibleMask) +import Data.Kind import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive -- | Provide access to a strict (WHNF), shared, write only value of type @w@. -data Writer w :: Effect +data Writer (w :: Type) :: Effect type instance DispatchOf (Writer w) = Static NoSideEffects -newtype instance StaticRep (Writer w) = Writer (MVar w) +newtype instance StaticRep (Writer w) = Writer (MVar' w) -- | Run a 'Writer' effect and return the final value along with the final -- output. -runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w) +runWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriter m = do - v <- unsafeEff_ $ newMVar mempty + v <- unsafeEff_ $ newMVar' mempty a <- evalStaticRep (Writer v) m - (a, ) <$> unsafeEff_ (readMVar v) + (a, ) <$> unsafeEff_ (readMVar' v) -- | Run a 'Writer' effect and return the final output, discarding the final -- value. -execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w +execWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriter m = do - v <- unsafeEff_ $ newMVar mempty + v <- unsafeEff_ $ newMVar' mempty _ <- evalStaticRep (Writer v) m - unsafeEff_ $ readMVar v + unsafeEff_ $ readMVar' v -- | Append the given output to the overall output of the 'Writer'. -tell :: (Writer w :> es, Monoid w) => w -> Eff es () +tell :: (HasCallStack, Writer w :> es, Monoid w) => w -> Eff es () tell w1 = unsafeEff $ \es -> do Writer v <- getEnv es - modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w + modifyMVar'_ v $ \w0 -> let w = w0 <> w1 in pure w -- | Execute an action and append its output to the overall output of the -- 'Writer'. @@ -79,15 +80,15 @@ -- error "oops" -- :} -- "Hi there!" -listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) +listen :: (HasCallStack, Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) listen m = unsafeEff $ \es -> do -- The mask is uninterruptible because modifyMVar_ v0 in the merge function -- might block and if an async exception is received while waiting, w1 will be -- lost. uninterruptibleMask $ \unmask -> do - v1 <- newMVar mempty + v1 <- newMVar' mempty -- Replace thread local MVar with a fresh one for isolated listening. - v0 <- stateEnv es $ \(Writer v) -> pure (v, Writer v1) + v0 <- stateEnv es $ \(Writer v) -> (v, Writer v1) a <- unmask (unEff m es) `onException` merge es v0 v1 (a, ) <$> merge es v0 v1 where @@ -95,8 +96,8 @@ -- exception was received while listening, merge results recorded so far. merge es v0 v1 = do putEnv es $ Writer v0 - w1 <- readMVar v1 - modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w + w1 <- readMVar' v1 + modifyMVar'_ v0 $ \w0 -> let w = w0 <> w1 in pure w pure w1 -- | Execute an action and append its output to the overall output of the @@ -104,11 +105,15 @@ -- output. -- -- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@ -listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b) +listens + :: (HasCallStack, Writer w :> es, Monoid w) + => (w -> b) + -> Eff es a + -> Eff es (a, b) listens f m = do (a, w) <- listen m pure (a, f w) -- $setup -- >>> import Control.Exception (ErrorCall) --- >>> import Control.Monad.Catch +-- >>> import Effectful.Exception 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; -}