effectful-core 2.3.1.0 → 2.7.0.0
raw patch · 52 files changed
Files
- CHANGELOG.md +150/−0
- README.md +2/−3
- cbits/utils.c +0/−5
- effectful-core.cabal +43/−28
- src/Effectful.hs +4/−4
- src/Effectful/Dispatch/Dynamic.hs +597/−215
- src/Effectful/Dispatch/Static.hs +1/−0
- src/Effectful/Dispatch/Static/Primitive.hs +0/−1
- src/Effectful/Dispatch/Static/Unsafe.hs +0/−47
- src/Effectful/Error/Dynamic.hs +93/−17
- src/Effectful/Error/Static.hs +150/−64
- src/Effectful/Exception.hs +659/−0
- src/Effectful/Fail.hs +4/−4
- src/Effectful/Input/Dynamic.hs +68/−0
- src/Effectful/Input/Static.hs +49/−0
- src/Effectful/Input/Static/Action.hs +79/−0
- src/Effectful/Internal/Effect.hs +19/−26
- src/Effectful/Internal/Effect/Dynamic.hs +99/−0
- src/Effectful/Internal/Env.hs +345/−159
- src/Effectful/Internal/Monad.hs +296/−90
- src/Effectful/Internal/Unlift.hs +383/−194
- src/Effectful/Internal/Utils.hs +23/−96
- src/Effectful/Internal/Utils/Word64Map.hs +162/−0
- src/Effectful/Labeled.hs +29/−36
- src/Effectful/Labeled/Error.hs +192/−0
- src/Effectful/Labeled/Input.hs +65/−0
- src/Effectful/Labeled/Output.hs +90/−0
- src/Effectful/Labeled/Provider.hs +98/−0
- src/Effectful/Labeled/Provider/List.hs +100/−0
- src/Effectful/Labeled/Reader.hs +70/−0
- src/Effectful/Labeled/ReturnWith.hs +43/−0
- src/Effectful/Labeled/State.hs +186/−0
- src/Effectful/Labeled/Writer.hs +109/−0
- src/Effectful/NonDet.hs +75/−34
- src/Effectful/Output/Dynamic.hs +86/−0
- src/Effectful/Output/Static/Action.hs +72/−0
- src/Effectful/Output/Static/Local/Array.hs +79/−0
- src/Effectful/Output/Static/Local/List.hs +39/−0
- src/Effectful/Output/Static/Shared/Array.hs +77/−0
- src/Effectful/Output/Static/Shared/List.hs +43/−0
- src/Effectful/Provider.hs +62/−54
- src/Effectful/Provider/List.hs +54/−75
- src/Effectful/Reader/Dynamic.hs +17/−16
- src/Effectful/Reader/Static.hs +14/−6
- src/Effectful/ReturnWith/Dynamic.hs +49/−0
- src/Effectful/ReturnWith/Static.hs +112/−0
- src/Effectful/State/Dynamic.hs +18/−27
- src/Effectful/State/Static/Local.hs +21/−15
- src/Effectful/State/Static/Shared.hs +42/−42
- src/Effectful/Writer/Dynamic.hs +13/−23
- src/Effectful/Writer/Static/Local.hs +16/−9
- src/Effectful/Writer/Static/Shared.hs +50/−18
CHANGELOG.md view
@@ -1,3 +1,153 @@+# effectful-core-2.7.0.0 (2026-08-24)+* Add the `Input` effect (`Effectful.Input.Dynamic`, `Effectful.Input.Static`,+ `Effectful.Input.Static.Action` and `Effectful.Labeled.Input`) for access to+ values.+* Add the `Output` effect (`Effectful.Output.Dynamic`,+ `Effectful.Output.Static.Action`, `Effectful.Output.Static.Local.Array`,+ `Effectful.Output.Static.Local.List`, `Effectful.Output.Static.Shared.Array`,+ `Effectful.Output.Static.Shared.List` and `Effectful.Labeled.Output`) for+ accumulation of values.+* Add the `ReturnWith` effect (`Effectful.ReturnWith.Dynamic`,+ `Effectful.ReturnWith.Static` and `Effectful.Labeled.ReturnWith`) for early+ return from a computation.+* Make the `Provider` and `ProviderList` effects dynamically dispatched and+ export their operations.+* Add `Effectful.Labeled.Provider` and `Effectful.Labeled.Provider.List` with+ labeled versions of the `Provider` and `ProviderList` effects.+* Re-export `Labeled(..)` from all `Effectful.Labeled.*` modules.+* Drop support for GHC < 9.6.+* Add definitions of `rethrowM` to `MonadThrow` and `catchNoPropagate` to+ `MonadCatch` instances for `Eff` when appropriate (`exceptions` >= 0.10.11).+* If the cleanup action of `bracket`, `bracket_`, `bracketOnError`, `finally` or+ `onException` from `Effectful.Exception` throws, the original exception is no+ longer lost - it is preserved in a `WhileHandling` annotation of the new one+ (`base` >= 4.21).+* Rename `Effectful.Internal.MTL` module to `Effectful.Internal.Effect.Dynamic`.+* Deprecate `withLiftMap` as its misuse in a multithreaded environment results+ in undefined behavior that cannot be detected at runtime. Use+ `localLiftUnlift` with an appropriate `UnliftStrategy` instead.+* Deprecate `stateM` and `modifyM` from `Effectful.State.Static.Local`,+ `Effectful.State.Static.Shared`, `Effectful.State.Dynamic` and+ `Effectful.Labeled.State` as well as the `StateM` operation of the dynamic+ `State` effect. The shared variant pins the state to a lock-based+ implementation, yet deadlocks when operations of the same `State` effect are+ used within the callback, while the local variant silently discards state+ modifications made this way. If you need atomic effectful updates of shared+ state, use an explicit `MVar`.+* Deprecate `runStateMVar`, `evalStateMVar` and `execStateMVar` from+ `Effectful.State.Static.Shared` so that the internal representation of the+ shared `State` effect is not tied to an `MVar`. If you need access to the+ state from outside of the effect, manage an explicit `MVar` yourself.+* Tighten pre-requisites for `unconsEnv` and `unreplaceEnv`.+* Add `localLendBorrow` to `Effectful.Dispatch.Dynamic`.+* Add `rethrowErrorWith`, `rethrowError` and `rethrowError_` (along with the+ corresponding `RethrowErrorWith` operation of the dynamic `Error` effect) for+ throwing errors with a given `CallStack`.+* Document why the `MonadThrow`, `MonadCatch` and `MonadMask` instances for+ `Eff` are available without any effect requirements.+* Require `primitive` >= 0.9.0.0.+* Require `strict-mutable-base` >= 2.0.0.0.+* Remove `SharedSuffix` constraints from functions in+ `Effectful.Dispatch.Dynamic` and deprecate the class, as runtime sanity+ checks make it unnecessary.+* **Breaking changes**:+ - Remove the `handlerEs` type parameter of `LocalEnv` as it was only needed+ to support `SharedSuffix` constraints.+ - Remove the `KnownEffects` class as it's no longer used; handlers of the+ `ProviderList` effect now require the `KnownSubset` constraint instead.+* **Bugfixes**:+ - `restoreStorageData` no longer shrinks the capacity of the storage, which+ could result in out of bounds reads when out of date references to the+ environment were accessed after the rollback, e.g. by the unlifting function+ that escaped its scope.+ - Unlifting functions created by `localLiftUnlift` with `SeqForkUnlift` or+ `ConcUnlift` `Persistent` strategy now correctly share the effect storage+ and the thread limit now applies jointly to both functions.+ - `OnEmptyRollback` strategy of the `NonDet` effect now correctly rolls back+ local state of statically dispatched effects stored in mutable variables.+ - Thread registration in unlifting functions created with the `ConcUnlift`+ `Persistent` strategy interrupted by an asynchronous exception no longer+ leaks a finalizer that corrupts the thread limit accounting when the thread+ dies.+ - Running the computation given to the setup function of `reinterpret` or+ `impose` in a cloned environment (e.g. by unlifting it with the+ `SeqForkUnlift` strategy and running it outside of the scope of the setup+ function) now results in an immediate, accurate error instead of+ corruption of the environment of the call site.++# effectful-core-2.6.1.0 (2025-08-30)+* Add `MonadError`, `MonadReader`, `MonadState` and `MonadWriter` instances for+ `Eff` for compatibility with existing code.++# effectful-core-2.6.0.0 (2025-06-13)+* Adjust `generalBracket` with `base >= 4.21` to make use of the new exception+ annotation mechanism.+* Add `withException` to `Effectful.Exception`.+* Deprecate `Effectful.Reader.Dynamic.withReader` as it doesn't work correctly+ for all potential interpreters.+* **Breaking changes**:+ - Change the order of type parameters in `raise` for better usability.+ - `Effectful.Error.Static.ErrorWrapper` is no longer caught by `catchSync`.+ - Remove deprecated function `Effectful.withConcEffToIO`.++# effectful-core-2.5.1.0 (2024-11-27)+* Add `passthrough` to `Effectful.Dispatch.Dynamic` for passing operations to+ the upstream handler within `interpose` and `impose` without having to fully+ pattern match on them.+* **Bugfixes**:+ - Fix a potential space leak related to `HasCallStack` quirks (see+ https://gitlab.haskell.org/ghc/ghc/-/issues/25520 for more information).++# effectful-core-2.5.0.0 (2024-10-23)+* Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make+ `emptyEff` and `sumEff` generate better call stacks.+* Explicitly define `setByteArray#` and `setOffAddr#` in the `Prim` instance of+ `Ref` for `primitive` < 0.9.0.0.+* **Bugfixes**:+ - `OnEmptyRollback` strategy of the `NonDet` effect is no longer broken.+* **Breaking changes**:+ - Remove `restoreEnv` function from `Effectful.Dispatch.Static.Primitive`+ since it was broken.+ - Base `Effectful.Exception` on `Control.Exception` instead of the+ `safe-exceptions` library for consistency with provided `MonadThrow` and+ `MonadCatch` instances.++# effectful-core-2.4.0.0 (2024-10-08)+* Add utility functions for handling effects that take the effect handler as the+ last parameter to `Effectful.Dispatch.Dynamic`.+* Add utility functions for handling first order effects to+ `Effectful.Dispatch.Dynamic`.+* Improve `Effectful.Labeled`, add `Effectful.Labeled.Error`,+ `Effectful.Labeled.Reader`, `Effectful.Labeled.State` and+ `Effectful.Labeled.Writer`.+* Add `throwErrorWith` and `throwError_` to `Effectful.Error.Static` and+ `Effectful.Error.Dynamic`.+* Add `HasCallStack` constraints where appropriate for better debugging+ experience.+* Add a `SeqForkUnlift` strategy to support running unlifting functions outside+ of the scope of effects they capture.+* Add `Effectful.Exception` with appropriate re-exports from the+ `safe-exceptions` library.+* **Bugfixes**:+ - Ensure that a `LocalEnv` is only used in a thread it belongs to.+ - Properly roll back changes made to the environment when `OnEmptyRollback`+ policy for the `NonDet` effect is selected.+ - Fix a bug in `stateM` and `modifyM` of thread local `State` effect that+ might've caused dropped state updates+ ([#237](https://github.com/haskell-effectful/effectful/issues/237)).+* **Breaking changes**:+ - `localSeqLend`, `localLend`, `localSeqBorrow` and `localBorrow` now take a+ list of effects instead of a single one.+ - `Effectful.Error.Static.throwError` now requires the error type to have a+ `Show` constraint. If this is not the case for some of your error types, use+ `throwError_` for them.+ - `ThrowError` operation from the dynamic version of the `Error` effect was+ replaced with `ThrowErrorWith`.+ - `stateEnv` and `modifyEnv` now take pure modification functions. If you rely+ on their old forms, switch to a combination of `getEnv` and `putEnv`.+ - `runStateMVar`, `evalStateMVar` and `execStateMVar` now take a strict+ `MVar'` from the `strict-mutable-base` package.+ # effectful-core-2.3.1.0 (2024-06-07) * Drop support for GHC 8.8. * Remove inaccurate information from the `Show` instance of `ErrorWrapper`.
README.md view
@@ -1,13 +1,12 @@ # effectful -[](https://github.com/haskell-effectful/effectful/actions?query=branch%3Amaster)+[](https://github.com/haskell-effectful/effectful/actions/workflows/haskell-ci.yml) [](https://hackage.haskell.org/package/effectful)-[](https://packdeps.haskellers.com/feed?needle=andrzej@rybczak.net) [](https://www.stackage.org/lts/package/effectful) [](https://www.stackage.org/nightly/package/effectful) -<img src="https://user-images.githubusercontent.com/387658/127747903-f728437f-2ee4-47b8-9f0c-5102fd44c8e4.png" width="128">+<img src="https://raw.githubusercontent.com/haskell-effectful/effectful/master/logo.svg" width="150"> An easy to use, fast extensible effects library with seamless integration with the existing Haskell ecosystem.
− cbits/utils.c
@@ -1,5 +0,0 @@-// Correct implementation of ThreadId# equality for GHC < 9.-long effectful_eq_thread(void *tso1, void *tso2)-{- return tso1 == tso2;-}
effectful-core.cabal view
@@ -1,7 +1,7 @@-cabal-version: 3.0+cabal-version: 3.8 build-type: Simple name: effectful-core-version: 2.3.1.0+version: 2.7.0.0 license: BSD-3-Clause license-file: LICENSE category: Control@@ -12,7 +12,7 @@ description: An easy to use, performant extensible effects library with seamless integration with the existing Haskell ecosystem.- .+ This library provides core definitions with a minimal dependency footprint. See the @<https://hackage.haskell.org/package/effectful effectful>@ package for the "batteries-included" variant.@@ -21,7 +21,7 @@ CHANGELOG.md README.md -tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.5, 9.8.2, 9.10.1 }+tested-with: GHC == { 9.6.7, 9.8.4, 9.10.3, 9.12.4, 9.14.1 } bug-reports: https://github.com/haskell-effectful/effectful/issues source-repository head@@ -29,51 +29,43 @@ location: https://github.com/haskell-effectful/effectful.git common language- ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors+ ghc-options: -Wall+ -Wcompat+ -Werror=missing-deriving-strategies -Werror=prepositive-qualified-module - default-language: Haskell2010+ default-language: GHC2021 - default-extensions: BangPatterns- ConstraintKinds- DataKinds- DeriveFunctor- DeriveGeneric- FlexibleContexts- FlexibleInstances- GADTs- GeneralizedNewtypeDeriving- ImportQualifiedPost+ default-extensions: DataKinds+ DeepSubsumption+ DerivingStrategies+ DuplicateRecordFields LambdaCase- MultiParamTypeClasses+ NoFieldSelectors NoStarIsType- RankNTypes+ OverloadedRecordDot RoleAnnotations- ScopedTypeVariables- StandaloneDeriving- TupleSections- TypeApplications TypeFamilies- TypeOperators+ UndecidableInstances library import: language ghc-options: -O2 - build-depends: base >= 4.14 && < 5+ build-depends: base >= 4.18 && < 5 , containers >= 0.6+ , deepseq >= 1.2 , exceptions >= 0.10.4+ , mtl >= 2.2.1 , monad-control >= 1.0.3- , primitive >= 0.7.3.0+ , primitive >= 0.9.0.0+ , strict-mutable-base >= 2.0.0.0 && < 3 , transformers-base >= 0.4.6 , unliftio-core >= 0.2.0.1 hs-source-dirs: src - if impl(ghc < 9)- c-sources: cbits/utils.c- exposed-modules: Effectful Effectful.Dispatch.Dynamic Effectful.Dispatch.Static@@ -81,19 +73,42 @@ Effectful.Dispatch.Static.Unsafe Effectful.Error.Dynamic Effectful.Error.Static+ Effectful.Exception Effectful.Fail+ Effectful.Input.Dynamic+ Effectful.Input.Static+ Effectful.Input.Static.Action Effectful.Internal.Effect+ Effectful.Internal.Effect.Dynamic Effectful.Internal.Env Effectful.Internal.Monad Effectful.Internal.Unlift Effectful.Internal.Utils+ Effectful.Internal.Utils.Word64Map Effectful.Labeled+ Effectful.Labeled.Error+ Effectful.Labeled.Input+ Effectful.Labeled.Output+ Effectful.Labeled.Provider+ Effectful.Labeled.Provider.List+ Effectful.Labeled.Reader+ Effectful.Labeled.ReturnWith+ Effectful.Labeled.State+ Effectful.Labeled.Writer Effectful.NonDet+ Effectful.Output.Dynamic+ Effectful.Output.Static.Action+ Effectful.Output.Static.Local.Array+ Effectful.Output.Static.Local.List+ Effectful.Output.Static.Shared.Array+ Effectful.Output.Static.Shared.List Effectful.Prim Effectful.Provider Effectful.Provider.List Effectful.Reader.Dynamic Effectful.Reader.Static+ Effectful.ReturnWith.Dynamic+ Effectful.ReturnWith.Static Effectful.State.Dynamic Effectful.State.Static.Local Effectful.State.Static.Shared
src/Effectful.hs view
@@ -46,7 +46,6 @@ , withUnliftStrategy , withSeqEffToIO , withEffToIO- , withConcEffToIO -- ** Lifting , raise@@ -64,6 +63,7 @@ import Control.Monad.IO.Unlift import Effectful.Internal.Effect+import Effectful.Internal.Effect.Dynamic () import Effectful.Internal.Env import Effectful.Internal.Monad @@ -148,7 +148,7 @@ -- -- These libraries can trivially be used with the 'Eff' monad since it provides -- typical instances that these libraries require the underlying monad to have,--- such as t'Control.Monad.Catch.MonadMask' or 'MonadUnliftIO'.+-- such as t'Effectful.Exception.MonadMask' or 'MonadUnliftIO'. -- -- In case the 'Eff' monad doesn't provide a specific instance out of the box, -- it can be supplied via an effect. As an example see how the instance of@@ -199,8 +199,8 @@ -- -- As an example, consider the following monad: ----- >>> import qualified Control.Monad.State as T--- >>> import qualified Control.Monad.Except as T+-- >>> import Control.Monad.State qualified as T+-- >>> import Control.Monad.Except qualified as T -- -- >>> data HandlerState -- >>> data HandlerError
src/Effectful/Dispatch/Dynamic.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE UndecidableInstances #-} -- | Dynamically dispatched effects. module Effectful.Dispatch.Dynamic ( -- * Introduction@@ -19,13 +19,18 @@ -- * Sending operations to the handler send+ , passthrough -- * Handling effects , EffectHandler , interpret+ , interpretWith , reinterpret+ , reinterpretWith , interpose+ , interposeWith , impose+ , imposeWith -- ** Handling local 'Eff' computations , LocalEnv@@ -51,16 +56,28 @@ , localLend , localSeqBorrow , localBorrow+ , localLendBorrow , SharedSuffix+ , KnownSubset + -- ** Utils for first order effects+ , EffectHandler_+ , interpret_+ , interpretWith_+ , reinterpret_+ , reinterpretWith_+ , interpose_+ , interposeWith_+ , impose_+ , imposeWith_+ -- * Re-exports , HasCallStack ) where import Control.Monad-import Control.Monad.IO.Unlift import Data.Primitive.PrimArray-import GHC.Stack (HasCallStack)+import GHC.Stack import GHC.TypeLits import Effectful.Internal.Effect@@ -138,11 +155,9 @@ -- The following defines an 'EffectHandler' that reads and writes files from the -- drive: ----- >>> import Control.Exception (IOException)--- >>> import Control.Monad.Catch (catch)--- >>> import qualified System.IO as IO--- -- >>> import Effectful.Error.Static+-- >>> import Effectful.Exception+-- >>> import System.IO qualified as IO -- -- >>> newtype FsError = FsError String deriving Show --@@ -155,7 +170,7 @@ -- ReadFile path -> adapt $ IO.readFile path -- WriteFile path contents -> adapt $ IO.writeFile path contents -- where--- adapt m = liftIO m `catch` \(e::IOException) -> throwError . FsError $ show e+-- adapt m = liftIO m `catchIO` \e -> throwError . FsError $ show e -- :} -- -- Here, we use 'interpret' and simply execute corresponding 'IO' actions for@@ -164,8 +179,7 @@ -- On the other hand, maybe there is a situation in which instead of interacting -- with the outside world, a pure, in-memory storage is preferred: ----- >>> import qualified Data.Map.Strict as M---+-- >>> import Data.Map.Strict qualified as M -- >>> import Effectful.State.Static.Local -- -- >>> :{@@ -212,6 +226,9 @@ -- -- If an effect makes use of the @m@ parameter, it is a /higher order effect/. --+-- /Note:/ for handling first order effects you can use 'interpret_' or+-- 'reinterpret_' whose 'EffectHandler_' doesn't take the 'LocalEnv' parameter.+-- -- Interpretation of higher order effects is slightly more involving. To see -- why, let's consider the @Profiling@ effect for logging how much time a -- specific action took to run:@@ -248,8 +265,8 @@ -- -- The problem is that @action@ has a type @Eff localEs a@, while the monad of -- the effect handler is @Eff es@. @localEs@ represents the /local environment/--- in which the @Profile@ operation was called, which is opaque as the effect--- handler cannot possibly know how it looks like.+-- in which the @Profile@ operation was called, which is more or less opaque to+-- the effect handler. -- -- The solution is to use the 'LocalEnv' that an 'EffectHandler' is given to run -- the action using one of the functions from the 'localUnlift' family:@@ -332,8 +349,6 @@ -- __orphan__, __canonical__ instance of @MonadRNG@ for 'Eff' that delegates to -- the @RNG@ effect: ----- >>> :set -XUndecidableInstances--- -- >>> :{ -- instance RNG :> es => MonadRNG (Eff es) where -- randomInt = send RandomInt@@ -343,7 +358,7 @@ -- -- >>> :{ -- runDummyRNG :: Eff (RNG : es) a -> Eff es a--- runDummyRNG = interpret $ \_ -> \case+-- runDummyRNG = interpret_ $ \case -- RandomInt -> pure 55 -- :} --@@ -381,9 +396,8 @@ -- ... for functional dependency: ‘m -> i’... -- ... ----- However, there exists a [dirty--- trick](https://www.youtube.com/watch?v=ZXtdd8e7CQQ) for bypassing the--- coverage condition, i.e. including the instance head in the context:+-- However, there exists a trick for bypassing the coverage condition,+-- i.e. including the instance head in its context: -- -- >>> :{ -- instance (MonadInput i (Eff es), Reader i :> es) => MonadInput i (Eff es) where@@ -400,41 +414,117 @@ -- >>> runPureEff . runReader @Int 3 $ double -- 6 +-- | A variant of 'send' for passing operations to the upstream handler within+-- 'interpose' and 'impose' without having to fully pattern match on them.+passthrough+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es, e :> localEs)+ => LocalEnv localEs+ -> e (Eff localEs) a+ -- ^ The operation.+ -> Eff es a+passthrough localEs op = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ Handler handlerEs (HandlerImpl handler) <- getEnv es+ when (les.storage /= handlerEs.storage) $ do+ error "les and handlerEs point to different Storages"+ -- Prevent the addition of unnecessary 'handler' stack frame to the call+ -- stack. Note that functions 'interpret', 'reinterpret', 'interpose' and+ -- 'impose' need to thaw the call stack so that useful stack frames from+ -- inside the effect handler continue to be added.+ unEff (withFrozenCallStack handler localEs op) handlerEs+{-# NOINLINE passthrough #-}+ ---------------------------------------- -- Handling effects -- | Interpret an effect. ----- /Note:/ 'interpret' can be turned into a 'reinterpret' with the use of--- 'inject'.+-- /Note:/ if you want to use intermediate effects in multiple handlers, then+-- hide them from downstream, have a look at 'inject'. interpret- :: DispatchOf e ~ Dynamic+ :: (HasCallStack, DispatchOf e ~ Dynamic) => EffectHandler e es -- ^ The effect handler. -> Eff (e : es) a -> Eff es a-interpret handler m = unsafeEff $ \es -> do- (`unEff` es) $ runHandler (mkHandler es) m- where- mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)+interpret handler action = interpretImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) +-- | 'interpret' with the effect handler as the last argument.+--+-- @since 2.4.0.0+interpretWith+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => Eff (e : es) a+ -> EffectHandler e es+ -- ^ The effect handler.+ -> Eff es a+interpretWith action handler = interpretImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler)+ -- | Interpret an effect using other, private effects. -- -- @'interpret' ≡ 'reinterpret' 'id'@+--+-- /Note:/ If you want to interpret multiple effects using other, private+-- effects, you can do so with a combination of 'interpret' and 'inject'.+--+-- This is in particular useful for splitting a large effect into smaller+-- ones. For example, let's say you want to split a+-- t'Effectful.State.Static.Local.State' into a read only and read write+-- component:+--+-- >>> :{+-- data Get s :: Effect where+-- Get :: Get s m s+-- type instance DispatchOf (Get s) = Dynamic+-- :}+--+-- >>> :{+-- data Put s :: Effect where+-- Put :: s -> Put s m ()+-- type instance DispatchOf (Put s) = Dynamic+-- :}+--+-- >>> import Effectful.State.Static.Local qualified as S+--+-- >>> :{+-- runGetPut :: forall s es a. s -> Eff (Get s : Put s : es) a -> Eff es (a, s)+-- runGetPut s0+-- = S.runState s0+-- . interpret_ @(Put s) (\(Put s) -> S.put s)+-- . interpret_ @(Get s) (\Get -> S.get)+-- . inject+-- :}+--+-- Here, a t'Effectful.State.Static.Local.State' effect is introduced, then+-- @Put@ and @Get@ effects that use it underneath and finally 'inject' hides the+-- original state from downstream code. reinterpret- :: DispatchOf e ~ Dynamic+ :: (HasCallStack, DispatchOf e ~ Dynamic) => (Eff handlerEs a -> Eff es b)- -- ^ Introduction of effects encapsulated within the handler.+ -- ^ Setup of effects encapsulated in the handler. -> EffectHandler e handlerEs -- ^ The effect handler. -> Eff (e : es) a -> Eff es b-reinterpret runHandlerEs handler m = unsafeEff $ \es -> do- (`unEff` es) . runHandlerEs . unsafeEff $ \handlerEs -> do- (`unEff` es) $ runHandler (mkHandler handlerEs) m- where- mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)+reinterpret runSetup handler action = reinterpretImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) +-- | 'reinterpret' with the effect handler as the last argument.+--+-- @since 2.4.0.0+reinterpretWith+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => (Eff handlerEs a -> Eff es b)+ -- ^ Setup of effects encapsulated in the handler.+ -> Eff (e : es) a+ -> EffectHandler e handlerEs+ -- ^ The effect handler.+ -> Eff es b+reinterpretWith runSetup action handler = reinterpretImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler)+ -- | Replace the handler of an existing effect with a new one. -- -- /Note:/ this function allows for augmenting handlers with a new functionality@@ -442,144 +532,287 @@ -- -- >>> :{ -- data E :: Effect where--- Op :: E m ()+-- Op1 :: E m ()+-- Op2 :: E m ()+-- Op3 :: E m () -- type instance DispatchOf E = Dynamic -- :} -- -- >>> :{ -- runE :: IOE :> es => Eff (E : es) a -> Eff es a--- runE = interpret $ \_ Op -> liftIO (putStrLn "op")+-- runE = interpret_ $ \case+-- Op1 -> liftIO (putStrLn "op1")+-- Op2 -> liftIO (putStrLn "op2")+-- Op3 -> error "Op3 not implemented" -- :} ----- >>> runEff . runE $ send Op--- op+-- >>> let action = send Op1 >> send Op2 --+-- >>> runEff . runE $ action+-- op1+-- op2+--+-- You can modify only specific operations and send the rest to the upstream+-- handler with 'passthrough':+-- -- >>> :{--- augmentE :: (E :> es, IOE :> es) => Eff es a -> Eff es a--- augmentE = interpose $ \_ Op -> liftIO (putStrLn "augmented op") >> send Op+-- augmentOp2 :: (E :> es, IOE :> es) => Eff es a -> Eff es a+-- augmentOp2 = interpose $ \env -> \case+-- Op2 -> liftIO (putStrLn "augmented op2") >> send Op2+-- op -> passthrough env op -- :} ----- >>> runEff . runE . augmentE $ send Op--- augmented op--- op+-- >>> runEff . runE . augmentOp2 $ action+-- op1+-- augmented op2+-- op2 --+-- /Note:/ when an exception is raised while handling an operation, good+-- debugging experience is ensured by strategically placed 'HasCallStack'+-- constraints:+--+-- >>> runEff . runE . augmentOp2 $ send Op3+-- *** Exception: Op3 not implemented+-- ...+-- error, called at <interactive>:...+-- handler, called at src/Effectful/Dispatch/Dynamic.hs:...+-- passthrough, called at <interactive>:...+-- handler, called at src/Effectful/Dispatch/Dynamic.hs:...+-- send, called at <interactive>:...+-- ... interpose- :: forall e es a. (DispatchOf e ~ Dynamic, e :> es)+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => EffectHandler e es -- ^ The effect handler. -> Eff es a -> Eff es a-interpose handler m = unsafeEff $ \es -> do- inlineBracket- (do- origHandler <- getEnv @e es- replaceEnv origHandler relinkHandler es- )- (\newEs -> do- -- Restore the original handler.- putEnv es =<< getEnv @e newEs- unreplaceEnv @e newEs- )- (\newEs -> do- -- Replace the original handler with a new one. Note that 'newEs'- -- will still see the original handler.- putEnv es $ mkHandler newEs- unEff m es- )- where- mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)+interpose handler action = interposeImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) +-- | 'interpose' with the effect handler as the last argument.+--+-- @since 2.4.0.0+interposeWith+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => Eff es a+ -> EffectHandler e es+ -- ^ The effect handler.+ -> Eff es a+interposeWith action handler = interposeImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler)+ -- | Replace the handler of an existing effect with a new one that uses other, -- private effects. -- -- @'interpose' ≡ 'impose' 'id'@ impose- :: forall e es handlerEs a b. (DispatchOf e ~ Dynamic, e :> es)+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es) => (Eff handlerEs a -> Eff es b)- -- ^ Introduction of effects encapsulated within the handler.+ -- ^ Setup of effects encapsulated in the handler. -> EffectHandler e handlerEs -- ^ The effect handler. -> Eff es a -> Eff es b-impose runHandlerEs handler m = unsafeEff $ \es -> do- inlineBracket- (do- origHandler <- getEnv @e es- replaceEnv origHandler relinkHandler es- )- (\newEs -> do- -- Restore the original handler.- putEnv es =<< getEnv @e newEs- unreplaceEnv @e newEs- )- (\newEs -> do- (`unEff` newEs) . runHandlerEs . unsafeEff $ \handlerEs -> do- -- Replace the original handler with a new one. Note that- -- 'newEs' (and thus 'handlerEs') wil still see the original- -- handler.- putEnv es $ mkHandler handlerEs- unEff m es- )- where- mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)+impose runSetup handler action = imposeImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler) +-- | 'impose' with the effect handler as the last argument.+--+-- @since 2.4.0.0+imposeWith+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => (Eff handlerEs a -> Eff es b)+ -- ^ Setup of effects encapsulated in the handler.+ -> Eff es a+ -> EffectHandler e handlerEs+ -- ^ The effect handler.+ -> Eff es b+imposeWith runSetup action handler = imposeImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in handler)+ ----------------------------------------+-- First order effects++-- | Type signature of a first order effect handler.+--+-- @since 2.4.0.0+type EffectHandler_ (e :: Effect) (es :: [Effect])+ = forall a localEs. HasCallStack+ => e (Eff localEs) a+ -- ^ The operation.+ -> Eff es a++-- | 'interpret' for first order effects.+--+-- @since 2.4.0.0+interpret_+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => EffectHandler_ e es+ -- ^ The effect handler.+ -> Eff (e : es) a+ -> Eff es a+interpret_ handler action = interpretImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | 'interpretWith' for first order effects.+--+-- @since 2.4.0.0+interpretWith_+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => Eff (e : es) a+ -> EffectHandler_ e es+ -- ^ The effect handler.+ -> Eff es a+interpretWith_ action handler = interpretImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | 'reinterpret' for first order effects.+--+-- @since 2.4.0.0+reinterpret_+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => (Eff handlerEs a -> Eff es b)+ -- ^ Setup of effects encapsulated in the handler.+ -> EffectHandler_ e handlerEs+ -- ^ The effect handler.+ -> Eff (e : es) a+ -> Eff es b+reinterpret_ runSetup handler action = reinterpretImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | 'reinterpretWith' for first order effects.+--+-- @since 2.4.0.0+reinterpretWith_+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => (Eff handlerEs a -> Eff es b)+ -- ^ Setup of effects encapsulated in the handler.+ -> Eff (e : es) a+ -> EffectHandler_ e handlerEs+ -- ^ The effect handler.+ -> Eff es b+reinterpretWith_ runSetup action handler = reinterpretImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | 'interpose' for first order effects.+--+-- @since 2.4.0.0+interpose_+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => EffectHandler_ e es+ -- ^ The effect handler.+ -> Eff es a+ -> Eff es a+interpose_ handler action = interposeImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | 'interposeWith' for first order effects.+--+-- @since 2.4.0.0+interposeWith_+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => Eff es a+ -> EffectHandler_ e es+ -- ^ The effect handler.+ -> Eff es a+interposeWith_ action handler = interposeImpl action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | 'impose' for first order effects.+--+-- @since 2.4.0.0+impose_+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => (Eff handlerEs a -> Eff es b)+ -- ^ Setup of effects encapsulated in the handler.+ -> EffectHandler_ e handlerEs+ -- ^ The effect handler.+ -> Eff es a+ -> Eff es b+impose_ runSetup handler action = imposeImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++-- | 'imposeWith' for first order effects.+--+-- @since 2.4.0.0+imposeWith_+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => (Eff handlerEs a -> Eff es b)+ -- ^ Setup of effects encapsulated in the handler.+ -> Eff es a+ -> EffectHandler_ e handlerEs+ -- ^ The effect handler.+ -> Eff es b+imposeWith_ runSetup action handler = imposeImpl runSetup action $+ HandlerImpl (let ?callStack = thawCallStack ?callStack in const handler)++---------------------------------------- -- Unlifts -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the -- general version see 'localUnlift'. localSeqUnlift- :: (HasCallStack, SharedSuffix es handlerEs)- => LocalEnv localEs handlerEs+ :: HasCallStack+ => LocalEnv localEs -- ^ Local environment. -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a) -- ^ Continuation with the unlifting function in scope. -> Eff es a-localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do+localSeqUnlift localEs k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs seqUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift+{-# INLINE localSeqUnlift #-} -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the -- general version see 'localUnliftIO'. localSeqUnliftIO- :: (HasCallStack, SharedSuffix es handlerEs, IOE :> es)- => LocalEnv localEs handlerEs+ :: (HasCallStack, IOE :> es)+ => LocalEnv localEs -- ^ Local environment. -> ((forall r. Eff localEs r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a-localSeqUnliftIO (LocalEnv les) k = liftIO $ seqUnliftIO les k+localSeqUnliftIO localEs k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ seqUnliftIO les k+{-# INLINE localSeqUnliftIO #-} -- | Create a local unlifting function with the given strategy. localUnlift- :: (HasCallStack, SharedSuffix es handlerEs)- => LocalEnv localEs handlerEs+ :: HasCallStack+ => LocalEnv localEs -- ^ Local environment. -> UnliftStrategy -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a) -- ^ Continuation with the unlifting function in scope. -> Eff es a-localUnlift (LocalEnv les) strategy k = case strategy of- SeqUnlift -> unsafeEff $ \es -> do- seqUnliftIO les $ \unlift -> do+localUnlift localEs strategy k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ case strategy of+ SeqUnlift -> seqUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift- ConcUnlift p l -> unsafeEff $ \es -> do- concUnliftIO les p l $ \unlift -> do+ SeqForkUnlift -> seqForkUnliftIO les $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift+ ConcUnlift p l -> concUnliftIO les p l $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localUnlift #-} -- | Create a local unlifting function with the given strategy. localUnliftIO- :: (HasCallStack, SharedSuffix es handlerEs, IOE :> es)- => LocalEnv localEs handlerEs+ :: (HasCallStack, IOE :> es)+ => LocalEnv localEs -- ^ Local environment. -> UnliftStrategy -> ((forall r. Eff localEs r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a-localUnliftIO (LocalEnv les) strategy k = case strategy of- SeqUnlift -> liftIO $ seqUnliftIO les k- ConcUnlift p l -> liftIO $ concUnliftIO les p l k+localUnliftIO localEs strategy k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ case strategy of+ SeqUnlift -> seqUnliftIO les k+ SeqForkUnlift -> seqForkUnliftIO les k+ ConcUnlift p l -> concUnliftIO les p l k {-# INLINE localUnliftIO #-} ----------------------------------------@@ -590,38 +823,38 @@ -- -- @since 2.2.1.0 localSeqLift- :: (HasCallStack, SharedSuffix es handlerEs)- => LocalEnv localEs handlerEs+ :: HasCallStack+ => LocalEnv localEs -- ^ Local environment. -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a) -- ^ Continuation with the lifting function in scope. -> Eff es a-localSeqLift !_ k = unsafeEff $ \es -> do- -- The LocalEnv parameter is not used, but we need it to constraint the- -- localEs type variable. It's also strict so that callers don't cheat.+localSeqLift localEs k = unsafeEff $ \es -> do+ requireMatchingStorages es localEs seqUnliftIO es $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift+{-# INLINE localSeqLift #-} -- | Create a local lifting function with the given strategy. -- -- @since 2.2.1.0 localLift- :: (HasCallStack, SharedSuffix es handlerEs)- => LocalEnv localEs handlerEs+ :: HasCallStack+ => LocalEnv localEs -- ^ Local environment. -> UnliftStrategy -> ((forall r. Eff es r -> Eff localEs r) -> Eff es a) -- ^ Continuation with the lifting function in scope. -> Eff es a-localLift !_ strategy k = case strategy of- -- The LocalEnv parameter is not used, but we need it to constraint the- -- localEs type variable. It's also strict so that callers don't cheat.- SeqUnlift -> unsafeEff $ \es -> do- seqUnliftIO es $ \unlift -> do+localLift localEs strategy k = unsafeEff $ \es -> do+ requireMatchingStorages es localEs+ case strategy of+ SeqUnlift -> seqUnliftIO es $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift- ConcUnlift p l -> unsafeEff $ \es -> do- concUnliftIO es p l $ \unlift -> do+ SeqForkUnlift -> seqForkUnliftIO es $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift+ ConcUnlift p l -> concUnliftIO es p l $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localLift #-} -- | Utility for lifting 'Eff' computations of type@@ -634,19 +867,24 @@ -- -- /Note:/ the computation must not run its argument in a different thread, -- attempting to do so will result in a runtime error.+--+-- /Warning:/ if the lifting function is used in a thread distinct from its+-- creator, the lifted computation must not interact with the environment. This+-- cannot be detected at runtime, hence the deprecation. withLiftMap- :: (HasCallStack, SharedSuffix es handlerEs)- => LocalEnv localEs handlerEs+ :: HasCallStack+ => LocalEnv localEs -- ^ Local environment. -> ((forall a b. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r) -- ^ Continuation with the lifting function in scope. -> Eff es r-withLiftMap !_ k = unsafeEff $ \es -> do- -- The LocalEnv parameter is not used, but we need it to constraint the- -- localEs type variable. It's also strict so that callers don't cheat.- (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \localEs -> do- seqUnliftIO localEs $ \unlift -> do+withLiftMap localEs k = unsafeEff $ \es -> do+ requireMatchingStorages es localEs+ (`unEff` es) $ k $ \mapEff m -> unsafeEff $ \les -> do+ seqUnliftIO les $ \unlift -> do (`unEff` es) . mapEff . unsafeEff_ $ unlift m+{-# DEPRECATED withLiftMap+ "Misusing withLiftMap in multiple threads results in undefined behavior. Use localLiftUnlift with an appropriate UnliftStrategy instead." #-} -- | Utility for lifting 'IO' computations of type --@@ -675,16 +913,17 @@ -- forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask -- :} withLiftMapIO- :: (HasCallStack, SharedSuffix es handlerEs, IOE :> es)- => LocalEnv localEs handlerEs+ :: (HasCallStack, IOE :> es)+ => LocalEnv localEs -- ^ Local environment. -> ((forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r) -- ^ Continuation with the lifting function in scope. -> Eff es r-withLiftMapIO !_ k = k $ \mapIO m -> unsafeEff $ \es -> do- -- The LocalEnv parameter is not used, but we need it to constraint the- -- localEs type variable. It's also strict so that callers don't cheat.- seqUnliftIO es $ \unlift -> mapIO $ unlift m+withLiftMapIO localEs k = unsafeEff $ \es -> do+ requireMatchingStorages es localEs+ (`unEff` es) $ k $ \mapIO m -> unsafeEff $ \les -> do+ seqUnliftIO les $ \unlift -> mapIO $ unlift m+{-# INLINE withLiftMapIO #-} ---------------------------------------- -- Bidirectional lifts@@ -694,25 +933,27 @@ -- Useful for lifting complicated 'Eff' computations where the monadic action -- shows in both positive (as a result) and negative (as an argument) position. ----- /Note:/ depending on the computation you're lifting 'localUnlift' along with--- 'withLiftMap' might be enough and is more efficient.+-- /Note:/ when 'SeqForkUnlift' or 'ConcUnlift' 'Persistent' strategy is used,+-- the unlifting functions will share the effect storage (unlike with two+-- separate calls to 'localLift' and 'localUnlift'). localLiftUnlift- :: (HasCallStack, SharedSuffix es handlerEs)- => LocalEnv localEs handlerEs+ :: HasCallStack+ => LocalEnv localEs -- ^ Local environment. -> UnliftStrategy -> ((forall r. Eff es r -> Eff localEs r) -> (forall r. Eff localEs r -> Eff es r) -> Eff es a) -- ^ Continuation with the lifting and unlifting function in scope. -> Eff es a-localLiftUnlift (LocalEnv les) strategy k = case strategy of- SeqUnlift -> unsafeEff $ \es -> do- seqUnliftIO es $ \unliftEs -> do+localLiftUnlift localEs strategy k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ case strategy of+ SeqUnlift -> seqUnliftIO es $ \unliftEs -> do seqUnliftIO les $ \unliftLocalEs -> do (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)- ConcUnlift p l -> unsafeEff $ \es -> do- concUnliftIO es p l $ \unliftEs -> do- concUnliftIO les p l $ \unliftLocalEs -> do- (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)+ SeqForkUnlift -> seqForkUnliftsIO es les $ \unliftEs unliftLocalEs -> do+ (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)+ ConcUnlift p l -> concUnliftsIO es les p l $ \unliftEs unliftLocalEs -> do+ (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs) {-# INLINE localLiftUnlift #-} -- | Create a local unlifting function with the given strategy along with an@@ -724,22 +965,25 @@ -- /Note:/ depending on the computation you're lifting 'localUnliftIO' along -- with 'withLiftMapIO' might be enough and is more efficient. localLiftUnliftIO- :: (HasCallStack, SharedSuffix es handlerEs, IOE :> es)- => LocalEnv localEs handlerEs+ :: (HasCallStack, IOE :> es)+ => LocalEnv localEs -- ^ Local environment. -> UnliftStrategy -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a) -- ^ Continuation with the lifting and unlifting function in scope. -> Eff es a-localLiftUnliftIO (LocalEnv les) strategy k = case strategy of- SeqUnlift -> liftIO $ seqUnliftIO les $ k unsafeEff_- ConcUnlift p l -> liftIO $ concUnliftIO les p l $ k unsafeEff_+localLiftUnliftIO localEs strategy k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ case strategy of+ SeqUnlift -> seqUnliftIO les $ k unsafeEff_+ SeqForkUnlift -> seqForkUnliftIO les $ k unsafeEff_+ ConcUnlift p l -> concUnliftIO les p l $ k unsafeEff_ {-# INLINE localLiftUnliftIO #-} ---------------------------------------- -- Misc --- | Lend an effect to the local environment.+-- | Lend effects to the local environment. -- -- Consider the following effect: --@@ -777,97 +1021,133 @@ -- runD :: IOE :> es => Eff (D : es) a -> Eff es a -- runD = interpret $ \env -> \case -- D -> localSeqUnlift env $ \unlift -> do--- localSeqLend @IOE env $ \useIOE -> do+-- localSeqLend @'[IOE] env $ \useIOE -> do -- unlift . useIOE . runE $ pure () -- :} ----- @since 2.3.1.0+-- @since 2.4.0.0 localSeqLend- :: (e :> es, SharedSuffix es handlerEs)- => LocalEnv localEs handlerEs- -> ((forall r. Eff (e : localEs) r -> Eff localEs r) -> Eff es a)+ :: forall lentEs es localEs a+ . (HasCallStack, KnownSubset lentEs es)+ => LocalEnv localEs+ -> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a) -- ^ Continuation with the lent handler in scope. -> Eff es a-localSeqLend (LocalEnv les) k = unsafeEff $ \es -> do- eles <- copyRef es les+localSeqLend localEs k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ eles <- copyRefs @lentEs es les seqUnliftIO eles $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift+{-# INLINE localSeqLend #-} --- | Lend an effect to the local environment with a given unlifting strategy.+-- | Lend effects to the local environment with a given unlifting strategy. -- -- Generalizes 'localSeqLend'. ----- @since 2.3.1.0+-- @since 2.4.0.0 localLend- :: (e :> es, SharedSuffix es handlerEs)- => LocalEnv localEs handlerEs+ :: forall lentEs es localEs a+ . (HasCallStack, KnownSubset lentEs es)+ => LocalEnv localEs -> UnliftStrategy- -> ((forall r. Eff (e : localEs) r -> Eff localEs r) -> Eff es a)+ -> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a) -- ^ Continuation with the lent handler in scope. -> Eff es a-localLend (LocalEnv les) strategy k = case strategy of- SeqUnlift -> unsafeEff $ \es -> do- eles <- copyRef es les- seqUnliftIO eles $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift- ConcUnlift p l -> unsafeEff $ \es -> do- eles <- copyRef es les- concUnliftIO eles p l $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift+localLend localEs strategy k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ eles <- copyRefs @lentEs es les+ case strategy of+ SeqUnlift -> seqUnliftIO eles $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift+ SeqForkUnlift -> seqForkUnliftIO eles $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift+ ConcUnlift p l -> concUnliftIO eles p l $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localLend #-} --- | Borrow an effect from the local environment.+-- | Borrow effects from the local environment. ----- @since 2.3.1.0+-- @since 2.4.0.0 localSeqBorrow- :: (e :> localEs, SharedSuffix es handlerEs)- => LocalEnv localEs handlerEs- -> ((forall r. Eff (e : es) r -> Eff es r) -> Eff es a)+ :: forall borrowedEs es localEs a+ . (HasCallStack, KnownSubset borrowedEs localEs)+ => LocalEnv localEs+ -> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a) -- ^ Continuation with the borrowed handler in scope. -> Eff es a-localSeqBorrow (LocalEnv les) k = unsafeEff $ \es -> do- ees <- copyRef les es+localSeqBorrow localEs k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ ees <- copyRefs @borrowedEs les es seqUnliftIO ees $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift+{-# INLINE localSeqBorrow #-} --- | Borrow an effect from the local environment with a given unlifting+-- | Borrow effects from the local environment with a given unlifting -- strategy. -- -- Generalizes 'localSeqBorrow'. ----- @since 2.3.1.0+-- @since 2.4.0.0 localBorrow- :: (e :> localEs, SharedSuffix es handlerEs)- => LocalEnv localEs handlerEs+ :: forall borrowedEs es localEs a+ . (HasCallStack, KnownSubset borrowedEs localEs)+ => LocalEnv localEs -> UnliftStrategy- -> ((forall r. Eff (e : es) r -> Eff es r) -> Eff es a)+ -> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a) -- ^ Continuation with the borrowed handler in scope. -> Eff es a-localBorrow (LocalEnv les) strategy k = case strategy of- SeqUnlift -> unsafeEff $ \es -> do- ees <- copyRef les es- seqUnliftIO ees $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift- ConcUnlift p l -> unsafeEff $ \es -> do- ees <- copyRef les es- concUnliftIO ees p l $ \unlift -> (`unEff` es) $ k $ unsafeEff_ . unlift+localBorrow localEs strategy k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ ees <- copyRefs @borrowedEs les es+ case strategy of+ SeqUnlift -> seqUnliftIO ees $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift+ SeqForkUnlift -> seqForkUnliftIO ees $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift+ ConcUnlift p l -> concUnliftIO ees p l $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE localBorrow #-} -copyRef- :: forall e srcEs destEs. e :> srcEs- => Env srcEs- -> Env destEs- -> IO (Env (e : destEs))-copyRef (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do- when (hstorage /= storage) $ do- error "storages do not match"- let size = sizeofPrimArray refs0 - offset- i = 2 * reifyIndex @e @srcEs- mrefs <- newPrimArray (size + 2)- copyPrimArray mrefs 0 hrefs (hoffset + i) 2- copyPrimArray mrefs 2 refs0 offset size- refs <- unsafeFreezePrimArray mrefs- pure $ Env 0 refs storage+-- | Simultaneously lend effects to the local environment and borrow effects+-- from it with a given unlifting strategy.+--+-- /Note:/ when 'SeqForkUnlift' or 'ConcUnlift' 'Persistent' strategy is used,+-- the lending and borrowing functions will share the effect storage (unlike+-- with two separate calls to 'localLend' and 'localBorrow').+--+-- @since 2.7.0.0+localLendBorrow+ :: forall lentEs borrowedEs es localEs a+ . ( HasCallStack+ , KnownSubset lentEs es+ , KnownSubset borrowedEs localEs+ )+ => LocalEnv localEs+ -> UnliftStrategy+ -> ( (forall r. Eff (lentEs ++ localEs) r -> Eff localEs r)+ -> (forall r. Eff (borrowedEs ++ es) r -> Eff es r)+ -> Eff es a+ )+ -- ^ Continuation with the lending and borrowing functions in scope.+ -> Eff es a+localLendBorrow localEs strategy k = unsafeEff $ \es -> do+ les <- unwrapLocalEnv es localEs+ eles <- copyRefs @lentEs es les+ ees <- copyRefs @borrowedEs les es+ case strategy of+ SeqUnlift -> seqUnliftIO eles $ \unliftLent -> do+ seqUnliftIO ees $ \unliftBorrowed -> do+ (`unEff` es) $ k (unsafeEff_ . unliftLent) (unsafeEff_ . unliftBorrowed)+ SeqForkUnlift -> seqForkUnliftsIO eles ees $ \unliftLent unliftBorrowed -> do+ (`unEff` es) $ k (unsafeEff_ . unliftLent) (unsafeEff_ . unliftBorrowed)+ ConcUnlift p l -> concUnliftsIO eles ees p l $ \unliftLent unliftBorrowed -> do+ (`unEff` es) $ k (unsafeEff_ . unliftLent) (unsafeEff_ . unliftBorrowed)+{-# INLINE localLendBorrow #-} -- | Require that both effect stacks share an opaque suffix. ----- Functions from the 'localUnlift' family utilize this constraint to guarantee--- sensible usage of unlifting functions.+-- Functions from the 'localUnlift' family previously required this constraint+-- to reject a subset of improper uses of unlifting functions at compile+-- time. It's no longer necessary, since all of them are detected at runtime+-- now. -- -- As an example, consider the following higher order effect: --@@ -904,24 +1184,15 @@ -- E m -> pure . runPureEff $ do -- localSeqUnlift env $ \unlift -> unlift m -- :}--- ...--- ...Could not deduce ...SharedSuffix '[] es...--- ... ----- Running local actions in a monomorphic effect stack is also not fine as--- this makes a special case of the above possible:------ >>> :{--- runE4 :: Eff [E, IOE] a -> Eff '[IOE] a--- runE4 = interpret $ \env -> \case--- E m -> pure . runPureEff $ do--- localSeqUnlift env $ \unlift -> unlift m--- :}--- ...--- ...Running local actions in monomorphic effect stacks is not supported...+-- >>> runEff . runE3 $ send (E (pure 'x'))+-- *** Exception: Env and LocalEnv point to different Storages. -- ... -- -- @since 1.2.0.0+{-# DEPRECATED SharedSuffix+ "Runtime sanity checks in relevant functions make this constraint unnecessary."+ #-} class SharedSuffix (es1 :: [Effect]) (es2 :: [Effect]) instance {-# INCOHERENT #-} SharedSuffix es es@@ -935,6 +1206,117 @@ Text "As a solution simply change the stack to have a polymorphic suffix." ) => SharedSuffix '[] '[] +----------------------------------------+-- Helpers++interpretImpl+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => Eff (e : es) a+ -> HandlerImpl e es+ -> Eff es a+interpretImpl action handlerImpl = unsafeEff $ \es -> do+ (`unEff` es) $ runHandler (Handler es handlerImpl) action+{-# INLINE interpretImpl #-}++reinterpretImpl+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => (Eff handlerEs a -> Eff es b)+ -> Eff (e : es) a+ -> HandlerImpl e handlerEs+ -> Eff es b+reinterpretImpl runSetup action handlerImpl = unsafeEff $ \es -> do+ (`unEff` es) . runSetup . unsafeEff $ \handlerEs -> do+ requireInScopeSetup es handlerEs+ (`unEff` es) $ runHandler (Handler handlerEs handlerImpl) action+{-# INLINE reinterpretImpl #-}++interposeImpl+ :: forall e es a. (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => Eff es a+ -> HandlerImpl e es+ -> Eff es a+interposeImpl action handlerImpl = unsafeEff $ \es -> do+ inlineBracket+ (do+ origHandler <- getEnv @e es+ replaceEnv origHandler relinkHandler es+ )+ (\newEs -> do+ -- Restore the original handler.+ putEnv es =<< getEnv @e newEs+ unreplaceEnv @e newEs+ )+ (\newEs -> do+ -- Replace the original handler with a new one. Note that 'newEs'+ -- will still see the original handler.+ putEnv es $ Handler newEs handlerImpl+ unEff action es+ )+{-# INLINE interposeImpl #-}++imposeImpl+ :: forall e es handlerEs a b. (HasCallStack, DispatchOf e ~ Dynamic, e :> es)+ => (Eff handlerEs a -> Eff es b)+ -> Eff es a+ -> HandlerImpl e handlerEs+ -> Eff es b+imposeImpl runSetup action handlerImpl = unsafeEff $ \es -> do+ inlineBracket+ (do+ origHandler <- getEnv @e es+ replaceEnv origHandler relinkHandler es+ )+ (\newEs -> do+ -- Restore the original handler.+ putEnv es =<< getEnv @e newEs+ unreplaceEnv @e newEs+ )+ (\newEs -> do+ (`unEff` newEs) . runSetup . unsafeEff $ \handlerEs -> do+ requireInScopeSetup es handlerEs+ -- Replace the original handler with a new one. Note that+ -- 'newEs' (and thus 'handlerEs') wil still see the original+ -- handler.+ putEnv es $ Handler handlerEs handlerImpl+ unEff action es+ )+{-# INLINE imposeImpl #-}++copyRefs+ :: forall es srcEs destEs+ . (HasCallStack, KnownSubset es srcEs)+ => Env srcEs+ -> Env destEs+ -> IO (Env (es ++ destEs))+copyRefs (Env soffset srefs _) (Env doffset drefs storage) = do+ let es = reifyIndices @es @srcEs+ esSize = length es+ destSize = sizeofPrimArray drefs - doffset+ mrefs <- newPrimArray (esSize + destSize)+ copyPrimArray mrefs esSize drefs doffset destSize+ let writeRefs i = \case+ [] -> pure ()+ (x : xs) -> do+ writePrimArray mrefs i $ indexPrimArray srefs (soffset + x)+ writeRefs (i + 1) xs+ writeRefs 0 es+ refs <- unsafeFreezePrimArray mrefs+ pure $ Env 0 refs storage+{-# NOINLINE copyRefs #-}++-- | Make sure the setup function of 'reinterpret' or 'impose' runs its+-- argument within its scope. If it runs in a cloned environment, the handler+-- would still operate on the environment of the call site, corrupting it.+requireInScopeSetup :: HasCallStack => Env es -> Env handlerEs -> IO ()+requireInScopeSetup es handlerEs+ | es.storage /= handlerEs.storage = error+ $ "The setup function ran the computation in a cloned environment.\n"+ ++ "If you unlifted it with the SeqForkUnlift or ConcUnlift strategy and "+ ++ "attempted to run it outside of the scope of the setup function or in "+ ++ "a different thread, it's not allowed."+ | otherwise = pure ()+ -- $setup -- >>> import Control.Concurrent (ThreadId, forkIOWithUnmask)+-- >>> import Control.Monad.IO.Class -- >>> import Effectful.Reader.Static
src/Effectful/Dispatch/Static.hs view
@@ -214,4 +214,5 @@ concUnliftIO es persistence limit k -- $setup+-- >>> :seti -XFieldSelectors -- >>> import Effectful
src/Effectful/Dispatch/Static/Primitive.hs view
@@ -31,7 +31,6 @@ -- ** Utils , emptyEnv , cloneEnv- , restoreEnv , sizeEnv , tailEnv ) where
src/Effectful/Dispatch/Static/Unsafe.hs view
@@ -5,50 +5,3 @@ ) where import Effectful.Internal.Monad---- | Utility for lifting 'IO' computations of type------ @'IO' a -> 'IO' b@------ to------ @'Eff' es a -> 'Eff' es b@------ This function is __really unsafe__ because:------ - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'--- computations.------ - The 'IO' computation must run its argument in a way that's perceived as--- sequential to the outside observer, e.g. in the same thread or in a worker--- thread that finishes before the argument is run again.------ __Warning:__ if you disregard the second point, you will experience weird--- bugs, data races or internal consistency check failures.------ When in doubt, use 'Effectful.Dispatch.Static.unsafeLiftMapIO', especially--- since this version saves only a simple safety check per call of--- @reallyUnsafeLiftMapIO f@.-reallyUnsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b-reallyUnsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es)---- | Create an unlifting function.------ This function is __really unsafe__ because:------ - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'--- computations.------ - Unlifted 'Eff' computations must be run in a way that's perceived as--- sequential to the outside observer, e.g. in the same thread as the caller--- of 'reallyUnsafeUnliftIO' or in a worker thread that finishes before--- another unlifted computation is run.------ __Warning:__ if you disregard the second point, you will experience weird--- bugs, data races or internal consistency check failures.------ When in doubt, use 'Effectful.Dispatch.Static.unsafeSeqUnliftIO', especially--- since this version saves only a simple safety check per call of the unlifting--- function.-reallyUnsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a-reallyUnsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es)
src/Effectful/Error/Dynamic.hs view
@@ -1,8 +1,12 @@ -- | The dynamically dispatched variant of the 'Error' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use the statically dispatched variant,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.Except.MonadError' instance for compatibility with existing+-- code, it's recommended to use the statically dispatched variant, -- i.e. "Effectful.Error.Static".+--+-- All caveats described in "Effectful.Error.Static" (in particular the+-- interaction with threads) apply. module Effectful.Error.Dynamic ( -- * Effect Error(..)@@ -14,7 +18,12 @@ , runErrorNoCallStackWith -- ** Operations+ , throwErrorWith , throwError+ , throwError_+ , rethrowErrorWith+ , rethrowError+ , rethrowError_ , catchError , handleError , tryError@@ -31,20 +40,16 @@ import Effectful import Effectful.Dispatch.Dynamic import Effectful.Error.Static qualified as E---- | Provide the ability to handle errors of type @e@.-data Error e :: Effect where- ThrowError :: e -> Error e m a- CatchError :: m a -> (E.CallStack -> e -> m a) -> Error e m a--type instance DispatchOf (Error e) = Dynamic+import Effectful.Internal.Effect.Dynamic (Error(..)) -- | Handle errors of type @e@ (via "Effectful.Error.Static"). runError- :: Eff (Error e : es) a+ :: HasCallStack+ => Eff (Error e : es) a -> Eff es (Either (E.CallStack, e) a) runError = reinterpret E.runError $ \env -> \case- ThrowError e -> E.throwError e+ ThrowErrorWith display e -> E.throwErrorWith display e+ RethrowErrorWith display cs e -> E.rethrowErrorWith display cs e CatchError m h -> localSeqUnlift env $ \unlift -> do E.catchError (unlift m) (\cs -> unlift . h cs) @@ -53,7 +58,8 @@ -- -- @since 2.3.0.0 runErrorWith- :: (E.CallStack -> e -> Eff es a)+ :: HasCallStack+ => (E.CallStack -> e -> Eff es a) -- ^ The error handler. -> Eff (Error e : es) a -> Eff es a@@ -66,14 +72,16 @@ -- -- @since 2.3.0.0 runErrorNoCallStack- :: Eff (Error e : es) a+ :: HasCallStack+ => Eff (Error e : es) a -> Eff es (Either e a) runErrorNoCallStack = fmap (either (Left . snd) Right) . runError -- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific -- error handler. In case of an error discard the 'CallStack'. runErrorNoCallStackWith- :: (e -> Eff es a)+ :: HasCallStack+ => (e -> Eff es a) -- ^ The error handler. -> Eff (Error e : es) a -> Eff es a@@ -81,14 +89,82 @@ Left e -> handler e Right a -> pure a --- | Throw an error of type @e@.+-- | Throw an error of type @e@ and specify a display function in case a+-- third-party code catches the internal exception and 'show's it.+--+-- @since 2.4.0.0+throwErrorWith+ :: (HasCallStack, Error e :> es)+ => (e -> String)+ -- ^ The display function.+ -> e+ -- ^ The error.+ -> Eff es a+throwErrorWith display = withFrozenCallStack send . ThrowErrorWith display++-- | Throw an error of type @e@ with 'show' as a display function. throwError+ :: (HasCallStack, Error e :> es, Show e)+ => e+ -- ^ The error.+ -> Eff es a+throwError = withFrozenCallStack throwErrorWith show++-- | Throw an error of type @e@ with no display function.+--+-- @since 2.4.0.0+throwError_ :: (HasCallStack, Error e :> es) => e -- ^ The error. -> Eff es a-throwError e = withFrozenCallStack $ send (ThrowError e)+throwError_ = withFrozenCallStack throwErrorWith (const "<opaque>") +-- | Throw an error of type @e@ with the given 'E.CallStack' and specify a+-- display function in case a third-party code catches the internal exception+-- and 'show's it.+--+-- Useful e.g. when you want to catch an error and rethrow it converted to a+-- different type without losing the original 'E.CallStack'.+--+-- @since 2.7.0.0+rethrowErrorWith+ :: Error e :> es+ => (e -> String)+ -- ^ The display function.+ -> E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowErrorWith display cs = send . RethrowErrorWith display cs++-- | Throw an error of type @e@ with the given 'E.CallStack' and 'show' as a+-- display function.+--+-- @since 2.7.0.0+rethrowError+ :: (Error e :> es, Show e)+ => E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError = rethrowErrorWith show++-- | Throw an error of type @e@ with the given 'E.CallStack' and no display+-- function.+--+-- @since 2.7.0.0+rethrowError_+ :: Error e :> es+ => E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError_ = rethrowErrorWith (const "<opaque>")+ -- | Handle an error of type @e@. catchError :: (HasCallStack, Error e :> es)@@ -102,7 +178,7 @@ -- | The same as @'flip' 'catchError'@, which is useful in situations where the -- code for the handler is shorter. handleError- :: Error e :> es+ :: (HasCallStack, Error e :> es) => (E.CallStack -> e -> Eff es a) -- ^ A handler for errors in the inner computation. -> Eff es a
src/Effectful/Error/Static.hs view
@@ -1,13 +1,13 @@ -- | Support for handling errors of a particular type, i.e. checked exceptions. -- -- The 'Error' effect is __not__ a general mechanism for handling regular--- exceptions, that's what functions from the @exceptions@ library are for (see--- "Control.Monad.Catch" for more information).+-- exceptions, that's what functions from the "Effectful.Exception" module are+-- for. -- -- In particular, regular exceptions of type @e@ are distinct from errors of -- type @e@ and will __not__ be caught by functions from this module: ----- >>> import qualified Control.Monad.Catch as E+-- >>> import Effectful.Exception qualified as E -- -- >>> boom = error "BOOM!" --@@ -16,14 +16,14 @@ -- ... -- -- If you want to catch regular exceptions, you should use--- 'Control.Monad.Catch.catch' (or a similar function):+-- 'Effectful.Exception.catch' (or a similar function): -- -- >>> runEff $ boom `E.catch` \(_::ErrorCall) -> pure "caught" -- "caught" -- -- On the other hand, functions for safe finalization and management of--- resources such as 'Control.Monad.Catch.finally' and--- 'Control.Monad.Catch.bracket' work as expected:+-- resources such as 'Effectful.Exception.finally' and+-- 'Effectful.Exception.bracket' work as expected: -- -- >>> msg = liftIO . putStrLn --@@ -43,8 +43,8 @@ -- effect with regard to other stateful effects does not matter. Consider the -- following: ----- >>> import qualified Control.Monad.State.Strict as T--- >>> import qualified Control.Monad.Except as T+-- >>> import Control.Monad.State.Strict qualified as T+-- >>> import Control.Monad.Except qualified as T -- -- >>> m1 = (T.modify (++ " there!") >> T.throwError "oops") `T.catchError` \_ -> pure () --@@ -74,7 +74,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.+--+-- === Interaction with threads+--+-- The 'Error' effect uses runtime exceptions underneath, so the usual rules+-- apply. In particular, in multi-threaded code an error thrown in a child+-- thread will not automatically propagate to the parent. If you need that, use+-- functions such as @withAsync@ from the+-- [Effectful.Concurrent.Async](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent-Async.html)+-- module of the @effectful@ package (which propagate exceptions from child+-- threads to their parents) or arrange the propagation yourself.+--+-- For more information see the documentation of the+-- [Concurrent](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent.html#t:Concurrent)+-- effect. module Effectful.Error.Static ( -- * Effect Error@@ -86,7 +100,12 @@ , runErrorNoCallStackWith -- ** Operations+ , throwErrorWith , throwError+ , throwError_+ , rethrowErrorWith+ , rethrowError+ , rethrowError_ , catchError , handleError , tryError@@ -98,16 +117,16 @@ , prettyCallStack ) where -import Control.Exception+import Data.Kind import GHC.Stack import Effectful import Effectful.Dispatch.Static-import Effectful.Dispatch.Static.Primitive+import Effectful.Exception import Effectful.Internal.Utils -- | Provide the ability to handle errors of type @e@.-data Error e :: Effect+data Error (e :: Type) :: Effect type instance DispatchOf (Error e) = Static NoSideEffects newtype instance StaticRep (Error e) = Error ErrorId@@ -115,29 +134,24 @@ -- | Handle errors of type @e@. runError :: forall e es a- . Eff (Error e : es) a+ . HasCallStack+ => Eff (Error e : es) a -> Eff es (Either (CallStack, e) a)-runError m = unsafeEff $ \es0 -> mask $ \unmask -> do- eid <- newErrorId- es <- consEnv (Error @e eid) dummyRelinker es0- r <- tryErrorIO unmask eid es `onException` unconsEnv es- unconsEnv es- pure r- where- tryErrorIO unmask eid es = try (unmask $ unEff m es) >>= \case- Right a -> pure $ Right a- Left ex -> tryHandler ex eid (\cs e -> Left (cs, e))- $ throwIO ex+runError action = do+ eid <- unsafeEff_ newErrorId+ evalStaticRep (Error @e eid) $ do+ tryJust (matchError eid) action -- | Handle errors of type @e@ with a specific error handler. -- -- @since 2.3.0.0 runErrorWith- :: (CallStack -> e -> Eff es a)+ :: HasCallStack+ => (CallStack -> e -> Eff es a) -- ^ The error handler. -> Eff (Error e : es) a -> Eff es a-runErrorWith handler m = runError m >>= \case+runErrorWith handler action = runError action >>= \case Left (cs, e) -> handler cs e Right a -> pure a @@ -146,48 +160,119 @@ -- @since 2.3.0.0 runErrorNoCallStack :: forall e es a- . Eff (Error e : es) a+ . HasCallStack+ => Eff (Error e : es) a -> Eff es (Either e a) runErrorNoCallStack = fmap (either (Left . snd) Right) . runError -- | Handle errors of type @e@ with a specific error handler. In case of an -- error discard the 'CallStack'. runErrorNoCallStackWith- :: (e -> Eff es a)+ :: HasCallStack+ => (e -> Eff es a) -- ^ The error handler. -> Eff (Error e : es) a -> Eff es a-runErrorNoCallStackWith handler m = runErrorNoCallStack m >>= \case+runErrorNoCallStackWith handler action = runErrorNoCallStack action >>= \case Left e -> handler e Right a -> pure a --- | Throw an error of type @e@.+-- | Throw an error of type @e@ and specify a display function in case a+-- third-party code catches the internal exception and 'show's it.+--+-- @since 2.4.0.0+throwErrorWith+ :: forall e es a. (HasCallStack, Error e :> es)+ => (e -> String)+ -- ^ The display function.+ -> e+ -- ^ The error.+ -> Eff es a+throwErrorWith display e = do+ Error eid <- getStaticRep @(Error e)+ withFrozenCallStack throwIO $ ErrorWrapper eid callStack (display e) (toAny e)++-- | Throw an error of type @e@ with 'show' as a display function. throwError+ :: forall e es a. (HasCallStack, Error e :> es, Show e)+ => e+ -- ^ The error.+ -> Eff es a+throwError = withFrozenCallStack throwErrorWith show++-- | Throw an error of type @e@ with no display function.+--+-- @since 2.4.0.0+throwError_ :: forall e es a. (HasCallStack, Error e :> es) => e -- ^ The error. -> Eff es a-throwError e = unsafeEff $ \es -> do- Error eid <- getEnv @(Error e) es- throwIO $ ErrorWrapper eid callStack (toAny e)+throwError_ = withFrozenCallStack throwErrorWith (const "<opaque>") +-- | Throw an error of type @e@ with the given 'CallStack' and specify a+-- display function in case a third-party code catches the internal exception+-- and 'show's it.+--+-- Useful e.g. when you want to catch an error and rethrow it converted to a+-- different type without losing the original 'CallStack'.+--+-- @since 2.7.0.0+rethrowErrorWith+ :: forall e es a. Error e :> es+ => (e -> String)+ -- ^ The display function.+ -> CallStack+ -- ^ The 'CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowErrorWith display cs e = do+ Error eid <- getStaticRep @(Error e)+ throwIO $ ErrorWrapper eid cs (display e) (toAny e)++-- | Throw an error of type @e@ with the given 'CallStack' and 'show' as a+-- display function.+--+-- @since 2.7.0.0+rethrowError+ :: forall e es a. (Error e :> es, Show e)+ => CallStack+ -- ^ The 'CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError = rethrowErrorWith show++-- | Throw an error of type @e@ with the given 'CallStack' and no display+-- function.+--+-- @since 2.7.0.0+rethrowError_+ :: forall e es a. Error e :> es+ => CallStack+ -- ^ The 'CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError_ = rethrowErrorWith (const "<opaque>")+ -- | Handle an error of type @e@. catchError- :: forall e es a. Error e :> es+ :: forall e es a. (HasCallStack, Error e :> es) => Eff es a -- ^ The inner computation. -> (CallStack -> e -> Eff es a) -- ^ A handler for errors in the inner computation. -> Eff es a-catchError m handler = unsafeEff $ \es -> do- Error eid <- getEnv @(Error e) es- catchErrorIO eid (unEff m es) $ \cs e -> do- unEff (handler cs e) es+catchError action handler = do+ Error eid <- getStaticRep @(Error e)+ catchJust (matchError eid) action $ \(cs, e) -> handler cs e -- | The same as @'flip' 'catchError'@, which is useful in situations where the -- code for the handler is shorter. handleError- :: forall e es a. Error e :> es+ :: forall e es a. (HasCallStack, Error e :> es) => (CallStack -> e -> Eff es a) -- ^ A handler for errors in the inner computation. -> Eff es a@@ -198,45 +283,46 @@ -- | Similar to 'catchError', but returns an 'Either' result which is a 'Right' -- if no error was thrown and a 'Left' otherwise. tryError- :: forall e es a. Error e :> es+ :: forall e es a. (HasCallStack, Error e :> es) => Eff es a -- ^ The inner computation. -> Eff es (Either (CallStack, e) a)-tryError m = (Right <$> m) `catchError` \es e -> pure $ Left (es, e)+tryError action = do+ Error eid <- getStaticRep @(Error e)+ tryJust (matchError eid) action ---------------------------------------- -- Helpers newtype ErrorId = ErrorId Unique- deriving Eq+ deriving newtype Eq -- | A unique is picked so that distinct 'Error' handlers for the same type -- don't catch each other's exceptions. newErrorId :: IO ErrorId newErrorId = ErrorId <$> newUnique -tryHandler- :: SomeException- -> ErrorId- -> (CallStack -> e -> r)- -> IO r- -> IO r-tryHandler ex eid0 handler next = case fromException ex of- Just (ErrorWrapper eid cs e)- | eid0 == eid -> pure $ handler cs (fromAny e)- | otherwise -> next- Nothing -> next+data ErrorWrapper = ErrorWrapper !ErrorId CallStack String Any -data ErrorWrapper = ErrorWrapper !ErrorId CallStack Any instance Show ErrorWrapper where- showsPrec p (ErrorWrapper _ cs _)- = ("Effectful.Error.Static.ErrorWrapper\n\n" ++)- . showsPrec p (prettyCallStack cs)-instance Exception ErrorWrapper+ showsPrec p (ErrorWrapper _ cs errRep _)+ = showParen (p > 10)+ $ ("Effectful.Error.Static.ErrorWrapper: " ++)+ . (errRep ++)+ . ("\n" ++)+ . (prettyCallStack cs ++)+ . ("\n\nIf you see this message, most likely an error escaped the " ++)+ . ("scope of its handler, e.g. by being thrown from a thread that " ++)+ . ("outlived it, or was caught by an overly zealous exception handler. " ++)+ . ("For more information see the documentation of the " ++)+ . ("Effectful.Error.Static module." ++) -catchErrorIO :: ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a-catchErrorIO eid m handler = do- m `catch` \err@(ErrorWrapper etag cs e) -> do- if eid == etag- then handler cs (fromAny e)- else throwIO err+instance Exception ErrorWrapper where+ -- See discussion in https://github.com/haskell-effectful/effectful/pull/232.+ toException = asyncExceptionToException+ fromException = asyncExceptionFromException++matchError :: ErrorId -> ErrorWrapper -> Maybe (CallStack, e)+matchError eid (ErrorWrapper etag cs _ e)+ | eid == etag = Just (cs, fromAny e)+ | otherwise = Nothing
+ src/Effectful/Exception.hs view
@@ -0,0 +1,659 @@+{-# LANGUAGE CPP #-}+-- | Support for runtime exceptions.+--+-- This module supplies thin wrappers over functions from "Control.Exception" as+-- well as several utility functions for convenience.+--+-- /Note:/ the 'Eff' monad provides instances for 'C.MonadThrow', 'C.MonadCatch'+-- and 'C.MonadMask', so any existing code that uses them remains compatible.+module Effectful.Exception+ ( -- * Throwing+ throwIO+#if MIN_VERSION_base(4,21,0)+ , rethrowIO+#endif++ -- * Catching (with recovery)+ -- $catchAll+ , catch+#if MIN_VERSION_base(4,21,0)+ , catchNoPropagate+#endif+ , catchDeep+ , catchJust+ , catchIf+ , catchIO+ , catchSync+ , catchSyncDeep++ , handle+ , handleDeep+ , handleJust+ , handleIf+ , handleIO+ , handleSync+ , handleSyncDeep++ , try+#if MIN_VERSION_base(4,21,0)+ , tryWithContext+#endif+ , tryDeep+ , tryJust+ , tryIf+ , tryIO+ , trySync+ , trySyncDeep++ , C.Handler(..)+ , catches+ , catchesDeep++ -- | #cleanup#++ -- * Cleanup (no recovery)+ -- $cleanup+ , bracket+ , bracket_+ , bracketOnError+ , generalBracket+ , C.ExitCase(..)+ , finally+ , onException+ , withException++ -- * Utils++ -- ** Evaluation+ , evaluate+ , evaluateDeep++#if MIN_VERSION_base(4,20,0)+ -- ** Annotations+ , annotateIO+#endif++ -- | #checkExceptionType#++ -- ** Check exception type+ -- $syncVsAsync+ , isSyncException+ , isAsyncException++ -- * Low-level API+ , mask+ , mask_+ , uninterruptibleMask+ , uninterruptibleMask_+ , E.MaskingState(..)+ , getMaskingState+ , interruptible+ , allowInterrupt++ -- * Re-exports from "Control.Exception"++ -- ** The 'SomeException' type+ , E.SomeException(..)++ -- ** The 'Exception' class+ , E.Exception(..)+ , E.mapException++#if MIN_VERSION_base(4,20,0)+ -- ** Exception context and annotation+ , E.addExceptionContext+ , E.someExceptionContext+ , E.ExceptionWithContext(..)+#if MIN_VERSION_base(4,21,0)+ , E.WhileHandling(..)+#endif+ , E.ExceptionContext(..)+ , E.emptyExceptionContext+ , E.addExceptionAnnotation+ , E.getExceptionAnnotations+ , E.getAllExceptionAnnotations+ , E.displayExceptionContext+ , E.SomeExceptionAnnotation(..)+ , E.ExceptionAnnotation(..)+#endif++ -- ** Concrete exception types+ , E.IOException+ , E.ArithException(..)+ , E.ArrayException(..)+ , E.AssertionFailed(..)+ , E.NoMethodError(..)+ , E.PatternMatchFail(..)+ , E.RecConError(..)+ , E.RecSelError(..)+ , E.RecUpdError(..)+ , E.ErrorCall(..)+ , E.TypeError(..)++ -- ** Asynchronous exceptions+ , E.SomeAsyncException(..)+ , E.AsyncException(..)+ , E.asyncExceptionToException+ , E.asyncExceptionFromException+ , E.NonTermination(..)+ , E.NestedAtomically(..)+ , E.BlockedIndefinitelyOnMVar(..)+ , E.BlockedIndefinitelyOnSTM(..)+ , E.AllocationLimitExceeded(..)+ , E.CompactionFailed(..)+ , E.Deadlock(..)++ -- ** Assertions+ , E.assert+ ) where++#if MIN_VERSION_base(4,20,0)+import Control.Exception.Annotation qualified as E+import Control.Exception.Context qualified as E+#endif++import Control.DeepSeq+import Control.Exception qualified as E+import Control.Monad.Catch qualified as C+import GHC.Stack (withFrozenCallStack)++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Unsafe++----------------------------------------+-- Throwing++-- | Lifted 'E.throwIO'.+throwIO+ :: (HasCallStack, E.Exception e)+ => e+ -- ^ The error.+ -> Eff es a+throwIO = unsafeEff_ . withFrozenCallStack E.throwIO++#if MIN_VERSION_base(4,21,0)+-- | Lifted 'E.rethrowIO'.+rethrowIO+ :: E.Exception e+ => E.ExceptionWithContext e+ -> Eff es a+rethrowIO = unsafeEff_ . E.rethrowIO+#endif++----------------------------------------+-- Catching++-- $catchAll+--+-- /Note:/ __do not use 'catch', 'handle' or 'try' to catch 'E.SomeException'__+-- unless you're really sure you want to catch __all__ exceptions (including+-- asynchronous ones). Instead:+--+-- - If you want to catch all exceptions, run a cleanup action and rethrow, use+-- one of the functions from the [cleanup](#cleanup) section.+--+-- - If you want to catch all synchronous exceptions, use 'catchSync',+-- 'handleSync' or 'trySync'.++-- | Lifted 'E.catch'.+catch+ :: E.Exception e+ => Eff es a+ -> (e -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+catch action handler = reallyUnsafeUnliftIO $ \unlift -> do+ E.catch (unlift action) (unlift . handler)++-- | A variant of 'catch' that fully forces evaluation of the result value to+-- find all impure exceptions.+catchDeep+ :: (E.Exception e, NFData a)+ => Eff es a+ -> (e -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+catchDeep action = catch (evaluateDeep =<< action)++#if MIN_VERSION_base(4,21,0)+-- | Lifted 'E.catchNoPropagate'.+catchNoPropagate+ :: E.Exception e+ => Eff es a+ -> (E.ExceptionWithContext e -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+catchNoPropagate action handler = reallyUnsafeUnliftIO $ \unlift -> do+ E.catchNoPropagate (unlift action) (unlift . handler)+#endif++-- | Lifted 'E.catchJust'.+catchJust+ :: E.Exception e+ => (e -> Maybe b)+ -- ^ The predicate.+ -> Eff es a+ -> (b -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+catchJust f action handler = reallyUnsafeUnliftIO $ \unlift -> do+ E.catchJust f (unlift action) (unlift . handler)++-- | Catch an exception only if it satisfies a specific predicate.+catchIf+ :: E.Exception e+ => (e -> Bool)+ -- ^ The predicate.+ -> Eff es a+ -> (e -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+catchIf p = catchJust (\e -> if p e then Just e else Nothing)++-- | 'catch' specialized to catch 'IOException'.+catchIO+ :: Eff es a+ -> (E.IOException -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+catchIO = catch++-- | 'catch' specialized to catch all exceptions considered to be synchronous.+--+-- @'catchSync' ≡ 'catchIf' \@'E.SomeException' 'isSyncException'@+--+-- See the [check exception type](#checkExceptionType) section for more+-- information.+catchSync+ :: Eff es a+ -> (E.SomeException -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+catchSync = catchIf @E.SomeException isSyncException++-- | A variant of 'catchSync' that fully forces evaluation of the result value+-- to find all impure exceptions.+catchSyncDeep+ :: NFData a+ => Eff es a+ -> (E.SomeException -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+catchSyncDeep action = catchSync (evaluateDeep =<< action)++-- | Flipped version of 'catch'.+handle+ :: E.Exception e+ => (e -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+ -> Eff es a+handle = flip catch++-- | Flipped version of 'catchDeep'.+handleDeep+ :: (E.Exception e, NFData a)+ => (e -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+ -> Eff es a+handleDeep = flip catchDeep++-- | Flipped version of 'catchJust'.+handleJust+ :: (HasCallStack, E.Exception e)+ => (e -> Maybe b)+ -- ^ The predicate.+ -> (b -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+ -> Eff es a+handleJust f = flip (catchJust f)++-- | Flipped version of 'catchIf'.+handleIf+ :: E.Exception e+ => (e -> Bool)+ -- ^ The predicate.+ -> (e -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+ -> Eff es a+handleIf p = flip (catchIf p)++-- | Flipped version of 'catchIO'.+handleIO+ :: (E.IOException -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+ -> Eff es a+handleIO = flip catchIO++-- | Flipped version of 'catchSync'.+handleSync+ :: (E.SomeException -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+ -> Eff es a+handleSync = flip catchSync++-- | Flipped version of 'catchSyncDeep'.+handleSyncDeep+ :: NFData a+ => (E.SomeException -> Eff es a)+ -- ^ The exception handler.+ -> Eff es a+ -> Eff es a+handleSyncDeep = flip catchSyncDeep++-- | Lifted 'E.try'.+try+ :: E.Exception e+ => Eff es a+ -- ^ The action.+ -> Eff es (Either e a)+try action = reallyUnsafeUnliftIO $ \unlift -> do+ E.try (unlift action)++#if MIN_VERSION_base(4,21,0)+-- | Lifted 'E.tryWithContext'.+tryWithContext+ :: E.Exception e+ => Eff es a+ -> Eff es (Either (E.ExceptionWithContext e) a)+tryWithContext action = reallyUnsafeUnliftIO $ \unlift -> do+ E.tryWithContext (unlift action)+#endif++-- | A variant of 'try' that fully forces evaluation of the result value to find+-- all impure exceptions.+tryDeep+ :: (E.Exception e, NFData a)+ => Eff es a+ -- ^ The action.+ -> Eff es (Either e a)+tryDeep action = try (evaluateDeep =<< action)++-- | Lifted 'E.tryJust'.+tryJust+ :: E.Exception e+ => (e -> Maybe b)+ -- ^ The predicate.+ -> Eff es a+ -> Eff es (Either b a)+tryJust f action = reallyUnsafeUnliftIO $ \unlift -> do+ E.tryJust f (unlift action)++-- | Catch an exception only if it satisfies a specific predicate.+tryIf+ :: E.Exception e+ => (e -> Bool)+ -- ^ The predicate.+ -> Eff es a+ -> Eff es (Either e a)+tryIf p = tryJust (\e -> if p e then Just e else Nothing)++-- | 'try' specialized to catch 'IOException'.+tryIO+ :: Eff es a+ -- ^ The action.+ -> Eff es (Either E.IOException a)+tryIO = try++-- | 'try' specialized to catch all exceptions considered to be synchronous.+--+-- @'trySync' ≡ 'tryIf' \@'E.SomeException' 'isSyncException'@+--+-- See the [check exception type](#checkExceptionType) section for more+-- information.+trySync+ :: Eff es a+ -- ^ The action.+ -> Eff es (Either E.SomeException a)+trySync = tryIf @E.SomeException isSyncException++-- | A variant of 'trySync' that fully forces evaluation of the result value to+-- find all impure exceptions.+trySyncDeep+ :: NFData a+ => Eff es a+ -- ^ The action.+ -> Eff es (Either E.SomeException a)+trySyncDeep action = trySync (evaluateDeep =<< action)++-- | Lifted 'E.catches'.+catches+ :: Eff es a+ -> [C.Handler (Eff es) a]+ -- ^ The exception handlers.+ -> Eff es a+catches action handlers = reallyUnsafeUnliftIO $ \unlift -> do+ let unliftHandler (C.Handler handler) = E.Handler (unlift . handler)+ E.catches (unlift action) (map unliftHandler handlers)++-- | A variant of 'catches' that fully forces evaluation of the result value to+-- find all impure exceptions.+catchesDeep+ :: NFData a+ => Eff es a+ -> [C.Handler (Eff es) a]+ -- ^ The exception handlers.+ -> Eff es a+catchesDeep action = catches (evaluateDeep =<< action)++----------------------------------------+-- Cleanup++-- $cleanup+--+-- /Note:/ when compiled with @base@ >= 4.21, if the computation to run last+-- throws an exception while another one is being propagated, the original+-- exception is preserved in a @WhileHandling@ annotation of the new one. This+-- is what the corresponding functions from "Control.Exception" do since @base@+-- 4.23 instead of discarding the original exception, see [CLC proposal+-- #397](https://github.com/haskell/core-libraries-committee/issues/397).++-- | Lifted 'E.bracket'.+bracket+ :: Eff es a+ -- ^ Computation to run first.+ -> (a -> Eff es b)+ -- ^ Computation to run last.+ -> (a -> Eff es c)+ -- ^ Computation to run in-between.+ -> Eff es c+bracket before after action = mask $ \restore -> do+ a <- before+ r <- restore (action a) `onException` after a+ _ <- after a+ pure r++-- | Lifted 'E.bracket_'.+bracket_+ :: Eff es a+ -- ^ Computation to run first.+ -> Eff es b+ -- ^ Computation to run last.+ -> Eff es c+ -- ^ Computation to run in-between.+ -> Eff es c+bracket_ before after action = bracket before (const after) (const action)++-- | Lifted 'E.bracketOnError'.+bracketOnError+ :: Eff es a+ -- ^ Computation to run first.+ -> (a -> Eff es b)+ -- ^ Computation to run last when an exception or+ -- t'Effectful.Error.Static.Error' was thrown.+ -> (a -> Eff es c)+ -- ^ Computation to run in-between.+ -> Eff es c+bracketOnError before after action = mask $ \restore -> do+ a <- before+ restore (action a) `onException` after a++-- | Generalization of 'bracket'.+--+-- See 'C.generalBracket' for more information.+generalBracket+ :: Eff es a+ -- ^ Computation to run first.+ -> (a -> C.ExitCase c -> Eff es b)+ -- ^ Computation to run last.+ -> (a -> Eff es c)+ -- ^ Computation to run in-between.+ -> Eff es (c, b)+generalBracket = C.generalBracket++-- | Lifted 'E.finally'.+finally+ :: Eff es a+ -> Eff es b+ -- ^ Computation to run last.+ -> Eff es a+finally action handler = mask $ \restore -> do+ r <- restore action `onException` handler+ _ <- handler+ pure r++-- | Lifted 'E.onException'.+onException+ :: Eff es a+ -> Eff es b+ -- ^ Computation to run last when an exception or+ -- t'Effectful.Error.Static.Error' was thrown.+ -> Eff es a+onException action handler =+ withException @E.SomeException action (const handler)++-- | A variant of 'onException' that gives access to the exception.+--+-- @since 2.6.0.0+withException+ :: E.Exception e+ => Eff es a+ -> (e -> Eff es b)+ -- ^ Computation to run last when an exception or+ -- t'Effectful.Error.Static.Error' was thrown.+ -> Eff es a+withException action cleanup = do+#if MIN_VERSION_base(4,21,0)+ action `catchNoPropagate` \ec@(E.ExceptionWithContext _ e) -> do+ _ <- annotateIO (E.WhileHandling (E.toException ec)) (cleanup e)+ rethrowIO ec+#else+ action `catch` \e -> do+ _ <- cleanup e+ throwIO e+#endif++----------------------------------------+-- Utils++-- | Lifted 'E.evaluate'.+evaluate :: a -> Eff es a+evaluate = unsafeEff_ . E.evaluate++-- | Deeply evaluate a value using 'evaluate' and 'NFData'.+evaluateDeep :: NFData a => a -> Eff es a+evaluateDeep = unsafeEff_ . E.evaluate . force++#if MIN_VERSION_base(4,20,0)+-- | Lifted 'E.annotateIO'.+annotateIO :: E.ExceptionAnnotation e => e -> Eff es a -> Eff es a+annotateIO e action = reallyUnsafeUnliftIO $ \unlift -> do+ E.annotateIO e (unlift action)+#endif++----------------------------------------+-- Check exception type++-- $syncVsAsync+--+-- /Note:/ there's no way to determine whether an exception was thrown+-- synchronously or asynchronously, so these functions rely on a+-- heuristic. Namely, an exception type is determined by its 'E.Exception'+-- instance.+--+-- Exception types with the default 'E.Exception' instance are considered+-- synchronous:+--+-- >>> data SyncEx = SyncEx deriving (Show)+-- >>> instance Exception SyncEx+--+-- >>> isSyncException SyncEx+-- True+--+-- >>> isAsyncException SyncEx+-- False+--+-- Whereas for asynchronous exceptions you need to define their 'E.Exception'+-- instance as follows:+--+-- >>> data AsyncEx = AsyncEx deriving (Show)+-- >>> :{+-- instance Exception AsyncEx where+-- toException = asyncExceptionToException+-- fromException = asyncExceptionFromException+-- :}+--+-- >>> isSyncException AsyncEx+-- False+--+-- >>> isAsyncException AsyncEx+-- True++-- | Check if the given exception is considered synchronous.+isSyncException :: E.Exception e => e -> Bool+isSyncException e = case E.fromException (E.toException e) of+ Just E.SomeAsyncException{} -> False+ Nothing -> True++-- | Check if the given exception is considered asynchronous.+isAsyncException :: E.Exception e => e -> Bool+isAsyncException e = case E.fromException (E.toException e) of+ Just E.SomeAsyncException{} -> True+ Nothing -> False++----------------------------------------+-- Low-level API++-- | Lifted 'E.mask'.+mask :: ((forall r. Eff es r -> Eff es r) -> Eff es a) -> Eff es a+mask k = reallyUnsafeUnliftIO $ \unlift -> do+ E.mask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release)++-- | Lifted 'E.mask_'.+mask_ :: Eff es a -> Eff es a+mask_ action = reallyUnsafeUnliftIO $ \unlift -> do+ E.mask_ (unlift action)++-- | Lifted 'E.uninterruptibleMask'.+uninterruptibleMask :: ((forall r. Eff es r -> Eff es r) -> Eff es a) -> Eff es a+uninterruptibleMask k = reallyUnsafeUnliftIO $ \unlift -> do+ E.uninterruptibleMask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release)++-- | Lifted 'E.uninterruptibleMask_'.+uninterruptibleMask_ :: Eff es a -> Eff es a+uninterruptibleMask_ action = reallyUnsafeUnliftIO $ \unlift -> do+ E.uninterruptibleMask_ (unlift action)++-- | Lifted 'E.getMaskingState'.+getMaskingState :: Eff es E.MaskingState+getMaskingState = unsafeEff_ E.getMaskingState++-- | Lifted 'E.interruptible'.+interruptible :: Eff es a -> Eff es a+interruptible action = reallyUnsafeUnliftIO $ \unlift -> do+ E.interruptible (unlift action)++-- | Lifted 'E.allowInterrupt'.+allowInterrupt :: Eff es ()+allowInterrupt = unsafeEff_ E.allowInterrupt++-- $setup+-- >>> import Control.Exception (Exception)+-- >>> import Control.Exception (asyncExceptionFromException)+-- >>> import Control.Exception (asyncExceptionToException)
src/Effectful/Fail.hs view
@@ -14,11 +14,11 @@ import Effectful.Internal.Monad (Fail(..)) -- | Run the 'Fail' effect via 'Error'.-runFail :: Eff (Fail : es) a -> Eff es (Either String a)-runFail = reinterpret runErrorNoCallStack $ \_ -> \case+runFail :: HasCallStack => Eff (Fail : es) a -> Eff es (Either String a)+runFail = reinterpret_ runErrorNoCallStack $ \case Fail msg -> throwError msg -- | Run the 'Fail' effect via the 'MonadFail' instance for 'IO'.-runFailIO :: IOE :> es => Eff (Fail : es) a -> Eff es a-runFailIO = interpret $ \_ -> \case+runFailIO :: (HasCallStack, IOE :> es) => Eff (Fail : es) a -> Eff es a+runFailIO = interpret_ $ \case Fail msg -> liftIO $ fail msg
+ src/Effectful/Input/Dynamic.hs view
@@ -0,0 +1,68 @@+-- | The dynamically dispatched variant of the 'Input' effect.+--+-- /Note:/ unless you plan to change interpretations at runtime, it's+-- recommended to use one of the statically dispatched variants,+-- i.e. "Effectful.Input.Static" or "Effectful.Input.Static.Action".+--+-- @since 2.7.0.0+module Effectful.Input.Dynamic+ ( -- * Effect+ Input(..)++ -- ** Handlers+ , runInput+ , runInputAction++ -- ** Operations+ , input+ , inputs+ ) where++import Effectful+import Effectful.Dispatch.Dynamic++-- | Provide access to values of type @i@.+data Input i :: Effect where+ Input :: Input i m i++type instance DispatchOf (Input i) = Dynamic++----------------------------------------+-- Handlers++-- | Run the 'Input' effect with the given value.+runInput+ :: HasCallStack+ => i+ -- ^ The input value.+ -> Eff (Input i : es) a+ -> Eff es a+runInput inputValue = interpret_ $ \case+ Input -> pure inputValue++-- | Run the 'Input' effect with the given action that supplies values.+runInputAction+ :: forall i es a+ . HasCallStack+ => (HasCallStack => Eff es i)+ -- ^ The action for input generation.+ -> Eff (Input i : es) a+ -> Eff es a+runInputAction inputAction = interpret_ $ \case+ Input -> inputAction++----------------------------------------+-- Operations++-- | Fetch the value.+input :: (HasCallStack, Input i :> es) => Eff es i+input = send Input++-- | Fetch the result of applying a function to the value.+--+-- @'inputs' f ≡ f '<$>' 'input'@+inputs+ :: (HasCallStack, Input i :> es)+ => (i -> a) -- ^ The function to apply to the value.+ -> Eff es a+inputs f = f <$> input
+ src/Effectful/Input/Static.hs view
@@ -0,0 +1,49 @@+-- | Support for access to a value of a particular type.+--+-- @since 2.7.0.0+module Effectful.Input.Static+ ( -- * Effect+ Input++ -- ** Handlers+ , runInput++ -- ** Operations+ , input+ , inputs+ ) where++import Data.Kind++import Effectful+import Effectful.Dispatch.Static++-- | Provide access to a value of type @i@.+data Input (i :: Type) :: Effect++type instance DispatchOf (Input i) = Static NoSideEffects+newtype instance StaticRep (Input i) = Input i++-- | Run the 'Input' effect with the given value.+runInput+ :: HasCallStack+ => i+ -- ^ The input value.+ -> Eff (Input i : es) a+ -> Eff es a+runInput = evalStaticRep . Input++-- | Fetch the value.+input :: (HasCallStack, Input i :> es) => Eff es i+input = do+ Input i <- getStaticRep+ pure i++-- | Fetch the result of applying a function to the value.+--+-- @'inputs' f ≡ f '<$>' 'input'@+inputs+ :: (HasCallStack, Input i :> es)+ => (i -> a) -- ^ The function to apply to the value.+ -> Eff es a+inputs f = f <$> input
+ src/Effectful/Input/Static/Action.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE ImplicitParams #-}+-- | Support for access to values supplied by a monadic action.+--+-- @since 2.7.0.0+module Effectful.Input.Static.Action+ ( -- * Effect+ Input++ -- ** Handlers+ , runInput++ -- ** Operations+ , input+ , inputs+ ) where++import Data.Kind+import GHC.Stack++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils++-- | Provide access to values of type @i@ supplied by a monadic action.+data Input (i :: Type) :: Effect++type instance DispatchOf (Input i) = Static NoSideEffects++-- | Wrapper to prevent a space leak on reconstruction of 'Input' in+-- 'relinkInput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).+newtype InputImpl i es where+ InputImpl :: (HasCallStack => Eff es i) -> InputImpl i es++data instance StaticRep (Input i) where+ Input+ :: !(Env inputEs)+ -> !(InputImpl i inputEs)+ -> StaticRep (Input i)++-- | Run the 'Input' effect with the given action that supplies values.+runInput+ :: forall i es a+ . HasCallStack+ => (HasCallStack => Eff es i)+ -- ^ The action for input generation.+ -> Eff (Input i : es) a+ -> Eff es a+runInput inputAction action = unsafeEff $ \es -> do+ inlineBracket+ (consEnv (Input es inputImpl) relinkInput es)+ unconsEnv+ (unEff action)+ where+ inputImpl = InputImpl $ let ?callStack = thawCallStack ?callStack in inputAction++-- | Fetch the value.+input :: (HasCallStack, Input i :> es) => Eff es i+input = unsafeEff $ \es -> do+ Input inputEs (InputImpl inputAction) <- getEnv es+ -- Corresponds to thawCallStack in runInput.+ (`unEff` inputEs) $ withFrozenCallStack inputAction++-- | Fetch the result of applying a function to the value.+--+-- @'inputs' f ≡ f '<$>' 'input'@+inputs+ :: (HasCallStack, Input i :> es)+ => (i -> a) -- ^ The function to apply to the value.+ -> Eff es a+inputs f = f <$> input++----------------------------------------+-- Helpers++relinkInput :: Relinker StaticRep (Input i)+relinkInput = Relinker $ \relink (Input inputEs inputAction) -> do+ newActionEs <- relink inputEs+ pure $ Input newActionEs inputAction
src/Effectful/Internal/Effect.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | Type-safe indexing for 'Effectful.Internal.Monad.Env'. --@@ -10,10 +9,10 @@ , (:>)(..) , (:>>) , Subset(..)+ , KnownSubset , KnownPrefix(..) , IsUnknownSuffixOf , type (++)- , KnownEffects(..) -- * Re-exports , Type@@ -70,8 +69,8 @@ ---------------------------------------- --- | Provide evidence that @xs@ is a subset of @es@.-class KnownPrefix es => Subset (xs :: [Effect]) (es :: [Effect]) where+-- | Provide evidence that @subEs@ is a subset of @es@.+class KnownPrefix es => Subset (subEs :: [Effect]) (es :: [Effect]) where subsetFullyKnown :: Bool subsetFullyKnown = -- Don't show "minimal complete definition" in haddock.@@ -86,8 +85,8 @@ -- have the same unknown suffix. instance {-# INCOHERENT #-} ( KnownPrefix es- , xs `IsUnknownSuffixOf` es- ) => Subset xs es where+ , subEs `IsUnknownSuffixOf` es+ ) => Subset subEs es where subsetFullyKnown = False reifyIndices = [] @@ -96,12 +95,19 @@ subsetFullyKnown = True reifyIndices = [] -instance (e :> es, Subset xs es) => Subset (e : xs) es where- subsetFullyKnown = subsetFullyKnown @xs @es- reifyIndices = reifyIndex @e @es : reifyIndices @xs @es+instance (e :> es, Subset subEs es) => Subset (e : subEs) es where+ subsetFullyKnown = subsetFullyKnown @subEs @es+ reifyIndices = reifyIndex @e @es : reifyIndices @subEs @es ---- +-- | Provide evidence that @subEs@ is a known subset of @es@.+class Subset subEs es => KnownSubset (subEs :: [Effect]) (es :: [Effect])+instance KnownSubset '[] es+instance (e :> es, KnownSubset subEs es) => KnownSubset (e : subEs) es++----+ -- | Calculate length of a statically known prefix of @es@. class KnownPrefix (es :: [Effect]) where prefixLength :: Int@@ -114,10 +120,10 @@ ---- --- | Require that @xs@ is the unknown suffix of @es@.-class (xs :: [Effect]) `IsUnknownSuffixOf` (es :: [Effect])-instance {-# INCOHERENT #-} xs ~ es => xs `IsUnknownSuffixOf` es-instance xs `IsUnknownSuffixOf` es => xs `IsUnknownSuffixOf` (e : es)+-- | Require that @subEs@ is the unknown suffix of @es@.+class (subEs :: [Effect]) `IsUnknownSuffixOf` (es :: [Effect])+instance {-# INCOHERENT #-} subEs ~ es => subEs `IsUnknownSuffixOf` es+instance subEs `IsUnknownSuffixOf` es => subEs `IsUnknownSuffixOf` (e : es) ---- @@ -127,16 +133,3 @@ (x : xs) ++ ys = x : xs ++ ys infixr 5 ++---- | Calculate length of a list of known effects.-class KnownEffects (es :: [Effect]) where- knownEffectsLength :: Int- knownEffectsLength =- -- Don't show "minimal complete definition" in haddock.- error "knownEffectsLength"--instance KnownEffects es => KnownEffects (e : es) where- knownEffectsLength = 1 + knownEffectsLength @es--instance KnownEffects '[] where- knownEffectsLength = 0
+ src/Effectful/Internal/Effect/Dynamic.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -Wno-orphans #-}+-- | Definitions and instances for MTL compatibility.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Effect.Dynamic where++import Control.Monad.Except qualified as MTL+import Control.Monad.Reader qualified as MTL+import Control.Monad.State qualified as MTL+import Control.Monad.Writer qualified as MTL+import GHC.Stack (CallStack)++import Effectful.Internal.Effect+import Effectful.Internal.Env+import Effectful.Internal.Monad++-- | Provide the ability to handle errors of type @e@.+data Error e :: Effect where+ -- | @since 2.4.0.0+ ThrowErrorWith :: (e -> String) -> e -> Error e m a+ -- | @since 2.7.0.0+ RethrowErrorWith :: (e -> String) -> CallStack -> e -> Error e m a+ CatchError :: m a -> (CallStack -> e -> m a) -> Error e m a++type instance DispatchOf (Error e) = Dynamic++-- | Instance included for compatibility with existing code.+instance+ ( Show e+ , Error e :> es+ , MTL.MonadError e (Eff es)+ ) => MTL.MonadError e (Eff es) where+ throwError = send . ThrowErrorWith show+ catchError action = send . CatchError action . const++----------------------------------------++data Reader r :: Effect where+ Ask :: Reader r m r+ Local :: (r -> r) -> m a -> Reader r m a++type instance DispatchOf (Reader r) = Dynamic++-- | Instance included for compatibility with existing code.+instance+ ( Reader r :> es+ , MTL.MonadReader r (Eff es)+ ) => MTL.MonadReader r (Eff es) where+ ask = send Ask+ local f = send . Local f+ reader f = f <$> send Ask++----------------------------------------++-- | Provide access to a mutable value of type @s@.+data State s :: Effect where+ Get :: State s m s+ Put :: s -> State s m ()+ State :: (s -> (a, s)) -> State s m a+ StateM :: (s -> m (a, s)) -> State s m a++{-# DEPRECATED StateM "Use a combination of Get and Put instead." #-}++type instance DispatchOf (State s) = Dynamic++-- | Instance included for compatibility with existing code.+instance+ ( State s :> es+ , MTL.MonadState s (Eff es)+ ) => MTL.MonadState s (Eff es) where+ get = send Get+ put = send . Put+ state = send . State++----------------------------------------++-- | Provide access to a write only value of type @w@.+data Writer w :: Effect where+ Tell :: w -> Writer w m ()+ Listen :: m a -> Writer w m (a, w)++type instance DispatchOf (Writer w) = Dynamic++-- | Instance included for compatibility with existing code.+--+-- /Warning:/ 'MTL.pass' is not implemented due to ambiguous semantics in+-- presence of runtime exceptions, so calling it (also indirectly via+-- 'MTL.censor', which is defined in terms of 'MTL.pass') results in a runtime+-- error.+instance+ ( Monoid w+ , Writer w :> es+ , MTL.MonadWriter w (Eff es)+ ) => MTL.MonadWriter w (Eff es) where+ writer (a, w) = a <$ send (Tell w)+ tell = send . Tell+ listen = send . Listen+ pass = error "pass is not implemented due to ambiguous semantics in presence of runtime exceptions"
src/Effectful/Internal/Env.hs view
@@ -1,11 +1,30 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} module Effectful.Internal.Env ( -- * The environment Env(..)+ , Ref(..)+ , Version , Storage(..) + -- ** StorageData+ , StorageData(..)+ , cloneStorage+ , replaceStorage+ , backupStorageData+ , restoreStorageData++ -- *** Utils+ , AnyRelinker+ , toAnyRelinker+ , fromAnyRelinker+ , AnyEffect+ , toAnyEffect+ , fromAnyEffect+ -- ** Relinker , Relinker(..) , dummyRelinker@@ -19,7 +38,6 @@ -- * Operations , emptyEnv , cloneEnv- , restoreEnv , sizeEnv , tailEnv @@ -40,9 +58,13 @@ import Control.Monad import Control.Monad.Primitive+import Data.IORef.Strict qualified as S import Data.Primitive.PrimArray import Data.Primitive.SmallArray-import GHC.Stack (HasCallStack)+import Data.Primitive.Types+import Data.Proxy+import GHC.Exts ((*#), (+#))+import GHC.Stack import Effectful.Internal.Effect import Effectful.Internal.Utils@@ -73,28 +95,206 @@ -- - Cloning: /@O(N)@/, where @N@ is the size of the 'Storage'. -- data Env (es :: [Effect]) = Env- { envOffset :: !Int- , envRefs :: !(PrimArray Int)- , envStorage :: !(IORef' Storage)+ { offset :: !Int+ , refs :: !(PrimArray Ref)+ , storage :: !(S.IORef Storage) } +-- | Reference to the effect in 'Storage'.+data Ref = Ref !Int !Version++instance Prim Ref where+ sizeOfType# _ = 2# *# sizeOfType# (Proxy @Int)+ alignmentOfType# _ = alignmentOfType# (Proxy @Int)+ indexByteArray# arr i =+ let n = 2# *# i+ ref = indexByteArray# arr n+ version = indexByteArray# arr (n +# 1#)+ in Ref ref version+ readByteArray# arr i s0 =+ let n = 2# *# i+ !(# s1, ref #) = readByteArray# arr n s0+ !(# s2, version #) = readByteArray# arr (n +# 1#) s1+ in (# s2, Ref ref version #)+ writeByteArray# arr i (Ref ref version) s0 =+ let n = 2# *# i+ s1 = writeByteArray# arr n ref s0+ s2 = writeByteArray# arr (n +# 1#) version s1+ in s2+ indexOffAddr# addr i =+ let n = 2# *# i+ ref = indexOffAddr# addr n+ version = indexOffAddr# addr (n +# 1#)+ in Ref ref version+ readOffAddr# addr i s0 =+ let n = 2# *# i+ !(# s1, ref #) = readOffAddr# addr n s0+ !(# s2, version #) = readOffAddr# addr (n +# 1#) s1+ in (# s2, Ref ref version #)+ writeOffAddr# addr i (Ref ref version) s0 =+ let n = 2# *# i+ s1 = writeOffAddr# addr n ref s0+ s2 = writeOffAddr# addr (n +# 1#) version s1+ in s2++-- | Version of the effect.+newtype Version = Version Int+ deriving newtype (Eq, Ord, Prim, Show)+ -- | A storage of effects. data Storage = Storage- { stSize :: !Int- , stVersion :: !Int- , stVersions :: !(MutablePrimArray RealWorld Int)- , stEffects :: !(SmallMutableArray RealWorld Any)- , stRelinkers :: !(SmallMutableArray RealWorld Any)+ { version :: !Version+ , data_ :: {-# UNPACK #-} !StorageData } ----------------------------------------+-- StorageData++-- | Effect in 'Storage'.+newtype AnyEffect = AnyEffect Any++toAnyEffect :: EffectRep (DispatchOf e) e -> AnyEffect+toAnyEffect = AnyEffect . toAny++fromAnyEffect :: AnyEffect -> EffectRep (DispatchOf e) e+fromAnyEffect (AnyEffect e) = fromAny e++-- | Relinker in 'Storage'.+newtype AnyRelinker = AnyRelinker Any++toAnyRelinker :: Relinker (EffectRep (DispatchOf e)) e -> AnyRelinker+toAnyRelinker = AnyRelinker . toAny++fromAnyRelinker :: AnyRelinker -> Relinker (EffectRep (DispatchOf e)) e+fromAnyRelinker (AnyRelinker f) = fromAny f++----------------------------------------++data StorageData = StorageData+ { size :: !Int+ , versions :: !(MutablePrimArray RealWorld Version)+ , effects :: !(SmallMutableArray RealWorld AnyEffect)+ , relinkers :: !(SmallMutableArray RealWorld AnyRelinker)+ }++-- | Clone the storage to use it in a different thread.+--+-- @since 2.7.0.0+cloneStorage :: HasCallStack => S.IORef Storage -> IO (S.IORef Storage)+cloneStorage storage0 = do+ Storage version storageData0 <- S.readIORef storage0+ storageData <- copyStorageData storageData0+ storage <- S.newIORef $ Storage version storageData+ relinkStorageData storageData storage+ pure storage++-- | Replace the storage of the environment.+--+-- @since 2.7.0.0+replaceStorage :: Env es -> S.IORef Storage -> IO (Env es)+replaceStorage (Env offset refs _) storage = pure $ Env offset refs storage++-- | Make a shallow copy of the 'StorageData'.+--+-- @since 2.5.0.0+copyStorageData :: HasCallStack => StorageData -> IO StorageData+copyStorageData (StorageData storageSize vs0 es0 fs0) = do+ vsSize <- getSizeofMutablePrimArray vs0+ esSize <- getSizeofSmallMutableArray es0+ fsSize <- getSizeofSmallMutableArray fs0+ when (vsSize /= esSize) $ do+ error $ "vsSize (" ++ show vsSize ++ ") /= esSize (" ++ show esSize ++ ")"+ when (esSize /= fsSize) $ do+ error $ "esSize (" ++ show esSize ++ ") /= fsSize (" ++ show fsSize ++ ")"+ vs <- cloneMutablePrimArray vs0 0 vsSize+ es <- cloneSmallMutableArray es0 0 esSize+ fs <- cloneSmallMutableArray fs0 0 fsSize+ pure $ StorageData storageSize vs es fs++-- | Relink effects in the storage data to the given storage.+--+-- @since 2.7.0.0+relinkStorageData :: HasCallStack => StorageData -> S.IORef Storage -> IO ()+relinkStorageData (StorageData storageSize _ es fs) storage = go storageSize+ where+ go = \case+ 0 -> pure ()+ k -> do+ let i = k - 1+ Relinker relinker <- fromAnyRelinker <$> readSmallArray fs i+ readSmallArray es i+ >>= relinker (relinkEnv storage) . fromAnyEffect+ >>= writeSmallArray' es i . toAnyEffect+ go i++-- | Backup storage data of the environment.+--+-- It can be restored later with 'restoreStorageData'.+--+-- @since 2.7.0.0+backupStorageData :: HasCallStack => Env es -> IO StorageData+backupStorageData env = do+ storageData <- copyStorageData . (.data_) =<< S.readIORef env.storage+ -- Relinking to the same storage might seem weird, but relinkers need to run+ -- and make a copy of mutable data associated with statically dispatched+ -- effects if appropriate.+ relinkStorageData storageData env.storage+ pure storageData++-- | Restore a copy of the 'StorageData'.+--+-- The copy needs to be from the same 'Env' as the target. It's consumed by this+-- operation and must not be used afterwards.+--+-- @since 2.5.0.0+restoreStorageData :: HasCallStack => StorageData -> Env es -> IO ()+restoreStorageData (StorageData newSize vs1 es1 fs1) env = do+ Storage version (StorageData oldSize vs0 es0 fs0) <- S.readIORef env.storage+ when (newSize /= oldSize) $ do+ error $ "newSize (" ++ show newSize ++ ") /= oldSize (" ++ show oldSize ++ ")"+ -- Since the time the backup was made the storage might've been grown by+ -- 'insertEffect', so if necessary create new arrays matching the current+ -- capacity, as shrinking it would violate the invariant that out of date+ -- references in 'getLocation' never read out of bounds.+ vs0size <- getSizeofMutablePrimArray vs0+ vs1size <- getSizeofMutablePrimArray vs1+ vs <- if vs0size > vs1size+ then do+ vs <- newPrimArray vs0size+ copyMutablePrimArray vs 0 vs1 0 newSize+ -- Fill the unused part of the versions array with+ -- 'undefinedVersion' to maintain the invariant that slots beyond+ -- the size of the storage never contain garbage (see the note on+ -- 'undefinedVersion').+ setPrimArray vs newSize (vs0size - newSize) undefinedVersion+ pure vs+ else pure vs1+ es0size <- getSizeofSmallMutableArray es0+ es1size <- getSizeofSmallMutableArray es1+ es <- if es0size > es1size+ then do+ es <- newSmallArray es0size undefinedEffect+ copySmallMutableArray es 0 es1 0 newSize+ pure es+ else pure es1+ fs0size <- getSizeofSmallMutableArray fs0+ fs1size <- getSizeofSmallMutableArray fs1+ fs <- if fs0size > fs1size+ then do+ fs <- newSmallArray fs0size undefinedRelinker+ copySmallMutableArray fs 0 fs1 0 newSize+ pure fs+ else pure fs1+ S.writeIORef env.storage $ Storage version (StorageData newSize vs es fs)++---------------------------------------- -- Relinker -- | A function for relinking 'Env' objects stored in the handlers and/or making -- a deep copy of the representation of the effect when cloning the environment. newtype Relinker :: (Effect -> Type) -> Effect -> Type where Relinker- :: ((forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e))+ :: (HasCallStack => (forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e)) -> Relinker rep e -- | A dummy 'Relinker'.@@ -125,100 +325,57 @@ -- Operations -- | Create an empty environment.-emptyEnv :: IO (Env '[])+emptyEnv :: HasCallStack => IO (Env '[]) emptyEnv = Env 0 <$> (unsafeFreezePrimArray =<< newPrimArray 0)- <*> (newIORef' =<< emptyStorage)+ <*> (S.newIORef =<< emptyStorage) -- | Clone the environment to use it in a different thread.-cloneEnv :: Env es -> IO (Env es)-cloneEnv (Env offset refs storage0) = do- Storage storageSize version vs0 es0 fs0 <- readIORef' storage0- vsSize <- getSizeofMutablePrimArray vs0- esSize <- getSizeofSmallMutableArray es0- fsSize <- getSizeofSmallMutableArray fs0- when (vsSize /= esSize) $ do- error $ "vsSize (" ++ show vsSize ++ ") /= esSize (" ++ show esSize ++ ")"- when (esSize /= fsSize) $ do- error $ "esSize (" ++ show esSize ++ ") /= fsSize (" ++ show fsSize ++ ")"- vs <- cloneMutablePrimArray vs0 0 vsSize- es <- cloneSmallMutableArray es0 0 esSize- fs <- cloneSmallMutableArray fs0 0 fsSize- storage <- newIORef' $ Storage storageSize version vs es fs- let relinkEffects = \case- 0 -> pure ()- k -> do- let i = k - 1- Relinker f <- fromAny <$> readSmallArray fs i- readSmallArray es i- >>= f (relinkEnv storage) . fromAny- >>= writeSmallArray' es i . toAny- relinkEffects i- relinkEffects storageSize- pure $ Env offset refs storage-{-# NOINLINE cloneEnv #-}---- | Restore the environment from its clone.------ @since 2.2.0.0-restoreEnv- :: Env es -- ^ Destination.- -> Env es -- ^ Source.- -> IO ()-restoreEnv dest src = do- destStorage <- readIORef' (envStorage dest)- srcStorage <- readIORef' (envStorage src)- let destStorageSize = stSize destStorage- srcStorageSize = stSize srcStorage- when (destStorageSize /= srcStorageSize) $ do- error $ "destStorageSize (" ++ show destStorageSize- ++ ") /= srcStorageSize (" ++ show srcStorageSize ++ ")"- writeIORef' (envStorage dest) $ srcStorage- -- Decreasing the counter allows leakage of unsafeCoerce (see unsafeCoerce2- -- in the EnvTests module).- { stVersion = max (stVersion destStorage) (stVersion srcStorage)- }-{-# NOINLINE restoreEnv #-}+cloneEnv :: HasCallStack => Env es -> IO (Env es)+cloneEnv env = replaceStorage env =<< cloneStorage env.storage -- | Get the current size of the environment. sizeEnv :: Env es -> IO Int sizeEnv (Env offset refs _) = do- pure $ (sizeofPrimArray refs - offset) `div` 2+ pure $ sizeofPrimArray refs - offset -- | Access the tail of the environment. tailEnv :: Env (e : es) -> IO (Env es) tailEnv (Env offset refs storage) = do- pure $ Env (offset + 2) refs storage+ pure $ Env (offset + 1) refs storage ---------------------------------------- -- Extending and shrinking -- | Extend the environment with a new data type. consEnv- :: EffectRep (DispatchOf e) e+ :: HasCallStack+ => EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env (e : es)) consEnv e f (Env offset refs0 storage) = do let size = sizeofPrimArray refs0 - offset- mrefs <- newPrimArray (size + 2)- copyPrimArray mrefs 2 refs0 offset size- (ref, version) <- insertEffect storage e f+ mrefs <- newPrimArray (size + 1)+ copyPrimArray mrefs 1 refs0 offset size+ ref <- insertEffect storage e f writePrimArray mrefs 0 ref- writePrimArray mrefs 1 version refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage-{-# NOINLINE consEnv #-} -- | Shrink the environment by one data type. --+-- The environment needs to come from 'consEnv', i.e. the intended usage is+-- @bracket (consEnv e f env) unconsEnv@.+-- -- /Note:/ after calling this function @e@ from the input environment is no -- longer usable.-unconsEnv :: Env (e : es) -> IO ()-unconsEnv (Env _ refs storage) = do+unconsEnv :: HasCallStack => Env (e : es) -> IO ()+unconsEnv (Env offset refs storage) = do+ when (offset /= 0) $ do+ error $ "offset (" ++ show offset ++ ") /= 0" deleteEffect storage (indexPrimArray refs 0)-{-# NOINLINE unconsEnv #-} ---------------------------------------- @@ -227,7 +384,7 @@ -- /Note:/ unlike in 'putEnv' the value in not changed in place, so only the new -- environment will see it. replaceEnv- :: forall e es. e :> es+ :: forall e es. (HasCallStack, e :> es) => EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e@@ -237,22 +394,23 @@ let size = sizeofPrimArray refs0 - offset mrefs <- newPrimArray size copyPrimArray mrefs 0 refs0 offset size- (ref, version) <- insertEffect storage e f- let i = 2 * reifyIndex @e @es- writePrimArray mrefs i ref- writePrimArray mrefs (i + 1) version+ ref <- insertEffect storage e f+ writePrimArray mrefs (reifyIndex @e @es) ref refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage-{-# NOINLINE replaceEnv #-} -- | Remove a reference to the replaced effect. --+-- The environment needs to come from 'replaceEnv', i.e. the intended usage is+-- @bracket (replaceEnv e f env) unreplaceEnv@.+-- -- /Note:/ after calling this function the input environment is no longer -- usable.-unreplaceEnv :: forall e es. e :> es => Env es -> IO ()+unreplaceEnv :: forall e es. (HasCallStack, e :> es) => Env es -> IO () unreplaceEnv (Env offset refs storage) = do- deleteEffect storage $ indexPrimArray refs (offset + 2 * reifyIndex @e @es)-{-# NOINLINE unreplaceEnv #-}+ when (offset /= 0) $ do+ error $ "offset (" ++ show offset ++ ") /= 0"+ deleteEffect storage $ indexPrimArray refs (reifyIndex @e @es) ---------------------------------------- @@ -260,37 +418,32 @@ subsumeEnv :: forall e es. e :> es => Env es -> IO (Env (e : es)) subsumeEnv (Env offset refs0 storage) = do let size = sizeofPrimArray refs0 - offset- mrefs <- newPrimArray (size + 2)- copyPrimArray mrefs 2 refs0 offset size- let ix = offset + 2 * reifyIndex @e @es- writePrimArray mrefs 0 $ indexPrimArray refs0 ix- writePrimArray mrefs 1 $ indexPrimArray refs0 (ix + 1)+ mrefs <- newPrimArray (size + 1)+ copyPrimArray mrefs 1 refs0 offset size+ writePrimArray mrefs 0 $ indexPrimArray refs0 (offset + reifyIndex @e @es) refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage-{-# NOINLINE subsumeEnv #-} ---------------------------------------- -- | Construct an environment containing a permutation (with possible -- duplicates) of a subset of effects from the input environment.-injectEnv :: forall xs es. Subset xs es => Env es -> IO (Env xs)+injectEnv :: forall subEs es. Subset subEs es => Env es -> IO (Env subEs) injectEnv (Env offset refs0 storage) = do- let xs = reifyIndices @xs @es- permSize = 2 * length xs- prefixSize = 2 * prefixLength @es- suffixSize = if subsetFullyKnown @xs @es+ let subEs = reifyIndices @subEs @es+ subEsSize = length subEs+ prefixSize = prefixLength @es+ suffixSize = if subsetFullyKnown @subEs @es then 0 else sizeofPrimArray refs0 - offset - prefixSize- mrefs <- newPrimArray (permSize + suffixSize)- copyPrimArray mrefs permSize refs0 (offset + prefixSize) suffixSize- let writePermRefs i = \case+ mrefs <- newPrimArray (subEsSize + suffixSize)+ copyPrimArray mrefs subEsSize refs0 (offset + prefixSize) suffixSize+ let writeRefs i = \case [] -> pure ()- (e : es) -> do- let ix = offset + 2 * e- writePrimArray mrefs i $ indexPrimArray refs0 ix- writePrimArray mrefs (i + 1) $ indexPrimArray refs0 (ix + 1)- writePermRefs (i + 2) es- writePermRefs 0 xs+ (x : xs) -> do+ writePrimArray mrefs i $ indexPrimArray refs0 (offset + x)+ writeRefs (i + 1) xs+ writeRefs 0 subEs refs <- unsafeFreezePrimArray mrefs pure $ Env 0 refs storage {-# NOINLINE injectEnv #-}@@ -300,138 +453,171 @@ -- | Extract a specific data type from the environment. getEnv- :: forall e es. e :> es+ :: forall e es. (HasCallStack, e :> es) => Env es -- ^ The environment. -> IO (EffectRep (DispatchOf e) e) getEnv env = do (i, es) <- getLocation @e env- fromAny <$> readSmallArray es i+ fromAnyEffect <$> readSmallArray es i -- | Replace the data type in the environment with a new value (in place). putEnv- :: forall e es. e :> es+ :: forall e es. (HasCallStack, e :> es) => Env es -- ^ The environment. -> EffectRep (DispatchOf e) e -> IO () putEnv env e = do (i, es) <- getLocation @e env- writeSmallArray' es i (toAny e)+ writeSmallArray' es i (toAnyEffect e) -- | Modify the data type in the environment and return a value (in place). stateEnv- :: forall e es a. e :> es+ :: forall e es a. (HasCallStack, e :> es) => Env es -- ^ The environment.- -> (EffectRep (DispatchOf e) e -> IO (a, EffectRep (DispatchOf e) e))+ -> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e)) -> IO a stateEnv env f = do (i, es) <- getLocation @e env- (a, e) <- f . fromAny =<< readSmallArray es i- writeSmallArray' es i (toAny e)+ (a, e) <- f . fromAnyEffect <$> readSmallArray es i+ writeSmallArray' es i (toAnyEffect e) pure a -- | Modify the data type in the environment (in place). modifyEnv- :: forall e es. e :> es+ :: forall e es. (HasCallStack, e :> es) => Env es -- ^ The environment.- -> (EffectRep (DispatchOf e) e -> IO (EffectRep (DispatchOf e) e))+ -> (EffectRep (DispatchOf e) e -> (EffectRep (DispatchOf e) e)) -> IO () modifyEnv env f = do (i, es) <- getLocation @e env- e <- f . fromAny =<< readSmallArray es i- writeSmallArray' es i (toAny e)+ e <- f . fromAnyEffect <$> readSmallArray es i+ writeSmallArray' es i (toAnyEffect e) -- | Determine location of the effect in the environment. getLocation- :: forall e es. e :> es+ :: forall e es. (HasCallStack, e :> es) => Env es- -> IO (Int, SmallMutableArray RealWorld Any)+ -> IO (Int, SmallMutableArray RealWorld AnyEffect) getLocation (Env offset refs storage) = do- let i = offset + 2 * reifyIndex @e @es- ref = indexPrimArray refs i- version = indexPrimArray refs (i + 1)- Storage _ _ vs es _ <- readIORef' storage+ Storage _ (StorageData _ vs es _) <- S.readIORef storage storageVersion <- readPrimArray vs ref -- If version of the reference is different than version in the storage, it -- means that the effect in the storage is not the one that was initially -- referenced. when (version /= storageVersion) $ do error $ "version (" ++ show version ++ ") /= storageVersion ("- ++ show storageVersion ++ ")"+ ++ show storageVersion ++ ")\n"+ ++ "If you're attempting to run an unlifting function outside "+ ++ "of the scope of effects it captures, have a look at "+ ++ "UnliftStrategy (SeqForkUnlift)." pure (ref, es)+ where+ Ref ref version = indexPrimArray refs (offset + reifyIndex @e @es) ---------------------------------------- -- Internal helpers -- | Create an empty storage.-emptyStorage :: IO Storage-emptyStorage = Storage 0 (noVersion + 1)- <$> newPrimArray 0- <*> newSmallArray 0 undefinedData- <*> newSmallArray 0 undefinedData+emptyStorage :: HasCallStack => IO Storage+emptyStorage = Storage initialVersion <$> storageData+ where+ storageData = StorageData 0+ <$> newPrimArray 0+ <*> newSmallArray 0 undefinedEffect+ <*> newSmallArray 0 undefinedRelinker -- | Insert an effect into the storage and return its reference. insertEffect- :: IORef' Storage+ :: HasCallStack+ => S.IORef Storage -> EffectRep (DispatchOf e) e -- ^ The representation of the effect. -> Relinker (EffectRep (DispatchOf e)) e- -> IO (Int, Int)+ -> IO Ref insertEffect storage e f = do- Storage size version vs0 es0 fs0 <- readIORef' storage+ Storage version (StorageData size vs0 es0 fs0) <- S.readIORef storage len0 <- getSizeofSmallMutableArray es0 case size `compare` len0 of GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")" LT -> do writePrimArray vs0 size version- writeSmallArray' es0 size (toAny e)- writeSmallArray' fs0 size (toAny f)- writeIORef' storage $ Storage (size + 1) (version + 1) vs0 es0 fs0- pure (size, version)+ writeSmallArray' es0 size (toAnyEffect e)+ writeSmallArray' fs0 size (toAnyRelinker f)+ S.writeIORef storage $+ Storage (bumpVersion version) (StorageData (size + 1) vs0 es0 fs0)+ pure $ Ref size version EQ -> do- let len = doubleCapacity len0+ let len = growCapacity len0 vs <- newPrimArray len- es <- newSmallArray len undefinedData- fs <- newSmallArray len undefinedData+ es <- newSmallArray len undefinedEffect+ fs <- newSmallArray len undefinedRelinker+ -- Fill the unused part of the versions array with 'undefinedVersion' to+ -- maintain the invariant that slots beyond the size of the storage never+ -- contain garbage (see the note on 'undefinedVersion').+ setPrimArray vs size (len - size) undefinedVersion copyMutablePrimArray vs 0 vs0 0 size copySmallMutableArray es 0 es0 0 size copySmallMutableArray fs 0 fs0 0 size writePrimArray vs size version- writeSmallArray' es size (toAny e)- writeSmallArray' fs size (toAny f)- writeIORef' storage $ Storage (size + 1) (version + 1) vs es fs- pure (size, version)+ writeSmallArray' es size (toAnyEffect e)+ writeSmallArray' fs size (toAnyRelinker f)+ S.writeIORef storage $+ Storage (bumpVersion version) (StorageData (size + 1) vs es fs)+ pure $ Ref size version+{-# NOINLINE insertEffect #-} -- | Given a reference to an effect from the top of the stack, delete it from -- the storage.-deleteEffect :: IORef' Storage -> Int -> IO ()-deleteEffect storage ref = do- Storage size version vs es fs <- readIORef' storage+deleteEffect :: HasCallStack => S.IORef Storage -> Ref -> IO ()+deleteEffect storage (Ref ref version) = do+ Storage currentVersion (StorageData size vs es fs) <- S.readIORef storage when (ref /= size - 1) $ do error $ "ref (" ++ show ref ++ ") /= size - 1 (" ++ show (size - 1) ++ ")"- writePrimArray vs ref noVersion- writeSmallArray es ref undefinedData- writeSmallArray fs ref undefinedData- writeIORef' storage $ Storage (size - 1) version vs es fs+ storageVersion <- readPrimArray vs ref+ when (version /= storageVersion) $ do+ error $ "version (" ++ show version ++ ") /= storageVersion ("+ ++ show storageVersion ++ ")\n"+ writePrimArray vs ref undefinedVersion+ writeSmallArray es ref undefinedEffect+ writeSmallArray fs ref undefinedRelinker+ S.writeIORef storage $ Storage currentVersion (StorageData (size - 1) vs es fs)+{-# NOINLINE deleteEffect #-} -- | Relink the environment to use the new storage.-relinkEnv :: IORef' Storage -> Env es -> IO (Env es)+relinkEnv :: S.IORef Storage -> Env es -> IO (Env es) relinkEnv storage (Env offset refs _) = pure $ Env offset refs storage --- | Double the capacity of an array.-doubleCapacity :: Int -> Int-doubleCapacity n = max 1 n * 2+-- | Version of an unused slot.+--+-- /Note:/ slots of the versions array beyond the current size of the storage+-- always contain 'undefinedVersion', so that out of date references to them+-- reliably fail the version check in 'getLocation'. This invariant is+-- maintained by 'insertEffect', 'deleteEffect' and 'restoreStorageData'.+undefinedVersion :: Version+undefinedVersion = Version 0 -noVersion :: Int-noVersion = 0+initialVersion :: Version+initialVersion = Version 1 -undefinedData :: HasCallStack => a-undefinedData = error "undefined data"+bumpVersion :: Version -> Version+bumpVersion (Version n) = Version (n + 1) +undefinedEffect :: HasCallStack => AnyEffect+undefinedEffect = toAnyEffect . errorWithoutStackTrace $ unlines+ [ "Undefined effect"+ , "Created at: " ++ prettyCallStack callStack+ ]++undefinedRelinker :: HasCallStack => AnyRelinker+undefinedRelinker = toAnyRelinker $ Relinker $ \_ _ -> do+ errorWithoutStackTrace $ unlines+ [ "Undefined relinker"+ , "Created at: " ++ prettyCallStack creationCallStack+ , "Called at: " ++ prettyCallStack callStack+ ]+ where+ creationCallStack = callStack+ -- | A strict version of 'writeSmallArray'. writeSmallArray' :: SmallMutableArray RealWorld a -> Int -> a -> IO () writeSmallArray' arr i a = a `seq` writeSmallArray arr i a--#if !MIN_VERSION_primitive(0,9,0)-getSizeofSmallMutableArray :: SmallMutableArray RealWorld a -> IO Int-getSizeofSmallMutableArray arr = pure $! sizeofSmallMutableArray arr-#endif
src/Effectful/Internal/Monad.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_HADDOCK not-home #-} -- | The 'Eff' monad.@@ -46,18 +45,25 @@ , withUnliftStrategy , withSeqEffToIO , withEffToIO- , withConcEffToIO+ , reallyUnsafeLiftMapIO+ , reallyUnsafeUnliftIO -- ** Low-level unlifts , seqUnliftIO+ , seqForkUnliftIO , concUnliftIO+ , seqForkUnliftsIO+ , concUnliftsIO -- * Dispatch -- ** Dynamic dispatch , EffectHandler- , LocalEnv(..)+ , LocalEnv+ , unwrapLocalEnv+ , requireMatchingStorages , Handler(..)+ , HandlerImpl(..) , relinkHandler , runHandler , send@@ -73,16 +79,10 @@ , stateStaticRep , stateStaticRepM , localStaticRep-- -- *** Primitive operations- , consEnv- , getEnv- , putEnv- , stateEnv- , modifyEnv ) where import Control.Applicative+import Control.Concurrent (myThreadId) import Control.Exception qualified as E import Control.Monad import Control.Monad.Base@@ -124,12 +124,12 @@ -- -- - Allows the effects to be handled in any order. newtype Eff (es :: [Effect]) a = Eff (Env es -> IO a)- deriving (Monoid, Semigroup)+ deriving newtype (Monoid, Semigroup) -- | Run a pure 'Eff' computation. -- -- For running computations with side effects see 'runEff'.-runPureEff :: Eff '[] a -> a+runPureEff :: HasCallStack => Eff '[] a -> a runPureEff (Eff m) = -- unsafeDupablePerformIO is safe here since IOE was not on the stack, so no -- IO with side effects was performed (unless someone sneakily introduced side@@ -144,7 +144,7 @@ -- | Peel off the constructor of 'Eff'. unEff :: Eff es a -> Env es -> IO a-unEff = \(Eff m) -> m+unEff (Eff m) = m -- | Access the underlying 'IO' monad along with the environment. --@@ -167,13 +167,13 @@ -- -- /Note:/ this strategy is implicitly used by the 'MonadUnliftIO' and -- 'MonadBaseControl' instance for 'Eff'.-unliftStrategy :: IOE :> es => Eff es UnliftStrategy+unliftStrategy :: (HasCallStack, IOE :> es) => Eff es UnliftStrategy unliftStrategy = do IOE unlift <- getStaticRep pure unlift -- | Locally override the current 'UnliftStrategy' with the given value.-withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a+withUnliftStrategy :: (HasCallStack, IOE :> es) => UnliftStrategy -> Eff es a -> Eff es a withUnliftStrategy unlift = localStaticRep $ \_ -> IOE unlift -- | Create an unlifting function with the 'SeqUnlift' strategy. For the general@@ -188,7 +188,8 @@ => ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> Eff es a-withSeqEffToIO f = unsafeEff $ \es -> seqUnliftIO es f+withSeqEffToIO k = unsafeEff $ \es -> seqUnliftIO es k+{-# INLINE withSeqEffToIO #-} -- | Create an unlifting function with the given strategy. --@@ -202,32 +203,38 @@ -> Eff es a withEffToIO strategy k = case strategy of SeqUnlift -> unsafeEff $ \es -> seqUnliftIO es k+ SeqForkUnlift -> unsafeEff $ \es -> seqForkUnliftIO es k ConcUnlift p b -> unsafeEff $ \es -> concUnliftIO es p b k {-# INLINE withEffToIO #-} --- | Create an unlifting function with the 'ConcUnlift' strategy.------ @since 2.2.2.0-withConcEffToIO- :: (HasCallStack, IOE :> es)- => Persistence- -> Limit+-- | Create an unlifting function with the 'SeqUnlift' strategy.+seqUnliftIO+ :: HasCallStack+ => Env es+ -- ^ The environment. -> ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope.- -> Eff es a-withConcEffToIO persistence limit f = unsafeEff $ \es ->- concUnliftIO es persistence limit f-{-# DEPRECATED withConcEffToIO "Use withEffToIO with the appropriate strategy." #-}+ -> IO a+seqUnliftIO es k = do+ tid0 <- myThreadId+ k $ \m -> do+ tid <- myThreadId+ if tid == tid0+ then unEff m es+ else error+ $ "If you want to use the unlifting function to run Eff computations "+ ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)." --- | Create an unlifting function with the 'SeqUnlift' strategy.-seqUnliftIO+-- | Create an unlifting function with the 'SeqForkUnlift' strategy.+seqForkUnliftIO :: HasCallStack => Env es -- ^ The environment. -> ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> IO a-seqUnliftIO es k = seqUnlift k es unEff+seqForkUnliftIO es0 k = cloneEnv es0 >>= \es -> seqUnliftIO es k+{-# INLINE seqForkUnliftIO #-} -- | Create an unlifting function with the 'ConcUnlift' strategy. concUnliftIO@@ -239,8 +246,118 @@ -> ((forall r. Eff es r -> IO r) -> IO a) -- ^ Continuation with the unlifting function in scope. -> IO a-concUnliftIO es persistence limit k = concUnlift persistence limit k es unEff+concUnliftIO es Ephemeral (Limited uses) k = ephemeralConcLimitedUnlift es uses k+concUnliftIO es Ephemeral Unlimited k = ephemeralConcUnlimitedUnlift es k+concUnliftIO es Persistent (Limited threads) k =+ if threads == 1+ then persistentConcSingleUnlift es k+ else persistentConcUnlift es False threads k+concUnliftIO es Persistent Unlimited k = persistentConcUnlift es True maxBound k +-- | Create two unlifting functions with the 'SeqForkUnlift' strategy.+--+-- The unlifting functions will share the effect storage (unlike with two+-- separate calls to 'seqForkUnliftIO').+--+-- /Warning:/ both environments must have the same underlying storage.+--+-- @since 2.7.0.0+seqForkUnliftsIO+ :: HasCallStack+ => Env es+ -> Env localEs+ -> ((forall r. Eff es r -> IO r) -> (forall r. Eff localEs r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting functions in scope.+ -> IO a+seqForkUnliftsIO es0 les0 k = do+ storage <- cloneStorage es0.storage+ es <- replaceStorage es0 storage+ les <- replaceStorage les0 storage+ seqUnliftIO es $ \unliftEs -> do+ seqUnliftIO les $ \unliftLocalEs -> do+ k unliftEs unliftLocalEs+{-# INLINE seqForkUnliftsIO #-}++-- | Create unlifting functions with the 'ConcUnlift' strategy.+--+-- In the 'Persistent' variant the unlifting functions will share the effect+-- storage in each thread (unlike with two separate calls to 'concUnliftIO').+--+-- /Warning:/ both environments must have the same underlying storage.+--+-- @since 2.7.0.0+concUnliftsIO+ :: HasCallStack+ => Env es+ -> Env localEs+ -- ^ The environment.+ -> Persistence+ -> Limit+ -> ((forall r. Eff es r -> IO r) -> (forall r. Eff localEs r -> IO r) -> IO a)+ -- ^ Continuation with the unlifting functions in scope.+ -> IO a+concUnliftsIO es les Ephemeral (Limited uses) k = do+ ephemeralConcLimitedUnlift es uses $ \unliftEs -> do+ ephemeralConcLimitedUnlift les uses $ \unliftLocalEs -> do+ k unliftEs unliftLocalEs+concUnliftsIO es les Ephemeral Unlimited k = do+ ephemeralConcUnlimitedUnlift es $ \unliftEs -> do+ ephemeralConcUnlimitedUnlift les $ \unliftLocalEs -> do+ k unliftEs unliftLocalEs+concUnliftsIO es les Persistent (Limited threads) k = do+ if threads == 1+ then persistentConcSingleUnlifts es les k+ else persistentConcUnlifts es les False threads k+concUnliftsIO es les Persistent Unlimited k = do+ persistentConcUnlifts es les True maxBound k++-- | Utility for lifting 'IO' computations of type+--+-- @'IO' a -> 'IO' b@+--+-- to+--+-- @'Eff' es a -> 'Eff' es b@+--+-- This function is __really unsafe__ because:+--+-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'+-- computations.+--+-- - The 'IO' computation must run its argument in a way that's perceived as+-- sequential to the outside observer, e.g. in the same thread or in a worker+-- thread that finishes before the argument is run again.+--+-- __Warning:__ if you disregard the second point, you will experience weird+-- bugs, data races or internal consistency check failures.+--+-- When in doubt, use 'Effectful.Dispatch.Static.unsafeLiftMapIO', especially+-- since this version saves only a simple safety check per call of+-- @reallyUnsafeLiftMapIO f@.+reallyUnsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b+reallyUnsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es)++-- | Create an unlifting function.+--+-- This function is __really unsafe__ because:+--+-- - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'+-- computations.+--+-- - Unlifted 'Eff' computations must be run in a way that's perceived as+-- sequential to the outside observer, e.g. in the same thread as the caller+-- of 'reallyUnsafeUnliftIO' or in a worker thread that finishes before+-- another unlifted computation is run.+--+-- __Warning:__ if you disregard the second point, you will experience weird+-- bugs, data races or internal consistency check failures.+--+-- When in doubt, use 'Effectful.Dispatch.Static.unsafeSeqUnliftIO', especially+-- since this version saves only a simple safety check per call of the unlifting+-- function.+reallyUnsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a+reallyUnsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es)+ ---------------------------------------- -- Base @@ -256,10 +373,9 @@ liftA2 f (Eff ma) (Eff mb) = unsafeEff $ \es -> liftA2 f (ma es) (mb es) instance Monad (Eff es) where- return = unsafeEff_ . pure Eff m >>= k = unsafeEff $ \es -> m es >>= \a -> unEff (k a) es -- https://gitlab.haskell.org/ghc/ghc/-/issues/20008- Eff ma >> Eff mb = unsafeEff $ \es -> ma es >> mb es+ {-# INLINE (>>=) #-} instance MonadFix (Eff es) where mfix f = unsafeEff $ \es -> mfix $ \a -> unEff (f a) es@@ -270,6 +386,10 @@ -- | Provide the ability to use the 'Alternative' and 'MonadPlus' instance for -- 'Eff'. --+-- /Note:/ 'NonDet' does not backtrack. Formally, it obeys the "left-catch" law+-- for 'MonadPlus', rather than the "left-distribution" law. This means that it+-- behaves more like 'Maybe' than @[]@.+-- -- @since 2.2.0.0 data NonDet :: Effect where Empty :: NonDet m a@@ -279,7 +399,7 @@ -- | @since 2.2.0.0 instance NonDet :> es => Alternative (Eff es) where- empty = withFrozenCallStack (send Empty)+ empty = send Empty a <|> b = send (a :<|>: b) -- | @since 2.2.0.0@@ -288,28 +408,82 @@ ---------------------------------------- -- Exception +-- | Available without any effect requirements.+--+-- Gating it behind an effect (such as 'IOE' or a more specialized effect) would+-- accomplish nothing, since any Haskell expression is free to throw an+-- exception with 'E.throw' at any point. instance C.MonadThrow (Eff es) where- throwM = unsafeEff_ . E.throwIO+ throwM = unsafeEff_ . withFrozenCallStack E.throwIO +#if MIN_VERSION_base(4,21,0) && MIN_VERSION_exceptions(0,10,11)+ rethrowM = unsafeEff_ . E.rethrowIO+#endif++-- | Available without any effect requirements.+--+-- This is the one instance of the three that would arguably benefit from+-- requiring 'IOE' (or a more specialized effect), as catching imprecise+-- exceptions makes it possible to write non-deterministic pure functions with+-- 'runPureEff'. Unfortunately it can't, because t'C.MonadCatch' is a superclass+-- of t'C.MonadMask', which needs to be available unconditionally (see the note+-- there).+--+-- For the full discussion see+-- [issue #76](https://github.com/haskell-effectful/effectful/issues/76). instance C.MonadCatch (Eff es) where- catch m handler = unsafeEff $ \es -> do- unEff m es `E.catch` \e -> do- unEff (handler e) es+ catch action handler = reallyUnsafeUnliftIO $ \unlift -> do+ E.catch (unlift action) (unlift . handler) +#if MIN_VERSION_base(4,21,0) && MIN_VERSION_exceptions(0,10,11)+ catchNoPropagate action handler = reallyUnsafeUnliftIO $ \unlift -> do+ E.catchNoPropagate (unlift action) (unlift . handler)+#endif++-- | Available without any effect requirements.+--+-- This makes it possible to use cleanup functions such as+-- 'Effectful.Exception.bracket' or 'Effectful.Exception.finally' anywhere, e.g.+-- to restore a state on error:+--+-- @+-- transactionally :: forall s es a. 'Effectful.State.Static.Local.State' s ':>' es => 'Eff' es a -> 'Eff' es a+-- transactionally = 'Effectful.Exception.bracketOnError' ('Effectful.State.Static.Local.get' \@s) ('Effectful.State.Static.Local.put' \@s) . const+-- @+--+-- Requiring 'IOE' would make functions like the above impossible to write and+-- force 'IOE' to show up in application code that otherwise only needs more+-- restricted effects, which would be a significant usability regression. On the+-- other hand, requiring a more specialized effect would be annoying, since+-- functions making use of t'C.MonadMask' are ubiquitous. instance C.MonadMask (Eff es) where- mask k = unsafeEff $ \es -> E.mask $ \unmask ->- unEff (k $ \m -> unsafeEff $ unmask . unEff m) es+ mask k = reallyUnsafeUnliftIO $ \unlift -> do+ E.mask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release) - uninterruptibleMask k = unsafeEff $ \es -> E.uninterruptibleMask $ \unmask ->- unEff (k $ \m -> unsafeEff $ unmask . unEff m) es+ uninterruptibleMask k = reallyUnsafeUnliftIO $ \unlift -> do+ E.uninterruptibleMask $ \release -> unlift $ k (reallyUnsafeLiftMapIO release) - generalBracket acquire release use = unsafeEff $ \es -> E.mask $ \unmask -> do- resource <- unEff acquire es- b <- unmask (unEff (use resource) es) `E.catch` \e -> do- _ <- unEff (release resource $ C.ExitCaseException e) es- E.throwIO e- c <- unEff (release resource $ C.ExitCaseSuccess b) es- pure (b, c)+ generalBracket before after action = reallyUnsafeUnliftIO $ \unlift -> do+ E.mask $ \unmask -> do+ a <- unlift before+#if MIN_VERSION_base(4,21,0)+ b <- E.catchNoPropagate+ (unmask . unlift $ action a)+ (\ec@(E.ExceptionWithContext _ e) -> do+ _ <- E.annotateIO (E.WhileHandling (E.toException ec)) $ do+ unlift . after a $ C.ExitCaseException e+ E.rethrowIO ec+ )+#else+ b <- E.catch+ (unmask . unlift $ action a)+ (\e -> do+ _ <- unlift . after a $ C.ExitCaseException e+ E.throwIO e+ )+#endif+ c <- unlift . after a $ C.ExitCaseSuccess b+ pure (b, c) ---------------------------------------- -- Fail@@ -321,7 +495,7 @@ type instance DispatchOf Fail = Dynamic instance Fail :> es => MonadFail (Eff es) where- fail msg = withFrozenCallStack $ send (Fail msg)+ fail msg = send (Fail msg) ---------------------------------------- -- IO@@ -339,7 +513,7 @@ -- | Run an 'Eff' computation with side effects. -- -- For running pure computations see 'runPureEff'.-runEff :: Eff '[IOE] a -> IO a+runEff :: HasCallStack => Eff '[IOE] a -> IO a runEff m = unEff m =<< consEnv (IOE SeqUnlift) dummyRelinker =<< emptyEnv instance IOE :> es => MonadIO (Eff es) where@@ -387,7 +561,7 @@ data PrimStateEff -- | Run an 'Eff' computation with primitive state-transformer actions.-runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a+runPrim :: (HasCallStack, IOE :> es) => Eff (Prim : es) a -> Eff es a runPrim = evalStaticRep Prim instance Prim :> es => PrimMonad (Eff es) where@@ -398,7 +572,7 @@ -- Lifting -- | Lift an 'Eff' computation into an effect stack with one more effect.-raise :: Eff es a -> Eff (e : es) a+raise :: forall e es a. Eff es a -> Eff (e : es) a raise m = unsafeEff $ \es -> unEff m =<< tailEnv es -- | Lift an 'Eff' computation into an effect stack with one more effect and@@ -411,23 +585,23 @@ -> ((forall r. Eff (e : es) r -> Eff es r) -> Eff es a) -- ^ Continuation with the unlifting function in scope. -> Eff (e : es) a-raiseWith strategy k = case strategy of- SeqUnlift -> unsafeEff $ \ees -> do- es <- tailEnv ees- seqUnliftIO ees $ \unlift -> do+raiseWith strategy k = unsafeEff $ \ees -> do+ es <- tailEnv ees+ case strategy of+ SeqUnlift -> seqUnliftIO ees $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift- ConcUnlift p l -> unsafeEff $ \ees -> do- es <- tailEnv ees- concUnliftIO ees p l $ \unlift -> do+ SeqForkUnlift -> seqForkUnliftIO ees $ \unlift -> do (`unEff` es) $ k $ unsafeEff_ . unlift+ ConcUnlift p l -> concUnliftIO ees p l $ \unlift -> do+ (`unEff` es) $ k $ unsafeEff_ . unlift {-# INLINE raiseWith #-} -- | Eliminate a duplicate effect from the top of the effect stack. subsume :: e :> es => Eff (e : es) a -> Eff es a subsume m = unsafeEff $ \es -> unEff m =<< subsumeEnv es --- | Allow for running an effect stack @xs@ within @es@ as long as @xs@ is a--- permutation (with possible duplicates) of a subset of @es@.+-- | Allow for running an effect stack @subEs@ within @es@ as long as @subEs@ is+-- a permutation (with possible duplicates) of a subset of @es@. -- -- Generalizes 'raise' and 'subsume'. --@@ -476,37 +650,57 @@ -- ... -- ...Couldn't match type ‘es1’ with ‘es2’ -- ...-inject :: Subset xs es => Eff xs a -> Eff es a+inject :: Subset subEs es => Eff subEs a -> Eff es a inject m = unsafeEff $ \es -> unEff m =<< injectEnv es ---------------------------------------- -- Dynamic dispatch -type role LocalEnv nominal nominal+type role LocalEnv nominal -- | Opaque representation of the 'Eff' environment at the point of calling the -- 'send' function, i.e. right before the control is passed to the effect -- handler. ----- The second type variable represents effects of a handler and is needed for--- technical reasons to guarantee soundness (see--- t'Effectful.Dispatch.Dynamic.SharedSuffix' for more information).-newtype LocalEnv (localEs :: [Effect]) (handlerEs :: [Effect]) = LocalEnv (Env localEs)+-- /Note:/ functions that consume it perform runtime checks to ensure that it's+-- used within the scope of the effect handler it belongs to.+newtype LocalEnv (localEs :: [Effect]) = LocalEnv (Env localEs) +-- | Unwrap the 'LocalEnv' via 'requireMatchingStorages'.+unwrapLocalEnv :: HasCallStack => Env es -> LocalEnv localEs -> IO (Env localEs)+unwrapLocalEnv es localEs@(LocalEnv les) = do+ requireMatchingStorages es localEs+ pure les++-- | Make sure that the 'LocalEnv' is used in the thread/context of the effect+-- handler it belongs to.+requireMatchingStorages :: HasCallStack => Env es -> LocalEnv localEs -> IO ()+requireMatchingStorages es (LocalEnv les)+ | es.storage /= les.storage = error+ $ "Env and LocalEnv point to different Storages.\n"+ ++ "If you passed LocalEnv to a different thread/context and tried to "+ ++ "use it there, it's not allowed. You need to use it in the "+ ++ "thread/context of the effect handler."+ | otherwise = pure ()+ -- | Type signature of the effect handler.-type EffectHandler e es+type EffectHandler (e :: Effect) (es :: [Effect]) = forall a localEs. (HasCallStack, e :> localEs)- => LocalEnv localEs es+ => LocalEnv localEs -- ^ Capture of the local environment for handling local 'Eff' computations -- when @e@ is a higher order effect. -> e (Eff localEs) a- -- ^ The effect performed in the local environment.+ -- ^ The operation. -> Eff es a +-- | Wrapper to prevent a space leak on reconstruction of 'Handler' in+-- 'relinkHandler' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).+newtype HandlerImpl e es = HandlerImpl (EffectHandler e es)+ -- | An internal representation of dynamically dispatched effects, i.e. the -- effect handler bundled with its environment. data Handler :: Effect -> Type where- Handler :: !(Env handlerEs) -> !(EffectHandler e handlerEs) -> Handler e+ Handler :: !(Env handlerEs) -> !(HandlerImpl e handlerEs) -> Handler e type instance EffectRep Dynamic = Handler relinkHandler :: Relinker Handler e@@ -515,7 +709,11 @@ pure $ Handler newHandlerEs handler -- | Run a dynamically dispatched effect with the given handler.-runHandler :: DispatchOf e ~ Dynamic => Handler e -> Eff (e : es) a -> Eff es a+runHandler+ :: (HasCallStack, DispatchOf e ~ Dynamic)+ => Handler e+ -> Eff (e : es) a+ -> Eff es a runHandler e m = unsafeEff $ \es0 -> do inlineBracket (consEnv e relinkHandler es0)@@ -529,11 +727,13 @@ -- ^ The operation. -> Eff es a send op = unsafeEff $ \es -> do- Handler handlerEs handler <- getEnv es- -- Prevent internal functions that rebind the effect handler from polluting- -- its call stack by freezing it. Note that functions 'interpret',- -- 'reinterpret', 'interpose' and 'impose' need to thaw it so that useful- -- stack frames from inside the effect handler continue to be added.+ Handler handlerEs (HandlerImpl handler) <- getEnv es+ when (es.storage /= handlerEs.storage) $ do+ error "es and handlerEs point to different Storages"+ -- Prevent the addition of unnecessary 'handler' stack frame to the call+ -- stack. Note that functions 'interpret', 'reinterpret', 'interpose' and+ -- 'impose' need to thaw the call stack so that useful stack frames from+ -- inside the effect handler continue to be added. unEff (withFrozenCallStack handler (LocalEnv es) op) handlerEs {-# NOINLINE send #-} @@ -553,7 +753,7 @@ -- | Run a statically dispatched effect with the given initial representation -- and return the final value along with the final representation. runStaticRep- :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)+ :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) => StaticRep e -- ^ The initial representation. -> Eff (e : es) a -> Eff es (a, StaticRep e)@@ -566,7 +766,7 @@ -- | Run a statically dispatched effect with the given initial representation -- and return the final value, discarding the final representation. evalStaticRep- :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)+ :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) => StaticRep e -- ^ The initial representation. -> Eff (e : es) a -> Eff es a@@ -579,7 +779,7 @@ -- | Run a statically dispatched effect with the given initial representation -- and return the final representation, discarding the final value. execStaticRep- :: (DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es)+ :: (HasCallStack, DispatchOf e ~ Static sideEffects, MaybeIOE sideEffects es) => StaticRep e -- ^ The initial representation. -> Eff (e : es) a -> Eff es (StaticRep e)@@ -590,42 +790,48 @@ (\es -> unEff m es *> getEnv es) -- | Fetch the current representation of the effect.-getStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => Eff es (StaticRep e)+getStaticRep+ :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es)+ => Eff es (StaticRep e) getStaticRep = unsafeEff $ \es -> getEnv es -- | Set the current representation of the effect to the given value.-putStaticRep :: (DispatchOf e ~ Static sideEffects, e :> es) => StaticRep e -> Eff es ()+putStaticRep+ :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es)+ => StaticRep e -> Eff es () putStaticRep s = unsafeEff $ \es -> putEnv es s -- | Apply the function to the current representation of the effect and return a -- value. stateStaticRep- :: (DispatchOf e ~ Static sideEffects, e :> es)+ :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) => (StaticRep e -> (a, StaticRep e)) -- ^ The function to modify the representation. -> Eff es a-stateStaticRep f = unsafeEff $ \es -> stateEnv es (pure . f)+stateStaticRep f = unsafeEff $ \es -> stateEnv es f -- | Apply the monadic function to the current representation of the effect and -- return a value. stateStaticRepM- :: (DispatchOf e ~ Static sideEffects, e :> es)+ :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) => (StaticRep e -> Eff es (a, StaticRep e)) -- ^ The function to modify the representation. -> Eff es a stateStaticRepM f = unsafeEff $ \es -> E.mask $ \unmask -> do- stateEnv es $ unmask . (`unEff` es) . f+ (a, e) <- unmask . (`unEff` es) . f =<< getEnv es+ putEnv es e+ pure a -- | Execute a computation with a temporarily modified representation of the -- effect. localStaticRep- :: (DispatchOf e ~ Static sideEffects, e :> es)+ :: (HasCallStack, DispatchOf e ~ Static sideEffects, e :> es) => (StaticRep e -> StaticRep e) -- ^ The function to temporarily modify the representation. -> Eff es a -> Eff es a localStaticRep f m = unsafeEff $ \es -> do inlineBracket- (stateEnv es $ \s -> pure (s, f s))+ (stateEnv es $ \s -> (s, f s)) (\s -> putEnv es s) (\_ -> unEff m es)
src/Effectful/Internal/Unlift.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE MagicHash #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} -- | Implementation of sequential and concurrent unlifts.@@ -12,13 +13,19 @@ , Limit(..) -- * Unlifting functions- , seqUnlift- , concUnlift+ , ephemeralConcLimitedUnlift+ , ephemeralConcUnlimitedUnlift+ , persistentConcUnlift+ , persistentConcSingleUnlift+ , persistentConcUnlifts+ , persistentConcSingleUnlifts ) where import Control.Concurrent+import Control.Concurrent.MVar.Strict qualified as S import Control.Monad-import Data.IntMap.Strict qualified as IM+import Data.Coerce+import Data.Word import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (mkWeak#, mkWeakNoFinalizer#) import GHC.Generics (Generic)@@ -29,6 +36,7 @@ import Effectful.Internal.Env import Effectful.Internal.Utils+import Effectful.Internal.Utils.Word64Map qualified as M ---------------------------------------- -- Unlift strategies@@ -41,11 +49,59 @@ -- ^ The sequential strategy is the fastest and a default setting for -- t'Effectful.IOE'. Any attempt of calling the unlifting function in threads -- distinct from its creator will result in a runtime error.+ | SeqForkUnlift+ -- ^ Like 'SeqUnlift', but all unlifted actions will be executed in a cloned+ -- environment.+ --+ -- The main consequence is that thread local state is forked at the point of+ -- creation of the unlifting function and its modifications in unlifted+ -- actions will not affect the main thread of execution (and vice versa):+ --+ -- >>> import Effectful+ -- >>> import Effectful.State.Dynamic+ -- >>> :{+ -- action :: (IOE :> es, State Int :> es) => Eff es ()+ -- action = do+ -- modify @Int (+1)+ -- withEffToIO SeqForkUnlift $ \unlift -> unlift $ modify @Int (+2)+ -- modify @Int (+4)+ -- :}+ --+ -- >>> runEff . execStateLocal @Int 0 $ action+ -- 5+ --+ -- >>> runEff . execStateShared @Int 0 $ action+ -- 7+ --+ -- Because of this it's possible to safely use the unlifting function outside+ -- of the scope of effects it captures, e.g. by creating an @IO@ action that+ -- executes effectful operations and running it later:+ --+ -- >>> :{+ -- delayed :: UnliftStrategy -> IO (IO String)+ -- delayed strategy = runEff . evalStateLocal "Hey" $ do+ -- r <- withEffToIO strategy $ \unlift -> pure $ unlift get+ -- modify (++ "!!!")+ -- pure r+ -- :}+ --+ -- This doesn't work with the 'SeqUnlift' strategy because when the returned+ -- action runs, @State@ is no longer in scope:+ --+ -- >>> join $ delayed SeqUnlift+ -- *** Exception: version (...) /= storageVersion (0)+ -- ...+ --+ -- However, it does with the 'SeqForkUnlift' strategy:+ --+ -- >>> join $ delayed SeqForkUnlift+ -- "Hey"+ -- | ConcUnlift !Persistence !Limit -- ^ The concurrent strategy makes it possible for the unlifting function to -- be called in threads distinct from its creator. See 'Persistence' and -- 'Limit' settings for more information.- deriving (Eq, Generic, Ord, Show)+ deriving stock (Eq, Generic, Ord, Show) -- | Persistence setting for the 'ConcUnlift' strategy. --@@ -58,6 +114,78 @@ -- - Lifting 'Control.Concurrent.forkIOWithUnmask' requires the 'Persistent' -- strategy, otherwise the unmasking function would start with a fresh -- environment each time it's called.+--+-- Both cases come down to what happens when the unlifting function is called+-- more than once in the same thread. If a thread calls it only once, the+-- 'Persistence' setting makes no observable difference.+--+-- === Example 1+--+-- Consider a thread that modifies thread local state, then inspects it with a+-- second call to the unlifting function:+--+-- >>> import Control.Concurrent+-- >>> import Control.Monad+-- >>> import Effectful+-- >>> import Effectful.State.Dynamic+--+-- >>> :{+-- modifyThenGet :: UnliftStrategy -> IO Int+-- modifyThenGet strategy = runEff . evalStateLocal @Int 0 $ do+-- withEffToIO strategy $ \unlift -> do+-- result <- newEmptyMVar+-- void . forkIO $ do+-- unlift $ modify @Int (+1)+-- putMVar result =<< unlift (get @Int)+-- takeMVar result+-- :}+--+-- With the 'Persistent' strategy the unlifting function keeps the environment+-- between the calls, so the second call sees the modification from the first+-- one:+--+-- >>> modifyThenGet $ ConcUnlift Persistent (Limited 1)+-- 1+--+-- On the other hand, with 'Ephemeral' each call to the unlifting function+-- starts with a fresh copy of the environment, so the modification is silently+-- lost:+--+-- >>> modifyThenGet $ ConcUnlift Ephemeral (Limited 2)+-- 0+--+-- This also showcases the limit meaning different things for the two settings:+-- for the 'Persistent' strategy it limits the number of threads the unlifting+-- can happen in, for 'Ephemeral' it limits the number of calls to the unlifting+-- function.+--+-- === Example 2+--+-- Consider a situation where a single worker thread runs multiple independent+-- jobs:+--+-- >>> :{+-- twoJobs :: UnliftStrategy -> IO [Int]+-- twoJobs strategy = runEff . evalStateLocal @Int 0 $ do+-- withEffToIO strategy $ \unlift -> do+-- result <- newEmptyMVar+-- void . forkIO $ do+-- let job = unlift $ modify @Int (+1) >> get @Int+-- putMVar result =<< sequence [job, job]+-- takeMVar result+-- :}+--+-- With 'Ephemeral' both jobs start from the environment as it was when the+-- unlifting function was created:+--+-- >>> twoJobs $ ConcUnlift Ephemeral Unlimited+-- [1,1]+--+-- With 'Persistent' the second job inherits changes made by the first one, even+-- though the user would most likely expect them to be independent:+--+-- >>> twoJobs $ ConcUnlift Persistent Unlimited+-- [1,2] data Persistence = Ephemeral -- ^ Don't persist the environment between calls to the unlifting function in@@ -65,7 +193,7 @@ | Persistent -- ^ Persist the environment between calls to the unlifting function within a -- particular thread.- deriving (Eq, Generic, Ord, Show)+ deriving stock (Eq, Generic, Ord, Show) -- | Limit setting for the 'ConcUnlift' strategy. data Limit@@ -84,60 +212,23 @@ -- when called in @N@ threads and @K+1@ copies when called in @K < N@ threads. | Unlimited -- ^ Unlimited use of the unlifting function.- deriving (Eq, Generic, Ord, Show)+ deriving stock (Eq, Generic, Ord, Show) ---------------------------------------- -- Unlift functions --- | Sequential unlift.-seqUnlift- :: HasCallStack- => ((forall r. m r -> IO r) -> IO a)- -> Env es- -> (forall r. m r -> Env es -> IO r)- -> IO a-seqUnlift k es unEff = do- tid0 <- myThreadId- k $ \m -> do- tid <- myThreadId- if tid `eqThreadId` tid0- then unEff m es- else error- $ "If you want to use the unlifting function to run Eff computations "- ++ "in multiple threads, have a look at UnliftStrategy (ConcUnlift)."---- | Concurrent unlift.-concUnlift- :: HasCallStack- => Persistence- -> Limit- -> ((forall r. m r -> IO r) -> IO a)- -> Env es- -> (forall r. m r -> Env es -> IO r)- -> IO a-concUnlift Ephemeral (Limited uses) k =- ephemeralConcUnlift uses k-concUnlift Ephemeral Unlimited k =- ephemeralConcUnlift maxBound k-concUnlift Persistent (Limited threads) k =- persistentConcUnlift False threads k-concUnlift Persistent Unlimited k =- persistentConcUnlift True maxBound k--------------------------------------------- Internal---- | Concurrent unlift that doesn't preserve the environment between calls to--- the unlifting function in threads other than its creator.-ephemeralConcUnlift- :: HasCallStack- => Int+-- | Concurrent unlift with limited uses that doesn't preserve the environment+-- between calls to the unlifting function in threads other than its creator.+--+-- @since 2.7.0.0+ephemeralConcLimitedUnlift+ :: (HasCallStack, forall r. Coercible (effEs r) (Env es -> IO r))+ => Env es+ -> Int -- ^ Number of permitted uses of the unlift function.- -> ((forall r. m r -> IO r) -> IO a)- -> Env es- -> (forall r. m r -> Env es -> IO r)+ -> ((forall r. effEs r -> IO r) -> IO a) -> IO a-ephemeralConcUnlift uses k es0 unEff = do+ephemeralConcLimitedUnlift es0 uses k = do unless (uses > 0) $ do error $ "Invalid number of uses: " ++ show uses tid0 <- myThreadId@@ -145,34 +236,53 @@ -- use. This can't be done from inside the callback as the environment might -- have already changed by then. esTemplate <- cloneEnv es0- mvUses <- newMVar' uses- k $ \m -> do- es <- myThreadId >>= \case- tid | tid0 `eqThreadId` tid -> pure es0- _ -> modifyMVar' mvUses $ \case- 0 -> error- $ "Number of permitted calls (" ++ show uses ++ ") to the unlifting "- ++ "function in other threads was exceeded. Please increase the limit "- ++ "or use the unlimited variant."- 1 -> pure (0, esTemplate)- n -> do- es <- cloneEnv esTemplate- pure (n - 1, es)- unEff m es-{-# NOINLINE ephemeralConcUnlift #-}+ mvUses <- S.newMVar uses+ let getEs = myThreadId >>= \case+ tid | tid0 == tid -> pure es0+ _ -> S.modifyMVar mvUses $ \case+ 0 -> error+ $ "Number of permitted calls (" ++ show uses ++ ") to the unlifting "+ ++ "function in other threads was exceeded. Please increase the limit "+ ++ "or use the unlimited variant."+ 1 -> pure (0, esTemplate)+ n -> do+ es <- cloneEnv esTemplate+ pure (n - 1, es)+ k $ \action -> coerce action =<< getEs+{-# INLINE ephemeralConcLimitedUnlift #-} +-- | Concurrent unlift with unlimited uses that doesn't preserve the environment+-- between calls to the unlifting function in threads other than its creator.+--+-- @since 2.7.0.0+ephemeralConcUnlimitedUnlift+ :: (HasCallStack, forall r. Coercible (effEs r) (Env es -> IO r))+ => Env es+ -> ((forall r. effEs r -> IO r) -> IO a)+ -> IO a+ephemeralConcUnlimitedUnlift es0 k = do+ tid0 <- myThreadId+ -- Create a copy of the environment as a template for the other threads to+ -- use. This can't be done from inside the callback as the environment might+ -- have already changed by then.+ esTemplate <- cloneEnv es0+ let getEs = myThreadId >>= \case+ tid | tid0 == tid -> pure es0+ _ -> cloneEnv esTemplate+ k $ \action -> coerce action =<< getEs+{-# INLINE ephemeralConcUnlimitedUnlift #-}+ -- | Concurrent unlift that preserves the environment between calls to the -- unlifting function within a particular thread. persistentConcUnlift- :: HasCallStack- => Bool+ :: (HasCallStack, forall r. Coercible (effEs r) (Env es -> IO r))+ => Env es+ -> Bool -> Int -- ^ Number of threads that are allowed to use the unlift function.- -> ((forall r. m r -> IO r) -> IO a)- -> Env es- -> (forall r. m r -> Env es -> IO r)+ -> ((forall r. effEs r -> IO r) -> IO a) -> IO a-persistentConcUnlift cleanUp threads k es0 unEff = do+persistentConcUnlift es0 cleanUp threads k = do unless (threads > 0) $ do error $ "Invalid number of threads: " ++ show threads tid0 <- myThreadId@@ -180,139 +290,218 @@ -- use. This can't be done from inside the callback as the environment might -- have already changed by then. esTemplate <- cloneEnv es0- mvEntries <- newMVar' $ ThreadEntries threads IM.empty- k $ \m -> do- es <- myThreadId >>= \case- tid | tid0 `eqThreadId` tid -> pure es0- tid -> modifyMVar' mvEntries $ \te -> do- let wkTid = weakThreadId tid- (mes, i) <- case wkTid `IM.lookup` teEntries te of- Just (ThreadEntry i td) -> (, i) <$> lookupEnv tid td- Nothing -> pure (Nothing, newEntryId)- case mes of- Just es -> pure (te, es)- Nothing -> case teCapacity te of- 0 -> error- $ "Number of other threads (" ++ show threads ++ ") permitted to "- ++ "use the unlifting function was exceeded. Please increase the "- ++ "limit or use the unlimited variant."- 1 -> do- wkTidEs <- mkWeakThreadIdEnv tid esTemplate wkTid i mvEntries cleanUp- let newEntries = ThreadEntries- { teCapacity = teCapacity te - 1- , teEntries = addThreadData wkTid i wkTidEs $ teEntries te- }- pure (newEntries, esTemplate)- _ -> do- es <- cloneEnv esTemplate- wkTidEs <- mkWeakThreadIdEnv tid es wkTid i mvEntries cleanUp- let newEntries = ThreadEntries- { teCapacity = teCapacity te - 1- , teEntries = addThreadData wkTid i wkTidEs $ teEntries te- }- pure (newEntries, es)- unEff m es-{-# NOINLINE persistentConcUnlift #-}--------------------------------------------- Data types+ mvEntries <- S.newMVar $ ThreadEntries threads M.empty+ let getEs = myThreadId >>= \case+ tid | tid0 == tid -> pure es0+ tid -> do+ te0 <- S.readMVar mvEntries+ let wkTid = weakThreadId tid+ case wkTid `M.lookup` te0.entries of+ Just wkEs -> getWkTidEnv wkEs+ -- If the environment is not in the map, there is no point checking+ -- again within modifyMVar below, because this is the only thread+ -- that can put it there.+ Nothing -> S.modifyMVar mvEntries $ \te -> case te.capacity of+ 0 -> noCapacityError threads+ 1 -> do+ wkTidEs <- mkWeakThreadIdEnv tid wkTid esTemplate mvEntries cleanUp+ let newEntries = ThreadEntries+ { capacity = te.capacity - 1+ , entries = M.insert wkTid wkTidEs te.entries+ }+ pure (newEntries, esTemplate)+ _ -> do+ es <- cloneEnv esTemplate+ wkTidEs <- mkWeakThreadIdEnv tid wkTid es mvEntries cleanUp+ let newEntries = ThreadEntries+ { capacity = te.capacity - 1+ , entries = M.insert wkTid wkTidEs te.entries+ }+ pure (newEntries, es)+ k $ \action -> coerce action =<< getEs+{-# INLINE persistentConcUnlift #-} -newtype EntryId = EntryId Int- deriving Eq+-- | Variant of 'persistentConcUnlift' for a single other thread that doesn't+-- need ThreadEntries.+--+-- @since 2.7.0.0+persistentConcSingleUnlift+ :: ( HasCallStack, forall r. Coercible (effEs r) (Env es -> IO r))+ => Env es+ -> ((forall r. effEs r -> IO r) -> IO a)+ -> IO a+persistentConcSingleUnlift es0 k = do+ tid0 <- myThreadId+ -- Create a copy of the environment for the other thread to use. This can't be+ -- done from inside the callback as the environment might have already changed+ -- by then.+ es <- cloneEnv es0+ -- GHC never labels threads as 0.+ mvWeakTid <- S.newMVar 0+ let getEs = myThreadId >>= \case+ tid | tid0 == tid -> pure es0+ tid -> do+ let wkTid = weakThreadId tid+ S.readMVar mvWeakTid >>= \case+ 0 -> S.modifyMVar mvWeakTid $ \case+ 0 -> pure (wkTid, es)+ _ -> noCapacityError 1+ v | v == wkTid -> pure es+ | otherwise -> noCapacityError 1+ k $ \action -> coerce action =<< getEs+{-# INLINE persistentConcSingleUnlift #-} -newEntryId :: EntryId-newEntryId = EntryId 0+-- | Variant of 'persistentConcUnlift' producing two unlifting functions that+-- share the effect storage in each thread.+--+-- @since 2.7.0.0+persistentConcUnlifts+ :: ( HasCallStack+ , forall r. Coercible (effEs r) (Env es -> IO r)+ , forall r. Coercible (effLocalEs r) (Env localEs -> IO r)+ )+ => Env es+ -> Env localEs+ -> Bool+ -> Int+ -- ^ Number of threads that are allowed to use the unlift function.+ -> ((forall r. effEs r -> IO r) -> (forall r. effLocalEs r -> IO r) -> IO a)+ -> IO a+persistentConcUnlifts es0 les0 cleanUp threads k = do+ unless (threads > 0) $ do+ error $ "Invalid number of threads: " ++ show threads+ tid0 <- myThreadId+ -- Create a copy of the environments sharing the effect storage as a template+ -- for the other threads to use. This can't be done from inside the callback+ -- as the environment might have already changed by then.+ storageTemplate <- cloneStorage es0.storage+ esTemplate <- replaceStorage es0 storageTemplate+ lesTemplate <- replaceStorage les0 storageTemplate+ mvEntries <- S.newMVar $ ThreadEntries threads M.empty+ let getEsLes = myThreadId >>= \case+ tid | tid0 == tid -> pure (es0, les0)+ tid -> do+ te0 <- S.readMVar mvEntries+ let wkTid = weakThreadId tid+ case wkTid `M.lookup` te0.entries of+ Just wkEsLes -> getWkTidEnv wkEsLes+ -- If the environments are not in the map, there is no point+ -- checking again within modifyMVar below, because this is the only+ -- thread that can put them there.+ Nothing -> S.modifyMVar mvEntries $ \te -> case te.capacity of+ 0 -> noCapacityError threads+ 1 -> do+ wkTidEsLes <- mkWeakThreadIdEnv tid wkTid (esTemplate, lesTemplate) mvEntries cleanUp+ let newEntries = ThreadEntries+ { capacity = te.capacity - 1+ , entries = M.insert wkTid wkTidEsLes te.entries+ }+ pure (newEntries, (esTemplate, lesTemplate))+ _ -> do+ storage <- cloneStorage storageTemplate+ es <- replaceStorage esTemplate storage+ les <- replaceStorage lesTemplate storage+ wkTidEsLes <- mkWeakThreadIdEnv tid wkTid (es, les) mvEntries cleanUp+ let newEntries = ThreadEntries+ { capacity = te.capacity - 1+ , entries = M.insert wkTid wkTidEsLes te.entries+ }+ pure (newEntries, (es, les))+ k (\action -> coerce action . fst =<< getEsLes)+ (\action -> coerce action . snd =<< getEsLes)+{-# INLINE persistentConcUnlifts #-} -nextEntryId :: EntryId -> EntryId-nextEntryId (EntryId i) = EntryId (i + 1)+-- | Variant of 'persistentConcUnlifts' for a single other thread that doesn't+-- need ThreadEntries.+--+-- @since 2.7.0.0+persistentConcSingleUnlifts+ :: ( HasCallStack+ , forall r. Coercible (effEs r) (Env es -> IO r)+ , forall r. Coercible (effLocalEs r) (Env localEs -> IO r)+ )+ => Env es+ -> Env localEs+ -> ((forall r. effEs r -> IO r) -> (forall r. effLocalEs r -> IO r) -> IO a)+ -> IO a+persistentConcSingleUnlifts es0 les0 k = do+ tid0 <- myThreadId+ -- Create a copy of the environments sharing the effect storage for the other+ -- thread to use. This can't be done from inside the callback as the+ -- environment might have already changed by then.+ storage <- cloneStorage es0.storage+ es <- replaceStorage es0 storage+ les <- replaceStorage les0 storage+ -- GHC never labels threads as 0.+ mvWeakTid <- S.newMVar 0+ let getEsLes = myThreadId >>= \case+ tid | tid0 == tid -> pure (es0, les0)+ tid -> do+ let wkTid = weakThreadId tid+ S.readMVar mvWeakTid >>= \case+ 0 -> S.modifyMVar mvWeakTid $ \case+ 0 -> pure (wkTid, (es, les))+ _ -> noCapacityError 1+ v | v == wkTid -> pure (es, les)+ | otherwise -> noCapacityError 1+ k (\action -> coerce action . fst =<< getEsLes)+ (\action -> coerce action . snd =<< getEsLes)+{-# INLINE persistentConcSingleUnlifts #-} -data ThreadEntries es = ThreadEntries- { teCapacity :: !Int- , teEntries :: !(IM.IntMap (ThreadEntry es))- }+----------------------------------------+-- Internal helpers --- | In GHC < 9 weak thread ids are 32bit long, while ThreadIdS are 64bit long,--- so there is potential for collisions. This is solved by keeping, for a--- particular weak thread id, a list of ThreadIdS with unique EntryIdS.-data ThreadEntry es = ThreadEntry !EntryId !(ThreadData es)+noCapacityError :: HasCallStack => Int -> a+noCapacityError threads = error+ $ "Number of other threads (" ++ show threads ++ ") permitted to "+ ++ "use the unlifting function was exceeded. Please increase the "+ ++ "limit or use the unlimited variant." -data ThreadData es- = ThreadData !EntryId !(Weak (ThreadId, Env es)) (ThreadData es)- | NoThreadData+getWkTidEnv :: HasCallStack => Weak a -> IO a+getWkTidEnv wkTidEnv = deRefWeak wkTidEnv >>= \case+ Nothing -> error "Impossible, thread alive but its weak ref dead"+ Just env -> pure env -------------------------------------------- Weak references to threads+data ThreadEntries a = ThreadEntries+ { capacity :: !Int+ , entries :: !(M.Word64Map (Weak a))+ } mkWeakThreadIdEnv :: ThreadId- -> Env es- -> Int- -> EntryId- -> MVar' (ThreadEntries es)+ -> Word64+ -> a+ -> S.MVar (ThreadEntries a) -> Bool- -> IO (Weak (ThreadId, Env es))-mkWeakThreadIdEnv t@(ThreadId t#) es wkTid i v = \case+ -> IO (Weak a)+mkWeakThreadIdEnv (ThreadId t#) wkTid es v = \case True -> IO $ \s0 ->- case mkWeak# t# (t, es) finalizer s0 of+ case mkWeak# t# es finalizer s0 of (# s1, w #) -> (# s1, Weak w #) False -> IO $ \s0 ->- case mkWeakNoFinalizer# t# (t, es) s0 of+ case mkWeakNoFinalizer# t# es s0 of (# s1, w #) -> (# s1, Weak w #) where- IO finalizer = deleteThreadData wkTid i v--------------------------------------------- Manipulation of ThreadEntries--lookupEnv :: ThreadId -> ThreadData es -> IO (Maybe (Env es))-lookupEnv tid0 = \case- NoThreadData -> pure Nothing- ThreadData _ wkTidEs td -> deRefWeak wkTidEs >>= \case- Nothing -> lookupEnv tid0 td- Just (tid, es)- | tid0 `eqThreadId` tid -> pure $ Just es- | otherwise -> lookupEnv tid0 td--------------------------------------------addThreadData- :: Int- -> EntryId- -> Weak (ThreadId, Env es)- -> IM.IntMap (ThreadEntry es)- -> IM.IntMap (ThreadEntry es)-addThreadData wkTid i w teMap- | i == newEntryId = IM.insert wkTid (newThreadEntry i w) teMap- | otherwise = IM.adjust (consThreadData w) wkTid teMap--newThreadEntry :: EntryId -> Weak (ThreadId, Env es) -> ThreadEntry es-newThreadEntry i w = ThreadEntry (nextEntryId i) $ ThreadData i w NoThreadData--consThreadData :: Weak (ThreadId, Env es) -> ThreadEntry es -> ThreadEntry es-consThreadData w (ThreadEntry i td) =- ThreadEntry (nextEntryId i) $ ThreadData i w td--------------------------------------------deleteThreadData :: Int -> EntryId -> MVar' (ThreadEntries es) -> IO ()-deleteThreadData wkTid i v = modifyMVar_' v $ \te -> do- 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- NoThreadData -> Nothing- td -> Just (ThreadEntry i td)--cleanThreadData :: EntryId -> ThreadData es -> ThreadData es-cleanThreadData i0 = \case- NoThreadData -> NoThreadData- ThreadData i w td- | i0 == i -> td- | otherwise -> ThreadData i w (cleanThreadData i0 td)+ -- The finalizer runs only if the corresponding entry is in the map. It+ -- might not be there for two reasons:+ --+ -- 1. Registration of the thread was interrupted by an asynchronous+ -- exception after the finalizer was attached, but before the update of+ -- the map was committed. The commit was rolled back, so there is+ -- nothing to clean up (and if the thread registered successfully+ -- afterwards, the entry belongs to the finalizer attached then).+ --+ -- 2. The thread registered successfully after one or more interrupted+ -- attempts, so multiple finalizers run on its death and another one+ -- already cleaned up the entry.+ IO finalizer = S.modifyMVar_ v $ \te -> do+ pure $ case M.updateLookupWithKey (\_ _ -> Nothing) wkTid te.entries of+ (Nothing, _) -> te+ (Just _, newEntries) -> ThreadEntries+ { capacity = case te.capacity of+ -- If the template copy of the environment hasn't been consumed+ -- yet, the capacity can be restored.+ 0 -> 0+ n -> n + 1+ , entries = newEntries+ }
src/Effectful/Internal/Utils.hs view
@@ -7,39 +7,26 @@ -- * Utils for 'ThreadId' , weakThreadId- , eqThreadId -- * Utils for 'Any' , Any , toAny , fromAny - -- * Strict 'IORef'- , IORef'- , newIORef'- , readIORef'- , writeIORef'-- -- * Strict 'MVar'- , MVar'- , toMVar'- , newMVar'- , readMVar'- , modifyMVar'- , modifyMVar_'- -- * Unique , Unique , newUnique - -- * CallStack+ -- * CallStack , thawCallStack++ -- * Array capacity+ , growCapacity ) where -import Control.Concurrent.MVar import Control.Exception-import Data.IORef import Data.Primitive.ByteArray+import Data.Word import GHC.Conc.Sync (ThreadId(..)) import GHC.Exts (Any, RealWorld) import GHC.Stack.Types (CallStack(..))@@ -49,13 +36,12 @@ 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 +-- Pretend to depend on containers to silence -Wunused-packages as containers+-- dependency is needed for doctests.+import Data.IntMap.Strict ()+ -- | Version of bracket with an INLINE pragma to work around -- https://gitlab.haskell.org/ghc/ghc/-/issues/22824. inlineBracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c@@ -69,22 +55,15 @@ ---------------------------------------- -- | Get an id of a thread that doesn't prevent its garbage collection.-weakThreadId :: ThreadId -> Int+weakThreadId :: ThreadId -> Word64 #if MIN_VERSION_base(4,19,0)-weakThreadId = fromIntegral . fromThreadId+weakThreadId = fromThreadId #else-weakThreadId (ThreadId t#) = fromIntegral $ rts_getThreadId (threadIdToAddr# t#)+weakThreadId (ThreadId t#) = 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@@ -100,26 +79,6 @@ ---------------------------------------- -#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 @@ -128,49 +87,6 @@ ---------------------------------------- --- | A strict variant of 'IORef'.-newtype IORef' a = IORef' (IORef a)- deriving Eq--newIORef' :: a -> IO (IORef' a)-newIORef' a = a `seq` (IORef' <$> newIORef a)--readIORef' :: IORef' a -> IO a-readIORef' (IORef' var) = readIORef var--writeIORef' :: IORef' a -> a -> IO ()-writeIORef' (IORef' var) a = a `seq` writeIORef var a---------------------------------------------- | A strict variant of 'MVar'.-newtype MVar' a = MVar' (MVar a)- deriving Eq--toMVar' :: MVar a -> IO (MVar' a)-toMVar' var = do- let var' = MVar' var- modifyMVar_' var' pure- pure var'--newMVar' :: a -> IO (MVar' a)-newMVar' a = a `seq` (MVar' <$> newMVar a)--readMVar' :: MVar' a -> IO a-readMVar' (MVar' var) = readMVar var--modifyMVar' :: MVar' a -> (a -> IO (a, r)) -> IO r-modifyMVar' (MVar' var) action = modifyMVar var $ \a0 -> do- (a, r) <- action a0- a `seq` pure (a, r)--modifyMVar_' :: MVar' a -> (a -> IO a) -> IO ()-modifyMVar_' (MVar' var) action = modifyMVar_ var $ \a0 -> do- a <- action a0- a `seq` pure a------------------------------------------- -- | A unique with no possibility for CAS contention. -- -- Credits for this go to Edward Kmett.@@ -184,7 +100,18 @@ ---------------------------------------- +-- | Remove exactly one layer of freezing, i.e. the one added by 'send' and+-- friends via 'withFrozenCallStack'. Freezes applied by client code need to+-- stay intact, so this must not recurse. thawCallStack :: CallStack -> CallStack thawCallStack = \case FreezeCallStack cs -> cs cs -> cs++----------------------------------------++-- | Grow capacity of an array.+--+-- See https://archive.ph/Z2R8w.+growCapacity :: Int -> Int+growCapacity n = 1 + quot (n * 3) 2
+ src/Effectful/Internal/Utils/Word64Map.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE Strict #-}+-- | A minimal, strict map keyed by 'Word64' values (adaptation of+-- 'Data.IntMap.Strict').+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Utils.Word64Map+ ( Word64Map+ , empty+ , lookup+ , insert+ , delete+ , updateLookupWithKey+ ) where++import Data.Bits+import Data.Word+import Prelude hiding (lookup)++-- | A map of 'Word64' keys to values of type @a@.+data Word64Map a+ = Bin Prefix (Word64Map a) (Word64Map a)+ | Tip Word64 a+ | Nil++-- | A @Prefix@ represents some prefix of high-order bits of a @Word64@.+newtype Prefix = Prefix Word64++unPrefix :: Prefix -> Word64+unPrefix (Prefix p) = p++----------------------------------------++-- | The empty map.+empty :: Word64Map a+empty = Nil++-- | Look up the value at a key in the map.+lookup :: Word64 -> Word64Map a -> Maybe a+lookup k = go+ where+ go (Bin p l r) | left k p = go l+ | otherwise = go r+ go (Tip kx x) | k == kx = Just x+ | otherwise = Nothing+ go Nil = Nothing++-- | Insert a new key/value pair in the map. If the key is already present, the+-- associated value is replaced with the supplied one.+--+-- The value is evaluated to WHNF when it is inserted into the map.+insert :: Word64 -> a -> Word64Map a -> Word64Map a+insert k x = go+ where+ go t@(Bin p l r)+ | nomatch k p = linkKey k (Tip k x) p t+ | left k p = Bin p (go l) r+ | otherwise = Bin p l (go r)+ go t@(Tip ky _)+ | k == ky = Tip k x+ | otherwise = link k (Tip k x) ky t+ go Nil = Tip k x++-- | Delete a key and its value from the map. When the key is not a member of+-- the map, the original map is returned.+delete :: Word64 -> Word64Map a -> Word64Map a+delete k = go+ where+ go t@(Bin p l r)+ | nomatch k p = t+ | left k p = binCheckLeft p (go l) r+ | otherwise = binCheckRight p l (go r)+ go t@(Tip ky _)+ | k == ky = Nil+ | otherwise = t+ go Nil = Nil++-- | Look up and update the value at a key in the map. The function returns the+-- original value, if it exists, and the updated map.+--+-- The updated value is evaluated to WHNF when it is inserted into the map.+updateLookupWithKey+ :: (Word64 -> a -> Maybe a)+ -> Word64+ -> Word64Map a+ -> (Maybe a, Word64Map a)+updateLookupWithKey f k = go+ where+ go t@(Bin p l r)+ | nomatch k p = (Nothing, t)+ | left k p = let (found, l') = go l in (found, binCheckLeft p l' r)+ | otherwise = let (found, r') = go r in (found, binCheckRight p l r')+ go t@(Tip ky y)+ | k == ky = case f ky y of+ Just y' -> (Just y, Tip ky y')+ Nothing -> (Just y, Nil)+ | otherwise = (Nothing, t)+ go Nil = (Nothing, Nil)++----------------------------------------+-- Internal helpers++-- | Whether the @Word64@ does not start with the given @Prefix@.+--+-- A @Word64@ starts with a @Prefix@ if it shares the high bits with the+-- internal @Word64@ value of the @Prefix@ up to the mask bit.+--+-- @nomatch@ is usually used to determine whether a key belongs in a @Bin@,+-- since all keys in a @Bin@ share a @Prefix@.+nomatch :: Word64 -> Prefix -> Bool+nomatch i (Prefix p) = (i `xor` p) .&. prefixMask /= 0+ where+ prefixMask = p `xor` (-p)++-- | Whether the @Word64@ is to the left of the split created by a @Bin@ with+-- this @Prefix@.+--+-- This does not imply that the @Word64@ belongs in this @Bin@. That fact is+-- usually determined first using @nomatch@.+left :: Word64 -> Prefix -> Bool+left i p = i < unPrefix p++-- | Link two @Word64Map@s. The maps must not be empty. The @Prefix@es of the+-- two maps must be different. @k1@ must share the prefix of @t1@. @p2@ must be+-- the prefix of @t2@.+linkKey :: Word64 -> Word64Map a -> Prefix -> Word64Map a -> Word64Map a+linkKey k1 t1 p2 t2 = link k1 t1 (unPrefix p2) t2++-- | Link two @Word64Map@s. The maps must not be empty. The @Prefix@es of the+-- two maps must be different. @k1@ must share the prefix of @t1@ and @k2@ must+-- share the prefix of @t2@.+link :: Word64 -> Word64Map a -> Word64 -> Word64Map a -> Word64Map a+link k1 t1 k2 t2 = linkWithMask (branchMask k1 k2) k1 t1 k2 t2++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Word64 -> Word64 -> Word64Map a -> Word64 -> Word64Map a -> Word64Map a+linkWithMask m k1 t1 k2 t2+ | k1 < k2 = Bin p t1 t2+ | otherwise = Bin p t2 t1+ where+ p = Prefix (mask k1 m .|. m)++-- | The prefix of key @i@ up to (but not including) the switching bit @m@.+mask :: Word64 -> Word64 -> Word64+mask i m = i .&. (m `xor` (-m))++-- | The first switching bit where the two prefixes disagree.+--+-- Precondition for defined behavior: p1 /= p2.+branchMask :: Word64 -> Word64 -> Word64+branchMask k1 k2 =+ unsafeShiftL 1 (finiteBitSize (0 :: Word64) - 1 - countLeadingZeros (k1 `xor` k2))++-- | Smart constructor that collapses an empty left subtree.+binCheckLeft :: Prefix -> Word64Map a -> Word64Map a -> Word64Map a+binCheckLeft _ Nil r = r+binCheckLeft p l r = Bin p l r++-- | Smart constructor that collapses an empty right subtree.+binCheckRight :: Prefix -> Word64Map a -> Word64Map a -> Word64Map a+binCheckRight _ l Nil = l+binCheckRight p l r = Bin p l r
src/Effectful/Labeled.hs view
@@ -1,14 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE PolyKinds #-} -- | Labeled effects. --+-- Any effect can be assigned multiple labels so you have more than one+-- available simultaneously.+-- -- @since 2.3.0.0 module Effectful.Labeled- ( -- * Example- -- $example-- -- * Effect- Labeled+ ( -- * Effect+ Labeled(..) -- ** Handlers , runLabeled@@ -22,58 +21,52 @@ import Effectful import Effectful.Dispatch.Static --- $example+-- | Assign a label to an effect. ----- An effect can be assigned multiple labels and you can have all of them--- available at the same time.+-- /Note:/ labeled effects are best used together with the+-- [effectful-plugin](https://hackage.haskell.org/package/effectful-plugin)+-- package, as it significantly improves their usability. ----- >>> import Effectful.Reader.Static+-- The constructor is for sending labeled operations of a dynamically dispatched+-- effect to the handler: --+-- >>> import Effectful.Dispatch.Dynamic+-- -- >>> :{--- action--- :: ( Labeled "a" (Reader String) :> es--- , Labeled "b" (Reader String) :> es--- , Reader String :> es--- )--- => Eff es String--- action = do--- a <- labeled @"b" @(Reader String) $ do--- labeled @"a" @(Reader String) $ do--- ask--- b <- labeled @"b" @(Reader String) $ do--- ask--- pure $ a ++ b+-- data X :: Effect where+-- X :: X m Int+-- type instance DispatchOf X = Dynamic -- :} -- -- >>> :{--- runPureEff @String--- . runLabeled @"a" (runReader "a")--- . runLabeled @"b" (runReader "b")--- . runReader "c"--- $ action+-- runPureEff . runLabeled @"x" (interpret_ $ \X -> pure 333) $ do+-- send $ Labeled @"x" X -- :}--- "ab"---- | Assign a label to an effect.-data Labeled (label :: k) (e :: Effect) :: Effect+-- 333+newtype Labeled (label :: k) (e :: Effect) :: Effect where+ -- | @since 2.4.0.0+ Labeled :: forall label e m a. e m a -> Labeled label e m a -type instance DispatchOf (Labeled label e) = Static NoSideEffects+type instance DispatchOf (Labeled label e) = DispatchOf e data instance StaticRep (Labeled label e) -- | Run a 'Labeled' effect with a given effect handler. runLabeled :: forall label e es a b- . (Eff (e : es) a -> Eff es b)+ . HasCallStack+ => (Eff (e : es) a -> Eff es b) -- ^ The effect handler. -> Eff (Labeled label e : es) a -> Eff es b runLabeled runE m = runE (fromLabeled m) --- | Bring an effect into scope to be able to run its operations.+-- | Bring an effect into scope without a label.+--+-- Useful for running code written with the non-labeled effect in mind. labeled :: forall label e es a- . Labeled label e :> es+ . (HasCallStack, Labeled label e :> es) => Eff (e : es) a -- ^ The action using the effect. -> Eff es a
+ src/Effectful/Labeled/Error.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Error' effect.+--+-- @since 2.4.0.0+module Effectful.Labeled.Error+ ( -- * Effect+ Error(..)++ -- ** Handlers+ , runError+ , runErrorWith+ , runErrorNoCallStack+ , runErrorNoCallStackWith++ -- ** Operations+ , throwErrorWith+ , throwError+ , throwError_+ , rethrowErrorWith+ , rethrowError+ , rethrowError_+ , catchError+ , handleError+ , tryError++ -- * Re-exports+ , Labeled(..)+ , E.HasCallStack+ , E.CallStack+ , E.getCallStack+ , E.prettyCallStack+ ) where++import GHC.Stack (withFrozenCallStack)++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Error.Dynamic (Error(..))+import Effectful.Error.Dynamic qualified as E++-- | Handle errors of type @e@ (via "Effectful.Error.Static").+runError+ :: forall label e es a+ . HasCallStack+ => Eff (Labeled label (Error e) : es) a+ -> Eff es (Either (E.CallStack, e) a)+runError = runLabeled @label E.runError++-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific+-- error handler.+runErrorWith+ :: forall label e es a+ . HasCallStack+ => (E.CallStack -> e -> Eff es a)+ -- ^ The error handler.+ -> Eff (Labeled label (Error e) : es) a+ -> Eff es a+runErrorWith = runLabeled @label . E.runErrorWith++-- | Handle errors of type @e@ (via "Effectful.Error.Static"). In case of an+-- error discard the 'E.CallStack'.+runErrorNoCallStack+ :: forall label e es a+ . HasCallStack+ => Eff (Labeled label (Error e) : es) a+ -> Eff es (Either e a)+runErrorNoCallStack = runLabeled @label E.runErrorNoCallStack++-- | Handle errors of type @e@ (via "Effectful.Error.Static") with a specific+-- error handler. In case of an error discard the 'CallStack'.+runErrorNoCallStackWith+ :: forall label e es a+ . HasCallStack+ => (e -> Eff es a)+ -- ^ The error handler.+ -> Eff (Labeled label (Error e) : es) a+ -> Eff es a+runErrorNoCallStackWith = runLabeled @label . E.runErrorNoCallStackWith++-- | Throw an error of type @e@ and specify a display function in case a+-- third-party code catches the internal exception and 'show's it.+throwErrorWith+ :: forall label e es a+ . (HasCallStack, Labeled label (Error e) :> es)+ => (e -> String)+ -- ^ The display function.+ -> e+ -- ^ The error.+ -> Eff es a+throwErrorWith display =+ withFrozenCallStack send . Labeled @label . ThrowErrorWith display++-- | Throw an error of type @e@ with 'show' as a display function.+throwError+ :: forall label e es a+ . (HasCallStack, Labeled label (Error e) :> es, Show e)+ => e+ -- ^ The error.+ -> Eff es a+throwError = withFrozenCallStack (throwErrorWith @label) show++-- | Throw an error of type @e@ with no display function.+throwError_+ :: forall label e es a+ . (HasCallStack, Labeled label (Error e) :> es)+ => e+ -- ^ The error.+ -> Eff es a+throwError_ = withFrozenCallStack (throwErrorWith @label) (const "<opaque>")++-- | Throw an error of type @e@ with the given 'E.CallStack' and specify a+-- display function in case a third-party code catches the internal exception+-- and 'show's it.+--+-- Useful e.g. when you want to catch an error and rethrow it converted to a+-- different type without losing the original 'E.CallStack'.+--+-- @since 2.7.0.0+rethrowErrorWith+ :: forall label e es a+ . Labeled label (Error e) :> es+ => (e -> String)+ -- ^ The display function.+ -> E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowErrorWith display cs =+ send . Labeled @label . RethrowErrorWith display cs++-- | Throw an error of type @e@ with the given 'E.CallStack' and 'show' as a+-- display function.+--+-- @since 2.7.0.0+rethrowError+ :: forall label e es a+ . (Labeled label (Error e) :> es, Show e)+ => E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError = rethrowErrorWith @label show++-- | Throw an error of type @e@ with the given 'E.CallStack' and no display+-- function.+--+-- @since 2.7.0.0+rethrowError_+ :: forall label e es a+ . Labeled label (Error e) :> es+ => E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError_ = rethrowErrorWith @label (const "<opaque>")++-- | Handle an error of type @e@.+catchError+ :: forall label e es a+ . (HasCallStack, Labeled label (Error e) :> es)+ => Eff es a+ -- ^ The inner computation.+ -> (E.CallStack -> e -> Eff es a)+ -- ^ A handler for errors in the inner computation.+ -> Eff es a+catchError m = send . Labeled @label . CatchError m++-- | The same as @'flip' 'catchError'@, which is useful in situations where the+-- code for the handler is shorter.+handleError+ :: forall label e es a+ . (HasCallStack, Labeled label (Error e) :> es)+ => (E.CallStack -> e -> Eff es a)+ -- ^ A handler for errors in the inner computation.+ -> Eff es a+ -- ^ The inner computation.+ -> Eff es a+handleError = flip (catchError @label)++-- | Similar to 'catchError', but returns an 'Either' result which is a 'Right'+-- if no error was thrown and a 'Left' otherwise.+tryError+ :: forall label e es a+ . (HasCallStack, Labeled label (Error e) :> es)+ => Eff es a+ -- ^ The inner computation.+ -> Eff es (Either (E.CallStack, e) a)+tryError m = catchError @label (Right <$> m) (\es e -> pure $ Left (es, e))
+ src/Effectful/Labeled/Input.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Input' effect.+--+-- @since 2.7.0.0+module Effectful.Labeled.Input+ ( -- * Effect+ Input++ -- ** Handlers+ , runInput+ , runInputAction++ -- ** Operations+ , input+ , inputs++ -- * Re-exports+ , Labeled(..)+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Input.Dynamic (Input(..))+import Effectful.Input.Dynamic qualified as I++-- | Run the 'Input' effect with the given value.+runInput+ :: forall label i es a+ . HasCallStack+ => i+ -- ^ The input value.+ -> Eff (Labeled label (Input i) : es) a+ -> Eff es a+runInput = runLabeled @label . I.runInput++-- | Run the 'Input' effect with the given action that supplies values.+runInputAction+ :: forall label i es a+ . HasCallStack+ => (HasCallStack => Eff es i)+ -- ^ The action for input generation.+ -> Eff (Labeled label (Input i) : es) a+ -> Eff es a+runInputAction = runLabeled @label . I.runInputAction++----------------------------------------+-- Operations++-- | Fetch the value.+input+ :: forall label i es+ . (HasCallStack, Labeled label (Input i) :> es)+ => Eff es i+input = send $ Labeled @label Input++-- | Fetch the result of applying a function to the value.+--+-- @'inputs' f ≡ f '<$>' 'input'@+inputs+ :: forall label i es a+ . (HasCallStack, Labeled label (Input i) :> es)+ => (i -> a) -- ^ The function to apply to the value.+ -> Eff es a+inputs f = f <$> input @label
+ src/Effectful/Labeled/Output.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Output' effect.+--+-- @since 2.7.0.0+module Effectful.Labeled.Output+ ( -- * Effect+ Output(..)++ -- ** Handlers+ , runOutputAction+ , runOutputLocalArray+ , runOutputLocalList+ , runOutputSharedArray+ , runOutputSharedList++ -- ** Operations+ , output++ -- * Re-exports+ , Labeled(..)+ , Array+ ) where++import Data.Primitive.Array++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Output.Dynamic (Output(..))+import Effectful.Output.Dynamic qualified as O++----------------------------------------+-- Handlers++-- | Run the 'Output' effect with the given action for receiving values.+runOutputAction+ :: forall label o es a+ . HasCallStack+ => (HasCallStack => o -> Eff es ())+ -- ^ The action for output generation.+ -> Eff (Labeled label (Output o) : es) a+ -> Eff es a+runOutputAction = runLabeled @label . O.runOutputAction++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array (via "Effectful.Output.Static.Local.Array").+runOutputLocalArray+ :: forall label o es a+ . HasCallStack+ => Eff (Labeled label (Output o) : es) a+ -> Eff es (a, Array o)+runOutputLocalArray = runLabeled @label O.runOutputLocalArray++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list (via "Effectful.Output.Static.Local.List").+runOutputLocalList+ :: forall label o es a+ . HasCallStack+ => Eff (Labeled label (Output o) : es) a+ -> Eff es (a, [o])+runOutputLocalList = runLabeled @label O.runOutputLocalList++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array (via "Effectful.Output.Static.Shared.Array").+runOutputSharedArray+ :: forall label o es a+ . HasCallStack+ => Eff (Labeled label (Output o) : es) a+ -> Eff es (a, Array o)+runOutputSharedArray = runLabeled @label O.runOutputSharedArray++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list (via "Effectful.Output.Static.Shared.List").+runOutputSharedList+ :: forall label o es a+ . HasCallStack+ => Eff (Labeled label (Output o) : es) a+ -> Eff es (a, [o])+runOutputSharedList = runLabeled @label O.runOutputSharedList++----------------------------------------+-- Operations++-- | Feed the value to the underlying handler.+output+ :: forall label o es+ . (HasCallStack, Labeled label (Output o) :> es)+ => o+ -> Eff es ()+output = send . Labeled @label . Output
+ src/Effectful/Labeled/Provider.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Provider' effect.+--+-- @since 2.7.0.0+module Effectful.Labeled.Provider+ ( -- * Effect+ Provider(..)+ , Provider_++ -- ** Handlers+ , runProvider+ , runProvider_++ -- ** Operations+ , provide+ , provide_+ , provideWith+ , provideWith_++ -- * Re-exports+ , Labeled(..)+ ) where++import Data.Coerce+import Data.Functor.Identity++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Provider (Provider(..), Provider_)+import Effectful.Provider qualified as P++-- | Run the labeled 'Provider' effect with a given effect handler.+runProvider+ :: forall label e input f es a+ . HasCallStack+ => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r))+ -- ^ The effect handler.+ -> Eff (Labeled label (Provider e input f) : es) a+ -> Eff es a+runProvider provider = runLabeled @label (P.runProvider provider)++-- | Run the labeled 'Provider' effect with a given effect handler that doesn't+-- change its return type.+runProvider_+ :: forall label e input es a+ . HasCallStack+ => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r)+ -- ^ The effect handler.+ -> Eff (Labeled label (Provider_ e input) : es) a+ -> Eff es a+runProvider_ provider = runLabeled @label (P.runProvider_ provider)++----------------------------------------+-- Operations++-- | Run the effect handler.+provide+ :: forall label e f es a+ . (HasCallStack, Labeled label (Provider e () f) :> es)+ => Eff (e : es) a+ -> Eff es (f a)+provide = send . Labeled @label . P.ProvideWith ()++-- | Run the effect handler with unchanged return type.+provide_+ :: forall label e es a+ . (HasCallStack, Labeled label (Provider_ e ()) :> es)+ => Eff (e : es) a+ -> Eff es a+provide_ = dropIdentity . send . Labeled @label . P.ProvideWith ()++-- | Run the effect handler with a given input.+provideWith+ :: forall label e input f es a+ . (HasCallStack, Labeled label (Provider e input f) :> es)+ => input+ -- ^ The input to the effect handler.+ -> Eff (e : es) a+ -> Eff es (f a)+provideWith input = send . Labeled @label . P.ProvideWith input++-- | Run the effect handler that doesn't change its return type with a given+-- input.+provideWith_+ :: forall label e input es a+ . (HasCallStack, Labeled label (Provider_ e input) :> es)+ => input+ -- ^ The input to the effect handler.+ -> Eff (e : es) a+ -> Eff es a+provideWith_ input = dropIdentity . send . Labeled @label . P.ProvideWith input++----------------------------------------+-- Helpers++dropIdentity :: Eff es (Identity a) -> Eff es a+dropIdentity = coerce
+ src/Effectful/Labeled/Provider/List.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'ProviderList' effect.+--+-- @since 2.7.0.0+module Effectful.Labeled.Provider.List+ ( -- * Effect+ ProviderList(..)+ , ProviderList_++ -- ** Handlers+ , runProviderList+ , runProviderList_++ -- ** Operations+ , provideList+ , provideList_+ , provideListWith+ , provideListWith_++ -- * Re-exports+ , Labeled(..)+ , type (++)+ , KnownSubset+ ) where++import Data.Coerce+import Data.Functor.Identity++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Provider.List (ProviderList(..), ProviderList_, type (++))+import Effectful.Provider.List qualified as P++-- | Run the labeled 'ProviderList' effect with a given handler.+runProviderList+ :: forall label providedEs input f es a+ . (HasCallStack, KnownSubset providedEs (providedEs ++ es))+ => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r))+ -- ^ The handler.+ -> Eff (Labeled label (ProviderList providedEs input f) : es) a+ -> Eff es a+runProviderList provider = runLabeled @label (P.runProviderList provider)++-- | Run the labeled 'ProviderList' effect with a given handler that doesn't+-- change its return type.+runProviderList_+ :: forall label providedEs input es a+ . (HasCallStack, KnownSubset providedEs (providedEs ++ es))+ => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r)+ -- ^ The handler.+ -> Eff (Labeled label (ProviderList_ providedEs input) : es) a+ -> Eff es a+runProviderList_ provider = runLabeled @label (P.runProviderList_ provider)++----------------------------------------+-- Operations++-- | Run the handler.+provideList+ :: forall label providedEs f es a+ . (HasCallStack, Labeled label (ProviderList providedEs () f) :> es)+ => Eff (providedEs ++ es) a+ -> Eff es (f a)+provideList = send . Labeled @label . P.ProvideListWith @providedEs ()++-- | Run the handler with unchanged return type.+provideList_+ :: forall label providedEs es a+ . (HasCallStack, Labeled label (ProviderList_ providedEs ()) :> es)+ => Eff (providedEs ++ es) a+ -> Eff es a+provideList_ = dropIdentity . send . Labeled @label . P.ProvideListWith @providedEs ()++-- | Run the handler with a given input.+provideListWith+ :: forall label providedEs input f es a+ . (HasCallStack, Labeled label (ProviderList providedEs input f) :> es)+ => input+ -- ^ The input to the handler.+ -> Eff (providedEs ++ es) a+ -> Eff es (f a)+provideListWith input = send . Labeled @label . P.ProvideListWith @providedEs input++-- | Run the handler that doesn't change its return type with a given input.+provideListWith_+ :: forall label providedEs input es a+ . (HasCallStack, Labeled label (ProviderList_ providedEs input) :> es)+ => input+ -- ^ The input to the handler.+ -> Eff (providedEs ++ es) a+ -> Eff es a+provideListWith_ input =+ dropIdentity . send . Labeled @label . P.ProvideListWith @providedEs input++----------------------------------------+-- Helpers++dropIdentity :: Eff es (Identity a) -> Eff es a+dropIdentity = coerce
+ src/Effectful/Labeled/Reader.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Reader' effect.+--+-- @since 2.4.0.0+module Effectful.Labeled.Reader+ ( -- * Effect+ Reader(..)++ -- ** Handlers+ , runReader++ -- ** Operations+ , ask+ , asks+ , local++ -- * Re-exports+ , Labeled(..)+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Reader.Dynamic (Reader(..))+import Effectful.Reader.Dynamic qualified as R++-- | Run the 'Reader' effect with the given initial environment (via+-- "Effectful.Reader.Static").+runReader+ :: forall label r es a+ . HasCallStack+ => r+ -- ^ The initial environment.+ -> Eff (Labeled label (Reader r) : es) a+ -> Eff es a+runReader = runLabeled @label . R.runReader++----------------------------------------+-- Operations++-- | Fetch the value of the environment.+ask+ :: forall label r es+ . (HasCallStack, Labeled label (Reader r) :> es)+ => Eff es r+ask = send $ Labeled @label Ask++-- | Retrieve a function of the current environment.+--+-- @'asks' f ≡ f '<$>' 'ask'@+asks+ :: forall label r es a+ . (HasCallStack, Labeled label (Reader r) :> es)+ => (r -> a)+ -- ^ The function to apply to the environment.+ -> Eff es a+asks f = f <$> ask @label++-- | Execute a computation in a modified environment.+--+-- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@+--+local+ :: forall label r es a+ . (HasCallStack, Labeled label (Reader r) :> es)+ => (r -> r)+ -- ^ The function to modify the environment.+ -> Eff es a+ -> Eff es a+local f = send . Labeled @label . Local f
+ src/Effectful/Labeled/ReturnWith.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'ReturnWith' effect.+--+-- @since 2.7.0.0+module Effectful.Labeled.ReturnWith+ ( -- * Effect+ ReturnWith(..)++ -- ** Handlers+ , runReturnWith++ -- ** Operations+ , returnWith++ -- * Re-exports+ , Labeled(..)+ ) where++import GHC.Stack (withFrozenCallStack)++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.ReturnWith.Dynamic (ReturnWith(..))+import Effectful.ReturnWith.Dynamic qualified as R++-- | Run a computation that can return early with a value of type @r@ (via+-- "Effectful.ReturnWith.Static").+runReturnWith+ :: forall label r es+ . HasCallStack+ => Eff (Labeled label (ReturnWith r) : es) r+ -> Eff es r+runReturnWith = runLabeled @label R.runReturnWith++-- | Return early with the given value.+returnWith+ :: forall label r es a+ . (HasCallStack, Labeled label (ReturnWith r) :> es)+ => r+ -- ^ The value.+ -> Eff es a+returnWith = withFrozenCallStack send . Labeled @label . ReturnWith
+ src/Effectful/Labeled/State.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- The deprecated stateM needs to use the deprecated StateM operation until+-- they're removed.+{-# OPTIONS_GHC -Wno-deprecations #-}+-- | Convenience functions for the 'Labeled' 'State' effect.+--+-- @since 2.4.0.0+module Effectful.Labeled.State+ ( -- * Effect+ State(..)++ -- ** Handlers++ -- *** Local+ , runStateLocal+ , evalStateLocal+ , execStateLocal++ -- *** Shared+ , runStateShared+ , evalStateShared+ , execStateShared++ -- ** Operations+ , get+ , gets+ , put+ , state+ , modify+ , stateM+ , modifyM++ -- * Re-exports+ , Labeled(..)+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.State.Dynamic (State(..))+import Effectful.State.Dynamic qualified as S++----------------------------------------+-- Local++-- | Run the 'State' effect with the given initial state and return the final+-- value along with the final state (via "Effectful.State.Static.Local").+runStateLocal+ :: forall label s es a+ . HasCallStack+ => s+ -- ^ The initial state.+ -> Eff (Labeled label (State s) : es) a+ -> Eff es (a, s)+runStateLocal = runLabeled @label . S.runStateLocal++-- | Run the 'State' effect with the given initial state and return the final+-- value, discarding the final state (via "Effectful.State.Static.Local").+evalStateLocal+ :: forall label s es a+ . HasCallStack+ => s+ -- ^ The initial state.+ -> Eff (Labeled label (State s) : es) a+ -> Eff es a+evalStateLocal = runLabeled @label . S.evalStateLocal++-- | Run the 'State' effect with the given initial state and return the final+-- state, discarding the final value (via "Effectful.State.Static.Local").+execStateLocal+ :: forall label s es a+ . HasCallStack+ => s+ -- ^ The initial state.+ -> Eff (Labeled label (State s) : es) a+ -> Eff es s+execStateLocal = runLabeled @label . S.execStateLocal++----------------------------------------+-- Shared++-- | Run the 'State' effect with the given initial state and return the final+-- value along with the final state (via "Effectful.State.Static.Shared").+runStateShared+ :: forall label s es a+ . HasCallStack+ => s+ -- ^ The initial state.+ -> Eff (Labeled label (State s) : es) a+ -> Eff es (a, s)+runStateShared = runLabeled @label . S.runStateShared++-- | Run the 'State' effect with the given initial state and return the final+-- value, discarding the final state (via "Effectful.State.Static.Shared").+evalStateShared+ :: forall label s es a+ . HasCallStack+ => s+ -- ^ The initial state.+ -> Eff (Labeled label (State s) : es) a+ -> Eff es a+evalStateShared = runLabeled @label . S.evalStateShared++-- | Run the 'State' effect with the given initial state and return the final+-- state, discarding the final value (via "Effectful.State.Static.Shared").+execStateShared+ :: forall label s es a+ . HasCallStack+ => s+ -- ^ The initial state.+ -> Eff (Labeled label (State s) : es) a+ -> Eff es s+execStateShared = runLabeled @label . S.execStateShared++----------------------------------------+-- Operations++-- | Fetch the current value of the state.+get+ :: forall label s es+ . (HasCallStack, Labeled label (State s) :> es)+ => Eff es s+get = send $ Labeled @label Get++-- | Get a function of the current state.+--+-- @'gets' f ≡ f '<$>' 'get'@+gets+ :: forall label s es a+ . (HasCallStack, Labeled label (State s) :> es)+ => (s -> a)+ -- ^ .+ -> Eff es a+gets f = f <$> get @label++-- | Set the current state to the given value.+put+ :: forall label s es+ . (HasCallStack, Labeled label (State s) :> es)+ => s+ -- ^ .+ -> Eff es ()+put = send . Labeled @label . Put++-- | Apply the function to the current state and return a value.+state+ :: forall label s es a+ . (HasCallStack, Labeled label (State s) :> es)+ => (s -> (a, s))+ -- ^ .+ -> Eff es a+state = send . Labeled @label . State++-- | Apply the function to the current state.+--+-- @'modify' f ≡ 'state' (\\s -> ((), f s))@+modify+ :: forall label s es+ . (HasCallStack, Labeled label (State s) :> es)+ => (s -> s)+ -- ^ .+ -> Eff es ()+modify f = state @label (\s -> ((), f s))++-- | Apply the monadic function to the current state and return a value.+stateM+ :: forall label s es a+ . (HasCallStack, Labeled label (State s) :> es)+ => (s -> Eff es (a, s))+ -- ^ .+ -> Eff es a+stateM = send . Labeled @label . StateM++-- | Apply the monadic function to the current state.+--+-- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@+modifyM+ :: forall label s es+ . (HasCallStack, Labeled label (State s) :> es)+ => (s -> Eff es s)+ -- ^ .+ -> Eff es ()+modifyM f = stateM @label (\s -> ((), ) <$> f s)++{-# DEPRECATED stateM, modifyM+ "Use a combination of get and put instead." #-}
+ src/Effectful/Labeled/Writer.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Writer' effect.+--+-- @since 2.4.0.0+module Effectful.Labeled.Writer+ ( -- * Effect+ Writer(..)++ -- ** Handlers++ -- *** Local+ , runWriterLocal+ , execWriterLocal++ -- *** Shared+ , runWriterShared+ , execWriterShared++ -- * Operations+ , tell+ , listen+ , listens++ -- * Re-exports+ , Labeled(..)+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Writer.Dynamic (Writer(..))+import Effectful.Writer.Dynamic qualified as W++----------------------------------------+-- Local++-- | Run the 'Writer' effect and return the final value along with the final+-- output (via "Effectful.Writer.Static.Local").+runWriterLocal+ :: forall label w es a+ . (HasCallStack, Monoid w)+ => Eff (Labeled label (Writer w) : es)+ a -> Eff es (a, w)+runWriterLocal = runLabeled @label W.runWriterLocal++-- | Run a 'Writer' effect and return the final output, discarding the final+-- value (via "Effectful.Writer.Static.Local").+execWriterLocal+ :: forall label w es a+ . (HasCallStack, Monoid w)+ => Eff (Labeled label (Writer w) : es) a+ -> Eff es w+execWriterLocal = runLabeled @label W.execWriterLocal++----------------------------------------+-- Shared++-- | Run the 'Writer' effect and return the final value along with the final+-- output (via "Effectful.Writer.Static.Shared").+runWriterShared+ :: forall label w es a+ . (HasCallStack, Monoid w)+ => Eff (Labeled label (Writer w) : es) a+ -> Eff es (a, w)+runWriterShared = runLabeled @label W.runWriterShared++-- | Run the 'Writer' effect and return the final output, discarding the final+-- value (via "Effectful.Writer.Static.Shared").+execWriterShared+ :: forall label w es a+ . (HasCallStack, Monoid w)+ => Eff (Labeled label (Writer w) : es) a+ -> Eff es w+execWriterShared = runLabeled @label W.execWriterShared++----------------------------------------+-- Operations++-- | Append the given output to the overall output of the 'Writer'.+tell+ :: forall label w es+ . (HasCallStack, Labeled label (Writer w) :> es)+ => w+ -> Eff es ()+tell = send . Labeled @label . Tell++-- | Execute an action and append its output to the overall output of the+-- 'Writer'.+listen+ :: forall label w es a+ . (HasCallStack, Labeled label (Writer w) :> es)+ => Eff es a+ -> Eff es (a, w)+listen = send . Labeled @label . Listen++-- | Execute an action and append its output to the overall output of the+-- 'Writer', then return the final value along with a function of the recorded+-- output.+--+-- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@+listens+ :: forall label w es a b+ . (HasCallStack, Labeled label (Writer w) :> es)+ => (w -> b)+ -> Eff es a+ -> Eff es (a, b)+listens f m = do+ (a, w) <- listen @label m+ pure (a, f w)
src/Effectful/NonDet.hs view
@@ -1,5 +1,9 @@ -- | Provider of the t'Control.Applicative.Alternative' and -- t'Control.Monad.MonadPlus' instance for 'Eff'.+--+-- /Note:/ the 'NonDet' effect uses the t'Effectful.Error.Static.Error' effect+-- underneath, so caveats described in "Effectful.Error.Static" (in particular+-- the interaction with threads) apply. module Effectful.NonDet ( -- * Effect NonDet(..)@@ -8,8 +12,9 @@ -- ** Handlers , runNonDet - -- * Utils+ -- * Operations , emptyEff+ , plusEff , sumEff -- * Re-exports@@ -21,28 +26,42 @@ ) where import Control.Applicative-import Data.Coerce 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.Monad (LocalEnv(..), NonDet(..))+import Effectful.Internal.Env qualified as I+import Effectful.Internal.Monad (NonDet(..)) -- | Policy of dealing with modifications to __thread local__ state in the -- environment in branches that end up calling the 'Empty' operation. ----- /Note:/ 'OnEmptyKeep' is significantly faster as there is no need to back up--- the environment on each call to ':<|>:'.+-- /Note:/ 'OnEmptyKeep' is faster as there is no need to back up the+-- environment on each call to ':<|>:'. -- -- @since 2.2.0.0 data OnEmptyPolicy- = OnEmptyKeep -- ^ Keep modifications on 'Empty'.- | OnEmptyRollback -- ^ Rollback modifications on 'Empty'.- deriving (Eq, Generic, Ord, Show)+ = OnEmptyKeep+ -- ^ Keep modifications on 'Empty'.+ | OnEmptyRollback+ -- ^ Rollback modifications on 'Empty'.+ --+ -- The rollback applies to the thread local state of __all__ effects, in+ -- particular ones handled outside of 'runNonDet':+ --+ -- >>> import Effectful.State.Static.Local+ -- >>> :{+ -- runPureEff . runState @Int 0 . runNonDet OnEmptyRollback $+ -- (modify @Int (+1) >> emptyEff) <|> get @Int+ -- :}+ -- (Right 0,0)+ --+ -- /Note:/ state modifications are rolled back on 'Empty' only. In particular,+ -- they are __not__ rolled back on exceptions.+ deriving stock (Eq, Generic, Ord, Show) -- | Run the 'NonDet' effect with a given 'OnEmptyPolicy'. --@@ -50,33 +69,52 @@ -- computation calls 'Empty'. -- -- @since 2.2.0.0-runNonDet :: OnEmptyPolicy -> Eff (NonDet : es) a -> Eff es (Either CallStack a)+runNonDet+ :: HasCallStack+ => OnEmptyPolicy+ -> Eff (NonDet : es) a+ -> Eff es (Either CallStack a) runNonDet = \case OnEmptyKeep -> runNonDetKeep OnEmptyRollback -> runNonDetRollback -runNonDetKeep :: Eff (NonDet : es) a -> Eff es (Either CallStack a)-runNonDetKeep = reinterpret (fmap noError . runError @()) $ \env -> \case- Empty -> throwError ()+runNonDetKeep+ :: HasCallStack+ => Eff (NonDet : es) a+ -> Eff es (Either CallStack a)+runNonDetKeep = reinterpret (fmap noError . runError @ErrorEmpty) $ \env -> \case+ Empty -> throwError ErrorEmpty m1 :<|>: m2 -> localSeqUnlift env $ \unlift -> do- mr <- (Just <$> unlift m1) `catchError` \_ () -> pure Nothing+ mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> pure Nothing case mr of Just r -> pure r Nothing -> unlift m2 -runNonDetRollback :: Eff (NonDet : es) a -> Eff es (Either CallStack a)-runNonDetRollback = reinterpret (fmap noError . runError @()) $ \env -> \case- Empty -> throwError ()+runNonDetRollback+ :: HasCallStack+ => Eff (NonDet : es) a+ -> Eff es (Either CallStack a)+runNonDetRollback = reinterpret setup $ \env -> \case+ Empty -> throwError ErrorEmpty m1 :<|>: m2 -> do- backupEnv <- cloneLocalEnv env+ backupData <- unsafeEff I.backupStorageData localSeqUnlift env $ \unlift -> do- mr <- (Just <$> unlift m1) `catchError` \_ () -> do- -- If m1 failed, roll back the environment.- restoreLocalEnv env backupEnv+ mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> do+ -- If m1 failed, restore the data.+ unsafeEff $ I.restoreStorageData backupData pure Nothing case mr of Just r -> pure r Nothing -> unlift m2+ where+ setup action = do+ backupData <- unsafeEff I.backupStorageData+ runError @ErrorEmpty action >>= \case+ Right r -> pure $ Right r+ Left (cs, _) -> do+ -- If the whole action failed, restore the data.+ unsafeEff $ I.restoreStorageData backupData+ pure $ Left cs ---------------------------------------- @@ -85,28 +123,31 @@ -- -- @since 2.2.0.0 emptyEff :: (HasCallStack, NonDet :> es) => Eff es a-emptyEff = withFrozenCallStack $ send Empty+emptyEff = withFrozenCallStack send Empty +-- | Specialized version of '<|>' with the `HasCallStack` constraint for+-- tracking purposes.+--+-- @since 2.5.0.0+plusEff :: (HasCallStack, NonDet :> es) => Eff es a -> Eff es a -> Eff es a+plusEff m1 m2 = send (m1 :<|>: m2)+infixl 3 `plusEff` -- same as <|>+ -- | Specialized version of 'asum' with the 'HasCallStack' constraint for -- tracking purposes. -- -- @since 2.2.0.0 sumEff :: (HasCallStack, Foldable t, NonDet :> es) => t (Eff es a) -> Eff es a-sumEff = foldr (<|>) emptyEff+sumEff = foldr plusEff emptyEff ---------------------------------------- -- Internal helpers +-- | Internal error type for the Empty action. Better than '()' in case it+-- escapes the scope of 'runNonDet' and shows up in error messages.+data ErrorEmpty = ErrorEmpty+instance Show ErrorEmpty where+ show ErrorEmpty = "Effectful.NonDet.ErrorEmpty"+ noError :: Either (cs, e) a -> Either cs a noError = either (Left . fst) Right--cloneLocalEnv- :: LocalEnv localEs handlerEs- -> Eff es (LocalEnv localEs handlerEs)-cloneLocalEnv = coerce . unsafeEff_ . cloneEnv . coerce--restoreLocalEnv- :: LocalEnv localEs handlerEs- -> LocalEnv localEs handlerEs- -> Eff es ()-restoreLocalEnv dest src = unsafeEff_ $ restoreEnv (coerce dest) (coerce src)
+ src/Effectful/Output/Dynamic.hs view
@@ -0,0 +1,86 @@+-- | The dynamically dispatched variant of the 'Output' effect.+--+-- /Note:/ unless you plan to change interpretations at runtime, it's+-- recommended to use one of the statically dispatched variants,+-- i.e. "Effectful.Output.Static.Action", "Effectful.Output.Static.Local.Array",+-- "Effectful.Output.Static.Local.List", "Effectful.Output.Static.Shared.Array"+-- or "Effectful.Output.Static.Shared.List".+--+-- @since 2.7.0.0+module Effectful.Output.Dynamic+ ( -- * Effect+ Output(..)++ -- ** Handlers+ , runOutputAction+ , runOutputLocalArray+ , runOutputLocalList+ , runOutputSharedArray+ , runOutputSharedList++ -- ** Operations+ , output+ ) where++import Data.Primitive.Array++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Output.Static.Local.Array qualified as LA+import Effectful.Output.Static.Local.List qualified as LL+import Effectful.Output.Static.Shared.Array qualified as SA+import Effectful.Output.Static.Shared.List qualified as SL++-- | Provide the ability to feed values of type @o@ to a handler.+data Output o :: Effect where+ Output :: o -> Output o m ()++type instance DispatchOf (Output o) = Dynamic++----------------------------------------+-- Handlers++-- | Run the 'Output' effect with the given action for receiving values.+runOutputAction+ :: forall o es a+ . HasCallStack+ => (HasCallStack => o -> Eff es ())+ -- ^ The action for output generation.+ -> Eff (Output o : es) a+ -> Eff es a+runOutputAction outputAction = interpret_ $ \case+ Output o -> outputAction $! o++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array (via "Effectful.Output.Static.Local.Array").+runOutputLocalArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)+runOutputLocalArray = reinterpret_ LA.runOutput $ \case+ Output o -> LA.output o++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list (via "Effectful.Output.Static.Local.List").+runOutputLocalList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])+runOutputLocalList = reinterpret_ LL.runOutput $ \case+ Output o -> LL.output o++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array (via "Effectful.Output.Static.Shared.Array").+runOutputSharedArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)+runOutputSharedArray = reinterpret_ SA.runOutput $ \case+ Output o -> SA.output o++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list (via "Effectful.Output.Static.Shared.List").+runOutputSharedList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])+runOutputSharedList = reinterpret_ SL.runOutput $ \case+ Output o -> SL.output o++----------------------------------------+-- Operations++-- | Feed the value to the underlying handler.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output = send . Output
+ src/Effectful/Output/Static/Action.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ImplicitParams #-}+-- | Support for feeding values of a particular type to a monadic action.+--+-- @since 2.7.0.0+module Effectful.Output.Static.Action+ ( -- * Effect+ Output++ -- ** Handlers+ , runOutput++ -- ** Operations+ , output+ ) where++import Data.Kind+import GHC.Stack++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils++-- | Provide the ability to feed values of type @o@ to a monadic action.+data Output (o :: Type) :: Effect++type instance DispatchOf (Output o) = Static NoSideEffects++-- | Wrapper to prevent a space leak on reconstruction of 'Output' in+-- 'relinkOutput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).+newtype OutputImpl o es where+ OutputImpl :: (HasCallStack => o -> Eff es ()) -> OutputImpl o es++data instance StaticRep (Output o) where+ Output+ :: !(Env actionEs)+ -> !(OutputImpl o actionEs)+ -> StaticRep (Output o)++-- | Run the 'Output' effect with the given action for receiving values.+runOutput+ :: forall o es a+ . HasCallStack+ => (HasCallStack => o -> Eff es ())+ -- ^ The action for receiving values.+ -> Eff (Output o : es) a+ -> Eff es a+runOutput outputAction action = unsafeEff $ \es -> do+ inlineBracket+ (consEnv (Output es outputImpl) relinkOutput es)+ unconsEnv+ (unEff action)+ where+ outputImpl = OutputImpl $ let ?callStack = thawCallStack ?callStack in outputAction++-- | Feed the value to the underlying monadic action.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output !o = unsafeEff $ \es -> do+ Output actionEs (OutputImpl outputAction) <- getEnv es+ -- Corresponds to thawCallStack in runOutput.+ (`unEff` actionEs) $ withFrozenCallStack outputAction o++----------------------------------------+-- Helpers++relinkOutput :: Relinker StaticRep (Output o)+relinkOutput = Relinker $ \relink (Output actionEs outputAction) -> do+ newActionEs <- relink actionEs+ pure $ Output newActionEs outputAction
+ src/Effectful/Output/Static/Local/Array.hs view
@@ -0,0 +1,79 @@+-- | Support for accumulation of values in a thread local array.+--+-- @since 2.7.0.0+module Effectful.Output.Static.Local.Array+ ( -- * Effect+ Output++ -- ** Handlers+ , runOutput++ -- ** Operations+ , output++ -- * Re-exports+ , Array+ ) where++import Control.Monad.Primitive+import Data.Kind+import Data.Primitive.Array++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils++-- | Provide access to accumulation of values of type @o@ in a thread local+-- array.+data Output (o :: Type) :: Effect++type instance DispatchOf (Output o) = Static NoSideEffects+data instance StaticRep (Output o) = Output !Int !(MutableArray RealWorld o)++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array.+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)+runOutput = runOutputImpl $ \(Output size arr) -> do+ freezeArray arr 0 size++-- | Append the value to the end of the array.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output !o = unsafeEff $ \es -> do+ Output size arr0 <- getEnv es+ let len0 = sizeofMutableArray arr0+ arr <- case size `compare` len0 of+ GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"+ LT -> pure arr0+ EQ -> do+ let len = growCapacity len0+ arr <- newArray len undefinedValue+ copyMutableArray arr 0 arr0 0 size+ pure arr+ writeArray arr size o+ putEnv es $ Output (size + 1) arr++----------------------------------------+-- Helpers++runOutputImpl+ :: HasCallStack+ => (StaticRep (Output o) -> IO acc)+ -> Eff (Output o : es) a+ -> Eff es (a, acc)+runOutputImpl f action = unsafeEff $ \es0 -> do+ arr <- newArray 0 undefinedValue+ inlineBracket+ (consEnv (Output 0 arr) relinkOutput es0)+ unconsEnv+ (\es -> (,) <$> unEff action es <*> (f =<< getEnv es))+ where+ relinkOutput = Relinker $ \_ (Output size arr0) -> do+ arr <- cloneMutableArray arr0 0 (sizeofMutableArray arr0)+ pure $ Output size arr++undefinedValue :: HasCallStack => a+undefinedValue = error "Undefined value"
+ src/Effectful/Output/Static/Local/List.hs view
@@ -0,0 +1,39 @@+-- | Support for accumulation of values in a thread local list.+--+-- @since 2.7.0.0+module Effectful.Output.Static.Local.List+ ( -- * Effect+ Output++ -- ** Handlers+ , runOutput++ -- ** Operations+ , output+ ) where++import Data.Kind++import Effectful+import Effectful.Dispatch.Static++-- | Provide access to accumulation of values of type @o@ in a thread local+-- list.+data Output (o :: Type) :: Effect++type instance DispatchOf (Output o) = Static NoSideEffects+newtype instance StaticRep (Output o) = Output [o]++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list.+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])+runOutput action = do+ (a, Output acc) <- runStaticRep (Output []) action+ pure (a, reverse acc)++-- | Append the value to the end of the list.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output !o = stateStaticRep $ \(Output acc) -> ((), Output (o : acc))
@@ -0,0 +1,77 @@+-- | Support for accumulation of values in a shared array.+--+-- @since 2.7.0.0+module Effectful.Output.Static.Shared.Array+ ( -- * Effect+ Output++ -- ** Handlers+ , runOutput++ -- ** Operations+ , output++ -- * Re-exports+ , Array+ ) where++import Control.Concurrent.MVar.Strict qualified as S+import Control.Monad.Primitive+import Data.Kind+import Data.Primitive.Array++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils++-- | Provide access to accumulation of values of type @o@ in a shared array.+data Output (o :: Type) :: Effect++data OutputData o = OutputData !Int !(MutableArray RealWorld o)++type instance DispatchOf (Output o) = Static NoSideEffects+newtype instance StaticRep (Output o) = Output (S.MVar (OutputData o))++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array.+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)+runOutput = runOutputImpl $ \(OutputData size arr) -> do+ freezeArray arr 0 size++-- | Append the value to the end of the array.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output !o = unsafeEff $ \es -> do+ Output v <- getEnv es+ S.modifyMVar_ v $ \(OutputData size arr0) -> do+ let len0 = sizeofMutableArray arr0+ arr <- case size `compare` len0 of+ GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"+ LT -> pure arr0+ EQ -> do+ let len = growCapacity len0+ arr <- newArray len undefinedValue+ copyMutableArray arr 0 arr0 0 size+ pure arr+ writeArray arr size o+ pure $ OutputData (size + 1) arr++----------------------------------------+-- Helpers++runOutputImpl+ :: HasCallStack+ => (OutputData o -> IO acc)+ -> Eff (Output o : es) a+ -> Eff es (a, acc)+runOutputImpl f action = do+ v <- unsafeEff_ $ S.newMVar . OutputData 0 =<< newArray 0 undefinedValue+ a <- evalStaticRep (Output v) action+ acc <- unsafeEff_ $ f =<< S.readMVar v+ pure (a, acc)++undefinedValue :: HasCallStack => a+undefinedValue = error "Undefined value"
@@ -0,0 +1,43 @@+-- | Support for accumulation of values in a shared list.+--+-- @since 2.7.0.0+module Effectful.Output.Static.Shared.List+ ( -- * Effect+ Output++ -- ** Handlers+ , runOutput++ -- ** Operations+ , output+ ) where++import Control.Concurrent.MVar.Strict qualified as S+import Data.Kind++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive++-- | Provide access to accumulation of values of type @o@ in a shared list.+data Output (o :: Type) :: Effect++type instance DispatchOf (Output o) = Static NoSideEffects+newtype instance StaticRep (Output o) = Output (S.MVar [o])++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list.+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])+runOutput action = do+ v <- unsafeEff_ $ S.newMVar []+ a <- evalStaticRep (Output v) action+ (a, ) . reverse <$> unsafeEff_ (S.readMVar v)++-- | Append the value to the end of the list.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output !o = unsafeEff $ \es -> do+ Output v <- getEnv es+ S.modifyMVar_ v $ \acc -> pure (o : acc)
src/Effectful/Provider.hs view
@@ -6,7 +6,7 @@ -- $example -- * Effect- Provider+ Provider(..) , Provider_ -- ** Handlers@@ -20,24 +20,20 @@ , 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+import Effectful.Dispatch.Dynamic -- $example -- -- >>> import Control.Monad.IO.Class+-- >>> import Data.Map.Strict qualified as M -- >>> import Effectful.Dispatch.Dynamic -- >>> import Effectful.State.Static.Local--- >>> import qualified Data.Map.Strict as M -- -- Given an effect: --@@ -74,7 +70,7 @@ -- => FilePath -- -> Eff (Write : es) a -- -> Eff es a--- runWriteIO fp = interpret $ \_ -> \case+-- runWriteIO fp = interpret_ $ \case -- Write msg -> liftIO . putStrLn $ fp ++ ": " ++ msg -- :} --@@ -84,7 +80,7 @@ -- => FilePath -- -> Eff (Write : es) a -- -> Eff es a--- runWritePure fp = interpret $ \_ -> \case+-- runWritePure fp = interpret_ $ \case -- Write msg -> modify $ M.insertWith (++) fp [msg] -- :} --@@ -108,93 +104,105 @@ -- $ action -- :} -- fromList [("in.txt",["hi","there"]),("out.txt",["good","bye"])]+--+-- Moreover, operations of the 'Provider' effect can be intercepted with+-- 'interpose', e.g. to adjust the input of the effect handler:+--+-- >>> :{+-- adjustPaths+-- :: Provider_ Write FilePath :> es+-- => Eff es a+-- -> Eff es a+-- adjustPaths = interpose @(Provider_ Write FilePath) $ \env -> \case+-- ProvideWith fp action -> do+-- passthrough env $ ProvideWith ("logs/" ++ fp) action+-- :}+--+-- >>> :{+-- runEff+-- . runProvider_ runWriteIO+-- . adjustPaths+-- $ action+-- :}+-- logs/in.txt: hi+-- logs/in.txt: there+-- logs/out.txt: good+-- logs/out.txt: bye -- | Provide a way to run a handler of @e@ with a given @input@. -- -- /Note:/ @f@ can be used to alter the return type of the effect handler. If -- that's unnecessary, use 'Provider_'.-data Provider (e :: Effect) (input :: Type) (f :: Type -> Type) :: Effect+data Provider (e :: Effect) (input :: Type) (f :: Type -> Type) :: Effect where+ -- | Run the effect handler with a given input.+ --+ -- @since 2.7.0.0+ ProvideWith :: input -> Eff (e : es) a -> Provider e input f (Eff es) (f a) -- | A restricted variant of 'Provider' with unchanged return type of the effect -- handler. type Provider_ e input = Provider e input Identity -type instance DispatchOf (Provider e input f) = Static NoSideEffects--data instance StaticRep (Provider e input f) where- Provider :: !(Env handlerEs)- -> !(forall r. input -> Eff (e : handlerEs) r -> Eff handlerEs (f r))- -> StaticRep (Provider e input f)+type instance DispatchOf (Provider e input f) = Dynamic -- | Run the 'Provider' effect with a given effect handler. runProvider- :: (forall r. input -> Eff (e : es) r -> Eff es (f r))+ :: forall e input f es a+ . HasCallStack+ => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r)) -- ^ The effect handler. -> Eff (Provider e input f : es) a -> Eff es a-runProvider run m = unsafeEff $ \es0 -> do- inlineBracket- (consEnv (Provider es0 run) relinkProvider es0)- unconsEnv- (\es -> unEff m es)+runProvider provider = interpret $ \env -> \case+ ProvideWith input action -> provider input $ do+ localSeqUnlift env $ \unlift -> do+ localSeqLend @'[e] env $ \lend -> do+ unlift . lend $ action -- | Run the 'Provider' effect with a given effect handler that doesn't change -- its return type. runProvider_- :: (forall r. input -> Eff (e : es) r -> Eff es r)+ :: forall e input es a+ . HasCallStack+ => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r) -- ^ The effect handler. -> Eff (Provider_ e input : es) a -> Eff es a-runProvider_ run = runProvider $ \input -> coerce . run input+runProvider_ provider = interpret $ \env -> \case+ ProvideWith input action -> provider input $ do+ localSeqUnlift env $ \unlift -> do+ localSeqLend @'[e] env $ \lend -> do+ unlift . lend $ coerce action -- | Run the effect handler.-provide :: Provider e () f :> es => Eff (e : es) a -> Eff es (f a)-provide = provideWith ()+provide :: (HasCallStack, Provider e () f :> es) => Eff (e : es) a -> Eff es (f a)+provide = send . ProvideWith () -- | Run the effect handler with unchanged return type.-provide_ :: Provider_ e () :> es => Eff (e : es) a -> Eff es a-provide_ = provideWith_ ()+provide_ :: (HasCallStack, Provider_ e () :> es) => Eff (e : es) a -> Eff es a+provide_ = dropIdentity . send . ProvideWith () -- | Run the effect handler with a given input. provideWith- :: Provider e input f :> es+ :: (HasCallStack, Provider e input f :> es) => input -- ^ The input to the effect handler. -> Eff (e : es) a -> Eff es (f a)-provideWith input action = unsafeEff $ \es -> do- Provider handlerEs run <- getEnv es- (`unEff` handlerEs) . run input . unsafeEff $ \eHandlerEs -> do- unEff action =<< copyRef eHandlerEs es+provideWith input = send . ProvideWith input -- | Run the effect handler that doesn't change its return type with a given -- input. provideWith_- :: Provider_ e input :> es+ :: (HasCallStack, Provider_ e input :> es) => input -- ^ The input to the effect handler. -> Eff (e : es) a -> Eff es a-provideWith_ input = adapt . provideWith input- where- adapt :: Eff es (Identity a) -> Eff es a- adapt = coerce+provideWith_ input = dropIdentity . send . ProvideWith input ---------------------------------------- -- Helpers -relinkProvider :: Relinker StaticRep (Provider e input f)-relinkProvider = Relinker $ \relink (Provider handlerEs run) -> do- newHandlerEs <- relink handlerEs- pure $ Provider newHandlerEs run--copyRef :: Env (e : handlerEs) -> Env es -> IO (Env (e : es))-copyRef (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do- when (hstorage /= storage) $ do- error "storages do not match"- let size = sizeofPrimArray refs0 - offset- mrefs <- newPrimArray (size + 2)- copyPrimArray mrefs 0 hrefs hoffset 2- copyPrimArray mrefs 2 refs0 offset size- refs <- unsafeFreezePrimArray mrefs- pure $ Env 0 refs storage+dropIdentity :: Eff es (Identity a) -> Eff es a+dropIdentity = coerce
src/Effectful/Provider/List.hs view
@@ -6,7 +6,7 @@ -- @since 2.3.1.0 module Effectful.Provider.List ( -- * Effect- ProviderList+ ProviderList(..) , ProviderList_ -- ** Handlers@@ -21,126 +21,105 @@ -- * Misc , type (++)- , KnownEffects+ , KnownSubset ) 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.Dispatch.Dynamic import Effectful.Internal.Effect-import Effectful.Internal.Env (Env(..))-import Effectful.Internal.Utils --- | Provide a way to run a handler of multiple @effects@ with a given @input@.+-- | Provide a way to run a handler of multiple @providedEs@ with a given+-- @input@. -- -- /Note:/ @f@ can be used to alter the return type of the handler. If that's -- unnecessary, use 'ProviderList_'.-data ProviderList (effects :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect+data ProviderList (providedEs :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect where+ -- | Run the effect handlers with a given input.+ --+ -- @since 2.7.0.0+ ProvideListWith+ :: forall providedEs input f es a+ . input+ -> Eff (providedEs ++ es) a+ -> ProviderList providedEs input f (Eff es) (f a) -- | A restricted variant of 'ProviderList' with unchanged return type of the -- handler.-type ProviderList_ effs input = ProviderList effs input Identity--type instance DispatchOf (ProviderList effs input f) = Static NoSideEffects+type ProviderList_ providedEs input = ProviderList providedEs input Identity -data instance StaticRep (ProviderList effs input f) where- ProviderList- :: KnownEffects effs- => !(Env handlerEs)- -> !(forall r. input -> Eff (effs ++ handlerEs) r -> Eff handlerEs (f r))- -> StaticRep (ProviderList effs input f)+type instance DispatchOf (ProviderList providedEs input f) = Dynamic -- | Run the 'ProviderList' effect with a given handler. runProviderList- :: KnownEffects effs- => (forall r. input -> Eff (effs ++ es) r -> Eff es (f r))+ :: forall providedEs input f es a+ . (HasCallStack, KnownSubset providedEs (providedEs ++ es))+ => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r)) -- ^ The handler.- -> Eff (ProviderList effs input f : es) a+ -> Eff (ProviderList providedEs input f : es) a -> Eff es a-runProviderList run m = unsafeEff $ \es0 -> do- inlineBracket- (consEnv (ProviderList es0 run) relinkProviderList es0)- unconsEnv- (\es -> unEff m es)+runProviderList provider = interpret $ \env -> \case+ ProvideListWith input action -> provider input $ do+ localSeqUnlift env $ \unlift -> do+ localSeqLend @providedEs env $ \lend -> do+ unlift . lend $ action --- | Run the 'Provider' effect with a given handler that doesn't change its+-- | Run the 'ProviderList' effect with a given handler that doesn't change its -- return type. runProviderList_- :: KnownEffects effs- => (forall r. input -> Eff (effs ++ es) r -> Eff es r)+ :: forall providedEs input es a+ . (HasCallStack, KnownSubset providedEs (providedEs ++ es))+ => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r) -- ^ The handler.- -> Eff (ProviderList_ effs input : es) a+ -> Eff (ProviderList_ providedEs input : es) a -> Eff es a-runProviderList_ run = runProviderList $ \input -> coerce . run input+runProviderList_ provider = interpret $ \env -> \case+ ProvideListWith input action -> provider input $ do+ localSeqUnlift env $ \unlift -> do+ localSeqLend @providedEs env $ \lend -> do+ unlift . lend $ coerce action -- | Run the handler. provideList- :: forall effs f es a- . ProviderList effs () f :> es- => Eff (effs ++ es) a+ :: forall providedEs f es a+ . (HasCallStack, ProviderList providedEs () f :> es)+ => Eff (providedEs ++ es) a -> Eff es (f a)-provideList = provideListWith @effs ()+provideList = send . ProvideListWith @providedEs () -- | Run the handler with unchanged return type. provideList_- :: forall effs es a- . ProviderList_ effs () :> es- => Eff (effs ++ es) a+ :: forall providedEs es a+ . (HasCallStack, ProviderList_ providedEs () :> es)+ => Eff (providedEs ++ es) a -> Eff es a-provideList_ = provideListWith_ @effs ()+provideList_ = dropIdentity . send . ProvideListWith @providedEs () -- | Run the handler with a given input. provideListWith- :: forall effs input f es a- . ProviderList effs input f :> es+ :: forall providedEs input f es a+ . (HasCallStack, ProviderList providedEs input f :> es) => input -- ^ The input to the handler.- -> Eff (effs ++ es) a+ -> Eff (providedEs ++ es) a -> Eff es (f a)-provideListWith input action = unsafeEff $ \es -> do- ProviderList (handlerEs :: Env handlerEs) run <- getEnv @(ProviderList effs input f) es- (`unEff` handlerEs) . run input . unsafeEff $ \eHandlerEs -> do- unEff action =<< copyRefs @effs @handlerEs eHandlerEs es+provideListWith input = send . ProvideListWith @providedEs input -- | Run the handler that doesn't change its return type with a given input. provideListWith_- :: forall effs input es a- . ProviderList_ effs input :> es+ :: forall providedEs input es a+ . (HasCallStack, ProviderList_ providedEs input :> es) => input -- ^ The input to the handler.- -> Eff (effs ++ es) a+ -> Eff (providedEs ++ es) a -> Eff es a-provideListWith_ input = adapt . provideListWith @effs input- where- adapt :: Eff es (Identity a) -> Eff es a- adapt = coerce+provideListWith_ input = dropIdentity . send . ProvideListWith @providedEs input ---------------------------------------- -- Helpers -relinkProviderList :: Relinker StaticRep (ProviderList e input f)-relinkProviderList = Relinker $ \relink (ProviderList handlerEs run) -> do- newHandlerEs <- relink handlerEs- pure $ ProviderList newHandlerEs run--copyRefs- :: forall effs handlerEs es- . KnownEffects effs- => Env (effs ++ handlerEs)- -> Env es- -> IO (Env (effs ++ es))-copyRefs (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do- when (hstorage /= storage) $ do- error "storages do not match"- let size = sizeofPrimArray refs0 - offset- effsSize = 2 * knownEffectsLength @effs- mrefs <- newPrimArray (size + effsSize)- copyPrimArray mrefs 0 hrefs hoffset effsSize- copyPrimArray mrefs effsSize refs0 offset size- refs <- unsafeFreezePrimArray mrefs- pure $ Env 0 refs storage+dropIdentity :: Eff es (Identity a) -> Eff es a+dropIdentity = coerce
src/Effectful/Reader/Dynamic.hs view
@@ -1,7 +1,8 @@ -- | The dynamically dispatched variant of the 'Reader' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use the statically dispatched variant,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.Reader.MonadReader' instance for compatibility with existing+-- code, it's recommended to use the statically dispatched variant, -- i.e. "Effectful.Reader.Static". module Effectful.Reader.Dynamic ( -- * Effect@@ -19,29 +20,28 @@ import Effectful import Effectful.Dispatch.Dynamic-import Effectful.Reader.Static qualified as R--data Reader r :: Effect where- Ask :: Reader r m r- Local :: (r -> r) -> m a -> Reader r m a--type instance DispatchOf (Reader r) = Dynamic+import Effectful.Internal.Effect.Dynamic (Reader(..)) --- | Run the 'Reader' effect with the given initial environment (via--- "Effectful.Reader.Static").+-- | Run the 'Reader' effect with the given initial environment. runReader- :: r -- ^ The initial environment.+ :: HasCallStack+ => r -- ^ The initial environment. -> Eff (Reader r : es) a -> Eff es a-runReader r = reinterpret (R.runReader r) $ \env -> \case- Ask -> R.ask- Local f m -> localSeqUnlift env $ \unlift -> R.local f (unlift m)+runReader r0 = interpret $ handler r0+ where+ handler :: r -> EffectHandler (Reader r) es+ handler r env = \case+ Ask -> pure r+ Local f action -> localSeqUnlift env $ \unlift -> do+ unlift $ interpose (handler $ f r) action -- | Execute a computation in a modified environment. -- -- @since 1.1.0.0 withReader- :: (r1 -> r2)+ :: HasCallStack+ => (r1 -> r2) -- ^ The function to modify the environment. -> Eff (Reader r2 : es) a -- ^ Computation to run in the modified environment.@@ -49,6 +49,7 @@ withReader f m = do r <- ask raise $ runReader (f r) m+{-# DEPRECATED withReader "withReader doesn't work correctly for all potential interpreters" #-} ---------------------------------------- -- Operations
src/Effectful/Reader/Static.hs view
@@ -1,4 +1,8 @@ -- | Support for access to a read only value of a particular type.+--+-- /Note:/ strictly speaking the value is not read only because of 'local'. If+-- you want to ensure that the initial value never changes, use+-- "Effectful.Input.Static". module Effectful.Reader.Static ( -- * Effect Reader@@ -13,19 +17,22 @@ , local ) where +import Data.Kind+ import Effectful import Effectful.Dispatch.Static -- | Provide access to a strict (WHNF), thread local, read only value of type -- @r@.-data Reader r :: Effect+data Reader (r :: Type) :: Effect type instance DispatchOf (Reader r) = Static NoSideEffects newtype instance StaticRep (Reader r) = Reader r -- | Run a 'Reader' effect with the given initial environment. runReader- :: r -- ^ The initial environment.+ :: HasCallStack+ => r -- ^ The initial environment. -> Eff (Reader r : es) a -> Eff es a runReader r = evalStaticRep (Reader r)@@ -34,7 +41,8 @@ -- -- @since 1.1.0.0 withReader- :: (r1 -> r2)+ :: HasCallStack+ => (r1 -> r2) -- ^ The function to modify the environment. -> Eff (Reader r2 : es) a -- ^ Computation to run in the modified environment.@@ -44,7 +52,7 @@ raise $ runReader (f r) m -- | Fetch the value of the environment.-ask :: Reader r :> es => Eff es r+ask :: (HasCallStack, Reader r :> es) => Eff es r ask = do Reader r <- getStaticRep pure r@@ -53,7 +61,7 @@ -- -- @'asks' f ≡ f '<$>' 'ask'@ asks- :: Reader r :> es+ :: (HasCallStack, Reader r :> es) => (r -> a) -- ^ The function to apply to the environment. -> Eff es a asks f = f <$> ask@@ -63,7 +71,7 @@ -- @'runReader' r ('local' f m) ≡ 'runReader' (f r) m@ -- local- :: Reader r :> es+ :: (HasCallStack, Reader r :> es) => (r -> r) -- ^ The function to modify the environment. -> Eff es a -> Eff es a
+ src/Effectful/ReturnWith/Dynamic.hs view
@@ -0,0 +1,49 @@+-- | The dynamically dispatched variant of the 'ReturnWith' effect.+--+-- /Note:/ unless you plan to change interpretations at runtime, it's+-- recommended to use the statically dispatched variant,+-- i.e. "Effectful.ReturnWith.Static".+--+-- All caveats described in "Effectful.ReturnWith.Static" (in particular the+-- interaction with threads) apply.+--+-- @since 2.7.0.0+module Effectful.ReturnWith.Dynamic+ ( -- * Effect+ ReturnWith(..)++ -- ** Handlers+ , runReturnWith++ -- ** Operations+ , returnWith+ ) where++import GHC.Stack (withFrozenCallStack)++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.ReturnWith.Static qualified as R++-- | Provide the ability to return early with a value of type @r@.+data ReturnWith r :: Effect where+ ReturnWith :: r -> ReturnWith r m a++type instance DispatchOf (ReturnWith r) = Dynamic++-- | Run a computation that can return early with a value of type @r@ (via+-- "Effectful.ReturnWith.Static").+runReturnWith+ :: HasCallStack+ => Eff (ReturnWith r : es) r+ -> Eff es r+runReturnWith = reinterpret_ R.runReturnWith $ \case+ ReturnWith r -> R.returnWith r++-- | Return early with the given value.+returnWith+ :: (HasCallStack, ReturnWith r :> es)+ => r+ -- ^ The value.+ -> Eff es a+returnWith = withFrozenCallStack send . ReturnWith
+ src/Effectful/ReturnWith/Static.hs view
@@ -0,0 +1,112 @@+-- | Support for early return from a computation.+--+-- >>> import Control.Monad (when)+--+-- >>> :{+-- classify :: ReturnWith String :> es => Int -> Eff es String+-- classify n = do+-- when (n < 0) $ returnWith "negative"+-- when (n == 0) $ returnWith "zero"+-- pure "positive"+-- :}+--+-- >>> runEff . runReturnWith $ classify 5+-- "positive"+--+-- >>> runEff . runReturnWith $ classify (-5)+-- "negative"+--+-- === Interaction with threads+--+-- The 'ReturnWith' effect uses runtime exceptions underneath, so the usual+-- rules apply. In particular, in multi-threaded code a call to 'returnWith' in+-- a child thread will not automatically propagate to the parent. If you need+-- that, use functions such as @withAsync@ from the+-- [Effectful.Concurrent.Async](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent-Async.html)+-- module of the @effectful@ package (which propagate exceptions from child+-- threads to their parents) or arrange the propagation yourself.+--+-- For more information see the documentation of the+-- [Concurrent](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent.html#t:Concurrent)+-- effect.+--+-- @since 2.7.0.0+module Effectful.ReturnWith.Static+ ( -- * Effect+ ReturnWith++ -- ** Handlers+ , runReturnWith++ -- ** Operations+ , returnWith+ ) where++import Data.Kind+import GHC.Stack++import Effectful+import Effectful.Dispatch.Static+import Effectful.Exception+import Effectful.Internal.Utils++-- | Provide the ability to return early with a value of type @r@.+data ReturnWith (r :: Type) :: Effect++type instance DispatchOf (ReturnWith r) = Static NoSideEffects+newtype instance StaticRep (ReturnWith r) = ReturnWith ReturnWithId++-- | Run a computation that can return early with a value of type @r@.+runReturnWith+ :: forall r es+ . HasCallStack+ => Eff (ReturnWith r : es) r+ -> Eff es r+runReturnWith action = do+ rid <- unsafeEff_ newReturnWithId+ evalStaticRep (ReturnWith @r rid) $ do+ catchJust (matchReturnWith rid) action pure++-- | Return early with the given value.+returnWith+ :: forall r es a. (HasCallStack, ReturnWith r :> es)+ => r+ -- ^ The value.+ -> Eff es a+returnWith r = do+ ReturnWith rid <- getStaticRep @(ReturnWith r)+ withFrozenCallStack throwIO $ ReturnWithWrapper rid callStack (toAny r)++----------------------------------------+-- Helpers++newtype ReturnWithId = ReturnWithId Unique+ deriving newtype Eq++-- | A unique is picked so that distinct 'ReturnWith' handlers for the same+-- type don't catch each other's values.+newReturnWithId :: IO ReturnWithId+newReturnWithId = ReturnWithId <$> newUnique++data ReturnWithWrapper = ReturnWithWrapper !ReturnWithId CallStack Any++instance Show ReturnWithWrapper where+ showsPrec p (ReturnWithWrapper _ cs _)+ = showParen (p > 10)+ $ ("Effectful.ReturnWith.Static.ReturnWithWrapper\n" ++)+ . (prettyCallStack cs ++)+ . ("\n\nIf you see this message, most likely a call to returnWith " ++)+ . ("escaped the scope of its handler, e.g. by being made from a thread " ++)+ . ("that outlived it, or was caught by an overly zealous exception " ++)+ . ("handler. For more information see the documentation of the " ++)+ . ("Effectful.ReturnWith.Static module." ++)++instance Exception ReturnWithWrapper where+ -- See discussion in https://github.com/haskell-effectful/effectful/pull/232.+ toException = asyncExceptionToException+ fromException = asyncExceptionFromException++matchReturnWith :: ReturnWithId -> ReturnWithWrapper -> Maybe r+matchReturnWith rid (ReturnWithWrapper rtag _ r)+ | rid == rtag = Just (fromAny r)+ | otherwise = Nothing
src/Effectful/State/Dynamic.hs view
@@ -1,7 +1,11 @@+-- The handlers need to interpret the deprecated StateM operation until it's+-- removed.+{-# OPTIONS_GHC -Wno-deprecations #-} -- | The dynamically dispatched variant of the 'State' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use one of the statically dispatched variants,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.State.MonadState' instance for compatibility with existing+-- code, it's recommended to use one of the statically dispatched variants, -- i.e. "Effectful.State.Static.Local" or "Effectful.State.Static.Shared". module Effectful.State.Dynamic ( -- * Effect@@ -31,41 +35,29 @@ import Effectful import Effectful.Dispatch.Dynamic+import Effectful.Internal.Effect.Dynamic (State(..)) import Effectful.State.Static.Local qualified as L import Effectful.State.Static.Shared qualified as S --- | Provide access to a mutable value of type @s@.-data State s :: Effect where- Get :: State s m s- Put :: s -> State s m ()- State :: (s -> (a, s)) -> State s m a- StateM :: (s -> m (a, s)) -> State s m a--type instance DispatchOf (State s) = Dynamic- ---------------------------------------- -- Local -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state (via "Effectful.State.Static.Local").-runStateLocal :: s -> Eff (State s : es) a -> Eff es (a, s)+runStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runStateLocal s0 = reinterpret (L.runState s0) localState -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state (via "Effectful.State.Static.Local").-evalStateLocal :: s -> Eff (State s : es) a -> Eff es a+evalStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalStateLocal s0 = reinterpret (L.evalState s0) localState -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value (via "Effectful.State.Static.Local").-execStateLocal :: s -> Eff (State s : es) a -> Eff es s+execStateLocal :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execStateLocal s0 = reinterpret (L.execState s0) localState -localState- :: L.State s :> es- => LocalEnv localEs es- -> State s (Eff localEs) a- -> Eff es a+localState :: L.State s :> es => EffectHandler (State s) es localState env = \case Get -> L.get Put s -> L.put s@@ -77,24 +69,20 @@ -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state (via "Effectful.State.Static.Shared").-runStateShared :: s -> Eff (State s : es) a -> Eff es (a, s)+runStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runStateShared s0 = reinterpret (S.runState s0) sharedState -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state (via "Effectful.State.Static.Shared").-evalStateShared :: s -> Eff (State s : es) a -> Eff es a+evalStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalStateShared s0 = reinterpret (S.evalState s0) sharedState -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value (via "Effectful.State.Static.Shared").-execStateShared :: s -> Eff (State s : es) a -> Eff es s+execStateShared :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execStateShared s0 = reinterpret (S.execState s0) sharedState -sharedState- :: S.State s :> es- => LocalEnv localEs es- -> State s (Eff localEs) a- -> Eff es a+sharedState :: S.State s :> es => EffectHandler (State s) es sharedState env = \case Get -> S.get Put s -> S.put s@@ -157,3 +145,6 @@ => (s -> Eff es s) -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s)++{-# DEPRECATED stateM, modifyM+ "Use a combination of get and put instead." #-}
src/Effectful/State/Static/Local.hs view
@@ -7,7 +7,9 @@ -- the @transformers@ library, the 'State' effect doesn't discard state updates -- when an exception is received: ----- >>> import qualified Control.Monad.Trans.State.Strict as S+-- >>> import Control.Exception (ErrorCall)+-- >>> import Control.Monad.Catch+-- >>> import Control.Monad.Trans.State.Strict qualified as S -- -- >>> :{ -- (`S.execStateT` "Hi") . handle (\(_::ErrorCall) -> pure ()) $ do@@ -41,11 +43,13 @@ , modifyM ) where +import Data.Kind+ import Effectful import Effectful.Dispatch.Static -- | Provide access to a strict (WHNF), thread local, mutable value of type @s@.-data State s :: Effect+data State (s :: Type) :: Effect type instance DispatchOf (State s) = Static NoSideEffects newtype instance StaticRep (State s) = State s@@ -53,7 +57,8 @@ -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state. runState- :: s -- ^ The initial state.+ :: HasCallStack+ => s -- ^ The initial state. -> Eff (State s : es) a -> Eff es (a, s) runState s0 m = do@@ -63,7 +68,8 @@ -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state. evalState- :: s -- ^ The initial state.+ :: HasCallStack+ => s -- ^ The initial state. -> Eff (State s : es) a -> Eff es a evalState s = evalStaticRep (State s)@@ -71,7 +77,8 @@ -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value. execState- :: s -- ^ The initial state.+ :: HasCallStack+ => s -- ^ The initial state. -> Eff (State s : es) a -> Eff es s execState s0 m = do@@ -79,7 +86,7 @@ pure s -- | Fetch the current value of the state.-get :: State s :> es => Eff es s+get :: (HasCallStack, State s :> es) => Eff es s get = do State s <- getStaticRep pure s@@ -88,18 +95,18 @@ -- -- @'gets' f ≡ f '<$>' 'get'@ gets- :: State s :> es+ :: (HasCallStack, State s :> es) => (s -> a) -- ^ The function to apply to the state. -> Eff es a gets f = f <$> get -- | Set the current state to the given value.-put :: State s :> es => s -> Eff es ()+put :: (HasCallStack, State s :> es) => s -> Eff es () put s = putStaticRep (State s) -- | Apply the function to the current state and return a value. state- :: State s :> es+ :: (HasCallStack, State s :> es) => (s -> (a, s)) -- ^ The function to modify the state. -> Eff es a state f = stateStaticRep $ \(State s0) -> let (a, s) = f s0 in (a, State s)@@ -108,14 +115,14 @@ -- -- @'modify' f ≡ 'state' (\\s -> ((), f s))@ modify- :: State s :> es+ :: (HasCallStack, State s :> es) => (s -> s) -- ^ The function to modify the state. -> Eff es () modify f = state $ \s -> ((), f s) -- | Apply the monadic function to the current state and return a value. stateM- :: State s :> es+ :: (HasCallStack, State s :> es) => (s -> Eff es (a, s)) -- ^ The function to modify the state. -> Eff es a stateM f = stateStaticRepM $ \(State s0) -> do@@ -126,11 +133,10 @@ -- -- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ modifyM- :: State s :> es+ :: (HasCallStack, State s :> es) => (s -> Eff es s) -- ^ The monadic function to modify the state. -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s) --- $setup--- >>> import Control.Exception (ErrorCall)--- >>> import Control.Monad.Catch+{-# DEPRECATED stateM, modifyM+ "State modifications made via operations of the same State effect within the callback are discarded. Use a combination of get and put instead." #-}
@@ -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,106 +47,105 @@ , modifyM ) where -import Control.Concurrent.MVar+import Control.Concurrent.MVar.Strict qualified as S+import Data.Kind import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive-import Effectful.Internal.Utils -- | Provide access to a strict (WHNF), shared, mutable value of type @s@.-data State s :: Effect+data State (s :: Type) :: Effect type instance DispatchOf (State s) = Static NoSideEffects-newtype instance StaticRep (State s) = State (MVar' s)+newtype instance StaticRep (State s) = State (S.MVar s) -- | Run the 'State' effect with the given initial state and return the final -- value along with the final state.-runState :: s -> Eff (State s : es) a -> Eff es (a, s)+runState :: HasCallStack => s -> Eff (State s : es) a -> Eff es (a, s) runState s m = do- v <- unsafeEff_ $ newMVar' s+ v <- unsafeEff_ $ S.newMVar s a <- evalStaticRep (State v) m- (a, ) <$> unsafeEff_ (readMVar' v)+ (a, ) <$> unsafeEff_ (S.readMVar v) -- | Run the 'State' effect with the given initial state and return the final -- value, discarding the final state.-evalState :: s -> Eff (State s : es) a -> Eff es a+evalState :: HasCallStack => s -> Eff (State s : es) a -> Eff es a evalState s m = do- v <- unsafeEff_ $ newMVar' s+ v <- unsafeEff_ $ S.newMVar s evalStaticRep (State v) m -- | Run the 'State' effect with the given initial state and return the final -- state, discarding the final value.-execState :: s -> Eff (State s : es) a -> Eff es s+execState :: HasCallStack => s -> Eff (State s : es) a -> Eff es s execState s m = do- v <- unsafeEff_ $ newMVar' s+ v <- unsafeEff_ $ S.newMVar s _ <- evalStaticRep (State v) m- unsafeEff_ $ readMVar' v+ unsafeEff_ $ S.readMVar v --- | Run the 'State' effect with the given initial state 'MVar' and return the+-- | Run the 'State' effect with the given initial state 'S.MVar' and return the -- final value along with the final state.-runStateMVar :: MVar s -> Eff (State s : es) a -> Eff es (a, s)+runStateMVar :: HasCallStack => S.MVar s -> Eff (State s : es) a -> Eff es (a, s) runStateMVar v m = do- v' <- unsafeEff_ $ toMVar' v- a <- evalStaticRep (State v') m- (a, ) <$> unsafeEff_ (readMVar v)+ a <- evalStaticRep (State v) m+ (a, ) <$> unsafeEff_ (S.readMVar v) --- | Run the 'State' effect with the given initial state 'MVar' and return the+-- | Run the 'State' effect with the given initial state 'S.MVar' and return the -- final value, discarding the final state.-evalStateMVar :: MVar s -> Eff (State s : es) a -> Eff es a-evalStateMVar v m = do- v' <- unsafeEff_ $ toMVar' v- evalStaticRep (State v') m+evalStateMVar :: HasCallStack => S.MVar s -> Eff (State s : es) a -> Eff es a+evalStateMVar v = evalStaticRep (State v) --- | Run the 'State' effect with the given initial state 'MVar' and return the+-- | Run the 'State' effect with the given initial state 'S.MVar' and return the -- final state, discarding the final value.-execStateMVar :: MVar s -> Eff (State s : es) a -> Eff es s+execStateMVar :: HasCallStack => S.MVar s -> Eff (State s : es) a -> Eff es s execStateMVar v m = do- v' <- unsafeEff_ $ toMVar' v- _ <- evalStaticRep (State v') m- unsafeEff_ $ readMVar v+ _ <- evalStaticRep (State v) m+ unsafeEff_ $ S.readMVar v +{-# DEPRECATED runStateMVar, evalStateMVar, execStateMVar+ "If you need access to the state from outside of the State effect, manage an explicit MVar yourself." #-}+ -- | Fetch the current value of the state.-get :: State s :> es => Eff es s+get :: (HasCallStack, State s :> es) => Eff es s get = unsafeEff $ \es -> do State v <- getEnv es- readMVar' v+ S.readMVar v -- | Get a function of the current state. -- -- @'gets' f ≡ f '<$>' 'get'@-gets :: State s :> es => (s -> a) -> Eff es a+gets :: (HasCallStack, State s :> es) => (s -> a) -> Eff es a gets f = f <$> get -- | Set the current state to the given value.-put :: State s :> es => s -> Eff es ()+put :: (HasCallStack, State s :> es) => s -> Eff es () put s = unsafeEff $ \es -> do State v <- getEnv es- modifyMVar_' v $ \_ -> pure s+ S.modifyMVar_ v $ \_ -> pure s -- | Apply the function to the current state and return a value. -- -- /Note:/ this function gets an exclusive access to the state for its duration.-state :: State s :> es => (s -> (a, s)) -> Eff es a+state :: (HasCallStack, State s :> es) => (s -> (a, s)) -> Eff es a state f = unsafeEff $ \es -> do State v <- getEnv es- modifyMVar' v $ \s0 -> let (a, s) = f s0 in pure (s, a)+ S.modifyMVar v $ \s0 -> let (a, s) = f s0 in pure (s, a) -- | Apply the function to the current state. -- -- @'modify' f ≡ 'state' (\\s -> ((), f s))@ -- -- /Note:/ this function gets an exclusive access to the state for its duration.-modify :: State s :> es => (s -> s) -> Eff es ()+modify :: (HasCallStack, State s :> es) => (s -> s) -> Eff es () modify f = state (\s -> ((), f s)) -- | Apply the monadic function to the current state and return a value. -- -- /Note:/ this function gets an exclusive access to the state for its duration.-stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a+stateM :: (HasCallStack, State s :> es) => (s -> Eff es (a, s)) -> Eff es a stateM f = unsafeEff $ \es -> do State v <- getEnv es- modifyMVar' v $ \s0 -> do+ S.modifyMVar v $ \s0 -> do (a, s) <- unEff (f s0) es pure (s, a) @@ -153,9 +154,8 @@ -- @'modifyM' f ≡ 'stateM' (\\s -> ((), ) '<$>' f s)@ -- -- /Note:/ this function gets an exclusive access to the state for its duration.-modifyM :: State s :> es => (s -> Eff es s) -> Eff es ()+modifyM :: (HasCallStack, State s :> es) => (s -> Eff es s) -> Eff es () modifyM f = stateM (\s -> ((), ) <$> f s) --- $setup--- >>> import Control.Exception (ErrorCall)--- >>> import Control.Monad.Catch+{-# DEPRECATED stateM, modifyM+ "Operations of the same State effect used within the callback deadlock. Use a combination of get and put instead, or an explicit MVar if you need atomic updates." #-}
src/Effectful/Writer/Dynamic.hs view
@@ -1,8 +1,12 @@+{-# OPTIONS_GHC -Wno-orphans #-} -- | The dynamically dispatched variant of the 'Writer' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use one of the statically dispatched variants,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.Writer.MonadWriter' instance for compatibility with existing+-- code, it's recommended to use one of the statically dispatched variants, -- i.e. "Effectful.Writer.Static.Local" or "Effectful.Writer.Static.Shared".+--+-- __If you just want to accumulate values, use "Effectful.Output.Dynamic".__ module Effectful.Writer.Dynamic ( -- * Effect Writer(..)@@ -25,34 +29,24 @@ import Effectful import Effectful.Dispatch.Dynamic+import Effectful.Internal.Effect.Dynamic (Writer(..)) import Effectful.Writer.Static.Local qualified as L import Effectful.Writer.Static.Shared qualified as S --- | Provide access to a write only value of type @w@.-data Writer w :: Effect where- Tell :: w -> Writer w m ()- Listen :: m a -> Writer w m (a, w)--type instance DispatchOf (Writer w) = Dynamic- ---------------------------------------- -- Local -- | Run the 'Writer' effect and return the final value along with the final -- output (via "Effectful.Writer.Static.Local").-runWriterLocal :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriterLocal :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriterLocal = reinterpret L.runWriter localWriter -- | Run a 'Writer' effect and return the final output, discarding the final -- value (via "Effectful.Writer.Static.Local").-execWriterLocal :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriterLocal :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriterLocal = reinterpret L.execWriter localWriter -localWriter- :: (L.Writer w :> es, Monoid w)- => LocalEnv localEs es- -> Writer w (Eff localEs) a- -> Eff es a+localWriter :: (L.Writer w :> es, Monoid w) => EffectHandler (Writer w) es localWriter env = \case Tell w -> L.tell w Listen m -> localSeqUnlift env $ \unlift -> L.listen (unlift m)@@ -62,19 +56,15 @@ -- | Run the 'Writer' effect and return the final value along with the final -- output (via "Effectful.Writer.Static.Shared").-runWriterShared :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriterShared :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriterShared = reinterpret S.runWriter sharedWriter -- | Run the 'Writer' effect and return the final output, discarding the final -- value (via "Effectful.Writer.Static.Shared").-execWriterShared :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriterShared :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriterShared = reinterpret S.execWriter sharedWriter -sharedWriter- :: (S.Writer w :> es, Monoid w)- => LocalEnv localEs es- -> Writer w (Eff localEs) a- -> Eff es a+sharedWriter :: (S.Writer w :> es, Monoid w) => EffectHandler (Writer w) es sharedWriter env = \case Tell w -> S.tell w Listen m -> localSeqUnlift env $ \unlift -> S.listen (unlift m)
src/Effectful/Writer/Static/Local.hs view
@@ -8,6 +8,8 @@ -- is inefficient. __This applies, in particular, to the standard list type__, -- which makes the 'Writer' effect pretty niche. --+-- __If you just want to accumulate values, use "Effectful.Output.Static.Local.Array" or "Effectful.Output.Static.Local.List".__+-- -- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the -- @transformers@ package includes additional operations -- 'Control.Monad.Trans.Writer.Strict.pass' and@@ -28,6 +30,7 @@ ) where import Control.Exception (onException, mask)+import Data.Kind import Effectful import Effectful.Dispatch.Static@@ -35,27 +38,27 @@ -- | Provide access to a strict (WHNF), thread local, write only value of type -- @w@.-data Writer w :: Effect+data Writer (w :: Type) :: Effect type instance DispatchOf (Writer w) = Static NoSideEffects newtype instance StaticRep (Writer w) = Writer w -- | Run a 'Writer' effect and return the final value along with the final -- output.-runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriter m = do (a, Writer w) <- runStaticRep (Writer mempty) m pure (a, w) -- | Run a 'Writer' effect and return the final output, discarding the final -- value.-execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriter m = do Writer w <- execStaticRep (Writer mempty) m pure w -- | Append the given output to the overall output of the 'Writer'.-tell :: (Writer w :> es, Monoid w) => w -> Eff es ()+tell :: (HasCallStack, Writer w :> es, Monoid w) => w -> Eff es () tell w = stateStaticRep $ \(Writer w0) -> ((), Writer (w0 <> w)) -- | Execute an action and append its output to the overall output of the@@ -75,26 +78,30 @@ -- error "oops" -- :} -- "Hi there!"-listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)+listen :: (HasCallStack, Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) listen m = unsafeEff $ \es -> mask $ \unmask -> do- w0 <- stateEnv es $ \(Writer w) -> pure (w, Writer mempty)+ w0 <- stateEnv es $ \(Writer w) -> (w, Writer mempty) a <- unmask (unEff m es) `onException` merge es w0 (a, ) <$> merge es w0 where merge es w0 = -- If an exception is thrown, restore w0 and keep parts of w1.- stateEnv es $ \(Writer w1) -> pure (w1, Writer (w0 <> w1))+ stateEnv es $ \(Writer w1) -> (w1, Writer (w0 <> w1)) -- | Execute an action and append its output to the overall output of the -- 'Writer', then return the final value along with a function of the recorded -- output. -- -- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@-listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)+listens+ :: (HasCallStack, Writer w :> es, Monoid w)+ => (w -> b)+ -> Eff es a+ -> Eff es (a, b) listens f m = do (a, w) <- listen m pure (a, f w) -- $setup -- >>> import Control.Exception (ErrorCall)--- >>> import Control.Monad.Catch+-- >>> import Effectful.Exception
@@ -8,6 +8,8 @@ -- is inefficient. __This applies, in particular, to the standard list type__, -- which makes the 'Writer' effect pretty niche. --+-- __If you just want to accumulate values, use "Effectful.Output.Static.Shared.Array" or "Effectful.Output.Static.Shared.List".__+-- -- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the -- @transformers@ package includes additional operations -- 'Control.Monad.Trans.Writer.Strict.pass' and@@ -27,44 +29,69 @@ , listens ) where +import Control.Concurrent.MVar.Strict qualified as S import Control.Exception (onException, uninterruptibleMask)+import Data.Kind import Effectful import Effectful.Dispatch.Static import Effectful.Dispatch.Static.Primitive-import Effectful.Internal.Utils -- | Provide access to a strict (WHNF), shared, write only value of type @w@.-data Writer w :: Effect+data Writer (w :: Type) :: Effect type instance DispatchOf (Writer w) = Static NoSideEffects-newtype instance StaticRep (Writer w) = Writer (MVar' w)+newtype instance StaticRep (Writer w) = Writer (S.MVar w) -- | Run a 'Writer' effect and return the final value along with the final -- output.-runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)+runWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es (a, w) runWriter m = do- v <- unsafeEff_ $ newMVar' mempty+ v <- unsafeEff_ $ S.newMVar mempty a <- evalStaticRep (Writer v) m- (a, ) <$> unsafeEff_ (readMVar' v)+ (a, ) <$> unsafeEff_ (S.readMVar v) -- | Run a 'Writer' effect and return the final output, discarding the final -- value.-execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w+execWriter :: (HasCallStack, Monoid w) => Eff (Writer w : es) a -> Eff es w execWriter m = do- v <- unsafeEff_ $ newMVar' mempty+ v <- unsafeEff_ $ S.newMVar mempty _ <- evalStaticRep (Writer v) m- unsafeEff_ $ readMVar' v+ unsafeEff_ $ S.readMVar v -- | Append the given output to the overall output of the 'Writer'.-tell :: (Writer w :> es, Monoid w) => w -> Eff es ()+tell :: (HasCallStack, Writer w :> es, Monoid w) => w -> Eff es () tell w1 = unsafeEff $ \es -> do Writer v <- getEnv es- modifyMVar_' v $ \w0 -> let w = w0 <> w1 in pure w+ S.modifyMVar_ v $ \w0 -> pure (w0 <> w1) -- | Execute an action and append its output to the overall output of the -- 'Writer'. --+-- /Note:/ the output of 'tell' executed from threads spawned within the nested+-- action is accounted for only if it completes before 'listen' merges the+-- output, which happens as soon as the action finishes. In particular, the+-- output of threads that outlive the scope of 'listen' will be lost:+--+-- >>> :{+-- runEff . execWriter @String $ do+-- lock <- liftIO newEmptyMVar+-- done <- liftIO newEmptyMVar+-- tell "1"+-- _ <- listen @String $ do+-- tell "2"+-- withEffToIO (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do+-- _ <- forkIO $ do+-- takeMVar lock+-- unlift $ tell "3"+-- putMVar done ()+-- pure ()+-- liftIO $ putMVar lock ()+-- liftIO $ takeMVar done+-- tell "4"+-- :}+-- "124"+-- -- /Note:/ if an exception is received while the action is executed, the partial -- output of the action will still be appended to the overall output of the -- 'Writer':@@ -79,15 +106,15 @@ -- error "oops" -- :} -- "Hi there!"-listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)+listen :: (HasCallStack, Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w) listen m = unsafeEff $ \es -> do -- The mask is uninterruptible because modifyMVar_ v0 in the merge function -- might block and if an async exception is received while waiting, w1 will be -- lost. uninterruptibleMask $ \unmask -> do- v1 <- newMVar' mempty+ v1 <- S.newMVar mempty -- Replace thread local MVar with a fresh one for isolated listening.- v0 <- stateEnv es $ \(Writer v) -> pure (v, Writer v1)+ v0 <- stateEnv es $ \(Writer v) -> (v, Writer v1) a <- unmask (unEff m es) `onException` merge es v0 v1 (a, ) <$> merge es v0 v1 where@@ -95,8 +122,8 @@ -- exception was received while listening, merge results recorded so far. merge es v0 v1 = do putEnv es $ Writer v0- w1 <- readMVar' v1- modifyMVar_' v0 $ \w0 -> let w = w0 <> w1 in pure w+ w1 <- S.readMVar v1+ S.modifyMVar_ v0 $ \w0 -> pure (w0 <> w1) pure w1 -- | Execute an action and append its output to the overall output of the@@ -104,11 +131,16 @@ -- output. -- -- @'listens' f m ≡ 'Data.Bifunctor.second' f '<$>' 'listen' m@-listens :: (Writer w :> es, Monoid w) => (w -> b) -> Eff es a -> Eff es (a, b)+listens+ :: (HasCallStack, Writer w :> es, Monoid w)+ => (w -> b)+ -> Eff es a+ -> Eff es (a, b) listens f m = do (a, w) <- listen m pure (a, f w) -- $setup+-- >>> import Control.Concurrent -- >>> import Control.Exception (ErrorCall)--- >>> import Control.Monad.Catch+-- >>> import Effectful.Exception