diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,101 @@
+# effectful-core-2.7.1.0 (2026-08-24)
+* Export `seqForkUnliftIO` and add `unsafeSeqForkUnliftIO` in
+ `Effectful.Dispatch.Static` for the `SeqForkUnlift` strategy.
+* Export `type (++)` from `Effectful.Dispatch.Dynamic`.
+* Remove an unnecessary `HasCallStack` constraint from `handleJust`.
+
+# 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
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,12 +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://www.stackage.org/lts/package/effectful)
[](https://www.stackage.org/nightly/package/effectful)
-
+
An easy to use, fast extensible effects library with seamless integration with
the existing Haskell ecosystem.
diff --git a/cbits/utils.c b/cbits/utils.c
deleted file mode 100644
--- a/cbits/utils.c
+++ /dev/null
@@ -1,5 +0,0 @@
-// Correct implementation of ThreadId# equality for GHC < 9.
-long effectful_eq_thread(void *tso1, void *tso2)
-{
- return tso1 == tso2;
-}
diff --git a/effectful-core.cabal b/effectful-core.cabal
--- a/effectful-core.cabal
+++ b/effectful-core.cabal
@@ -1,7 +1,7 @@
-cabal-version: 3.0
+cabal-version: 3.8
build-type: Simple
name: effectful-core
-version: 2.5.1.0
+version: 2.7.1.0
license: BSD-3-Clause
license-file: LICENSE
category: Control
@@ -12,7 +12,7 @@
description:
An easy to use, performant extensible effects library with seamless
integration with the existing Haskell ecosystem.
- .
+
This library provides core definitions with a minimal dependency
footprint. See the @@
package for the "batteries-included" variant.
@@ -21,7 +21,7 @@
CHANGELOG.md
README.md
-tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.5, 9.8.3, 9.10.1, 9.12.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
@@ -31,56 +31,41 @@
common language
ghc-options: -Wall
-Wcompat
- -Wno-unticked-promoted-constructors
- -Wmissing-deriving-strategies
+ -Werror=missing-deriving-strategies
-Werror=prepositive-qualified-module
- default-language: Haskell2010
+ default-language: GHC2021
- default-extensions: BangPatterns
- ConstraintKinds
- DataKinds
- DeriveFunctor
- DeriveGeneric
+ default-extensions: DataKinds
+ DeepSubsumption
DerivingStrategies
- FlexibleContexts
- FlexibleInstances
- GADTs
- GeneralizedNewtypeDeriving
- ImportQualifiedPost
+ DuplicateRecordFields
LambdaCase
- MultiParamTypeClasses
+ NoFieldSelectors
NoStarIsType
- PolyKinds
- 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
- , strict-mutable-base >= 1.1.0.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
@@ -90,22 +75,40 @@
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
diff --git a/src/Effectful.hs b/src/Effectful.hs
--- a/src/Effectful.hs
+++ b/src/Effectful.hs
@@ -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'Effectful.Exception.MonadMask' or 'MonadUnliftIO'.
+-- such as t'Control.Monad.Catch.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
diff --git a/src/Effectful/Dispatch/Dynamic.hs b/src/Effectful/Dispatch/Dynamic.hs
--- a/src/Effectful/Dispatch/Dynamic.hs
+++ b/src/Effectful/Dispatch/Dynamic.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE UndecidableInstances #-}
-- | Dynamically dispatched effects.
module Effectful.Dispatch.Dynamic
( -- * Introduction
@@ -57,8 +56,10 @@
, localLend
, localSeqBorrow
, localBorrow
+ , localLendBorrow
, SharedSuffix
, KnownSubset
+ , type (++)
-- ** Utils for first order effects
, EffectHandler_
@@ -349,8 +350,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
@@ -419,20 +418,21 @@
-- | A variant of 'send' for passing operations to the upstream handler within
-- 'interpose' and 'impose' without having to fully pattern match on them.
passthrough
- :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es, e :> localEs, SharedSuffix es handlerEs)
- => LocalEnv localEs handlerEs
+ :: (HasCallStack, DispatchOf e ~ Dynamic, e :> es, e :> localEs)
+ => LocalEnv localEs
-> e (Eff localEs) a
-- ^ The operation.
-> Eff es a
-passthrough (LocalEnv les) op = unsafeEff $ \es -> do
+passthrough localEs op = unsafeEff $ \es -> do
+ les <- unwrapLocalEnv es localEs
Handler handlerEs (HandlerImpl handler) <- getEnv es
- when (envStorage les /= envStorage handlerEs) $ do
+ 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 (LocalEnv les) op) handlerEs
+ unEff (withFrozenCallStack handler localEs op) handlerEs
{-# NOINLINE passthrough #-}
----------------------------------------
@@ -466,6 +466,41 @@
-- | 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
:: (HasCallStack, DispatchOf e ~ Dynamic)
=> (Eff handlerEs a -> Eff es b)
@@ -539,12 +574,13 @@
--
-- >>> runEff . runE . augmentOp2 $ send Op3
-- *** Exception: Op3 not implemented
--- CallStack (from HasCallStack):
+-- ...
-- error, called at :...
-- handler, called at src/Effectful/Dispatch/Dynamic.hs:...
-- passthrough, called at :...
-- handler, called at src/Effectful/Dispatch/Dynamic.hs:...
-- send, called at :...
+-- ...
interpose
:: (HasCallStack, DispatchOf e ~ Dynamic, e :> es)
=> EffectHandler e es
@@ -717,14 +753,14 @@
-- | 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
- requireMatchingStorages es les
+localSeqUnlift localEs k = unsafeEff $ \es -> do
+ les <- unwrapLocalEnv es localEs
seqUnliftIO les $ \unlift -> do
(`unEff` es) $ k $ unsafeEff_ . unlift
{-# INLINE localSeqUnlift #-}
@@ -732,28 +768,28 @@
-- | 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 = unsafeEff $ \es -> do
- requireMatchingStorages es les
+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 = unsafeEff $ \es -> do
- requireMatchingStorages es les
+localUnlift localEs strategy k = unsafeEff $ \es -> do
+ les <- unwrapLocalEnv es localEs
case strategy of
SeqUnlift -> seqUnliftIO les $ \unlift -> do
(`unEff` es) $ k $ unsafeEff_ . unlift
@@ -765,15 +801,15 @@
-- | 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 = unsafeEff $ \es -> do
- requireMatchingStorages es les
+localUnliftIO localEs strategy k = unsafeEff $ \es -> do
+ les <- unwrapLocalEnv es localEs
case strategy of
SeqUnlift -> seqUnliftIO les k
SeqForkUnlift -> seqForkUnliftIO les k
@@ -788,14 +824,14 @@
--
-- @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 (LocalEnv les) k = unsafeEff $ \es -> do
- requireMatchingStorages es les
+localSeqLift localEs k = unsafeEff $ \es -> do
+ requireMatchingStorages es localEs
seqUnliftIO es $ \unlift -> do
(`unEff` es) $ k $ unsafeEff_ . unlift
{-# INLINE localSeqLift #-}
@@ -804,15 +840,15 @@
--
-- @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 (LocalEnv les) strategy k = unsafeEff $ \es -> do
- requireMatchingStorages es les
+localLift localEs strategy k = unsafeEff $ \es -> do
+ requireMatchingStorages es localEs
case strategy of
SeqUnlift -> seqUnliftIO es $ \unlift -> do
(`unEff` es) $ k $ unsafeEff_ . unlift
@@ -832,19 +868,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 (LocalEnv les) k = unsafeEff $ \es -> do
- requireMatchingStorages es les
- (`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
-{-# INLINE withLiftMap #-}
+{-# 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
--
@@ -873,16 +914,16 @@
-- 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 (LocalEnv les) k = unsafeEff $ \es -> do
- requireMatchingStorages es les
- (`unEff` es) $ k $ \mapIO m -> unsafeEff $ \localEs -> do
- seqUnliftIO localEs $ \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 #-}
----------------------------------------
@@ -893,28 +934,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 = unsafeEff $ \es -> do
- requireMatchingStorages es les
+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)
- SeqForkUnlift -> seqForkUnliftIO es $ \unliftEs -> do
- seqForkUnliftIO les $ \unliftLocalEs -> do
- (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)
- ConcUnlift p l -> concUnliftIO es p l $ \unliftEs -> do
- concUnliftIO les p l $ \unliftLocalEs -> do
- (`unEff` es) $ k (unsafeEff_ . unliftEs) (unsafeEff_ . unliftLocalEs)
+ 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
@@ -926,15 +966,15 @@
-- /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 = unsafeEff $ \es -> do
- requireMatchingStorages es les
+localLiftUnliftIO localEs strategy k = unsafeEff $ \es -> do
+ les <- unwrapLocalEnv es localEs
case strategy of
SeqUnlift -> seqUnliftIO les $ k unsafeEff_
SeqForkUnlift -> seqForkUnliftIO les $ k unsafeEff_
@@ -988,13 +1028,14 @@
--
-- @since 2.4.0.0
localSeqLend
- :: forall lentEs es handlerEs localEs a
- . (HasCallStack, KnownSubset lentEs es, SharedSuffix es handlerEs)
- => LocalEnv localEs handlerEs
+ :: 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
+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 #-}
@@ -1005,14 +1046,15 @@
--
-- @since 2.4.0.0
localLend
- :: forall lentEs es handlerEs localEs a
- . (HasCallStack, KnownSubset lentEs es, SharedSuffix es handlerEs)
- => LocalEnv localEs handlerEs
+ :: forall lentEs es localEs a
+ . (HasCallStack, KnownSubset lentEs es)
+ => LocalEnv localEs
-> UnliftStrategy
-> ((forall r. Eff (lentEs ++ localEs) r -> Eff localEs r) -> Eff es a)
-- ^ Continuation with the lent handler in scope.
-> Eff es a
-localLend (LocalEnv les) strategy k = unsafeEff $ \es -> do
+localLend localEs strategy k = unsafeEff $ \es -> do
+ les <- unwrapLocalEnv es localEs
eles <- copyRefs @lentEs es les
case strategy of
SeqUnlift -> seqUnliftIO eles $ \unlift -> do
@@ -1027,13 +1069,14 @@
--
-- @since 2.4.0.0
localSeqBorrow
- :: forall borrowedEs es handlerEs localEs a
- . (HasCallStack, KnownSubset borrowedEs localEs, SharedSuffix es handlerEs)
- => LocalEnv localEs handlerEs
+ :: 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
+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 #-}
@@ -1045,14 +1088,15 @@
--
-- @since 2.4.0.0
localBorrow
- :: forall borrowedEs es handlerEs localEs a
- . (HasCallStack, KnownSubset borrowedEs localEs, SharedSuffix es handlerEs)
- => LocalEnv localEs handlerEs
+ :: forall borrowedEs es localEs a
+ . (HasCallStack, KnownSubset borrowedEs localEs)
+ => LocalEnv localEs
-> UnliftStrategy
-> ((forall r. Eff (borrowedEs ++ es) r -> Eff es r) -> Eff es a)
-- ^ Continuation with the borrowed handler in scope.
-> Eff es a
-localBorrow (LocalEnv les) strategy k = unsafeEff $ \es -> do
+localBorrow localEs strategy k = unsafeEff $ \es -> do
+ les <- unwrapLocalEnv es localEs
ees <- copyRefs @borrowedEs les es
case strategy of
SeqUnlift -> seqUnliftIO ees $ \unlift -> do
@@ -1063,10 +1107,48 @@
(`unEff` es) $ k $ unsafeEff_ . unlift
{-# INLINE localBorrow #-}
+-- | Simultaneously lend effects to the local environment and borrow effects
+-- from it with a given unlifting strategy.
+--
+-- /Note:/ when 'SeqForkUnlift' or 'ConcUnlift' 'Persistent' strategy is used,
+-- the lending and borrowing functions will share the effect storage (unlike
+-- with two separate calls to 'localLend' and 'localBorrow').
+--
+-- @since 2.7.0.0
+localLendBorrow
+ :: forall lentEs borrowedEs es localEs a
+ . ( HasCallStack
+ , KnownSubset lentEs es
+ , KnownSubset borrowedEs localEs
+ )
+ => LocalEnv localEs
+ -> UnliftStrategy
+ -> ( (forall r. Eff (lentEs ++ localEs) r -> Eff localEs r)
+ -> (forall r. Eff (borrowedEs ++ es) r -> Eff es r)
+ -> Eff es a
+ )
+ -- ^ Continuation with the lending and borrowing functions in scope.
+ -> Eff es a
+localLendBorrow localEs strategy k = unsafeEff $ \es -> do
+ les <- unwrapLocalEnv es localEs
+ eles <- copyRefs @lentEs es les
+ ees <- copyRefs @borrowedEs les es
+ case strategy of
+ SeqUnlift -> seqUnliftIO eles $ \unliftLent -> do
+ seqUnliftIO ees $ \unliftBorrowed -> do
+ (`unEff` es) $ k (unsafeEff_ . unliftLent) (unsafeEff_ . unliftBorrowed)
+ SeqForkUnlift -> seqForkUnliftsIO eles ees $ \unliftLent unliftBorrowed -> do
+ (`unEff` es) $ k (unsafeEff_ . unliftLent) (unsafeEff_ . unliftBorrowed)
+ ConcUnlift p l -> concUnliftsIO eles ees p l $ \unliftLent unliftBorrowed -> do
+ (`unEff` es) $ k (unsafeEff_ . unliftLent) (unsafeEff_ . unliftBorrowed)
+{-# INLINE localLendBorrow #-}
+
-- | Require that both effect stacks share an opaque suffix.
--
--- Functions from the 'localUnlift' family utilize this constraint to guarantee
--- sensible usage of unlifting functions.
+-- Functions from the 'localUnlift' family previously required this constraint
+-- to reject a subset of improper uses of unlifting functions at compile
+-- time. It's no longer necessary, since all of them are detected at runtime
+-- now.
--
-- As an example, consider the following higher order effect:
--
@@ -1103,24 +1185,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
@@ -1154,6 +1227,7 @@
-> 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 #-}
@@ -1200,6 +1274,7 @@
)
(\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.
@@ -1214,8 +1289,7 @@
=> Env srcEs
-> Env destEs
-> IO (Env (es ++ destEs))
-copyRefs src@(Env soffset srefs _) dest@(Env doffset drefs storage) = do
- requireMatchingStorages src dest
+copyRefs (Env soffset srefs _) (Env doffset drefs storage) = do
let es = reifyIndices @es @srcEs
esSize = length es
destSize = sizeofPrimArray drefs - doffset
@@ -1231,13 +1305,16 @@
pure $ Env 0 refs storage
{-# NOINLINE copyRefs #-}
-requireMatchingStorages :: HasCallStack => Env es1 -> Env es2 -> IO ()
-requireMatchingStorages es1 es2
- | envStorage es1 /= envStorage es2 = error
- $ "Env and LocalEnv point to different Storages.\n"
- ++ "If you passed LocalEnv to a different thread and tried to create an "
- ++ "unlifting function there, it's not allowed. You need to create it in "
- ++ "the thread of the effect handler."
+-- | 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
diff --git a/src/Effectful/Dispatch/Static.hs b/src/Effectful/Dispatch/Static.hs
--- a/src/Effectful/Dispatch/Static.hs
+++ b/src/Effectful/Dispatch/Static.hs
@@ -25,8 +25,10 @@
-- ** Unlifts
, seqUnliftIO
+ , seqForkUnliftIO
, concUnliftIO
, unsafeSeqUnliftIO
+ , unsafeSeqForkUnliftIO
, unsafeConcUnliftIO
-- ** Utils
@@ -199,6 +201,20 @@
unsafeSeqUnliftIO k = unsafeEff $ \es -> do
seqUnliftIO es k
+-- | Create an unlifting function with the 'SeqForkUnlift' strategy.
+--
+-- This function is __unsafe__ because it can be used to introduce arbitrary
+-- 'IO' actions into pure 'Eff' computations.
+--
+-- @since 2.7.1.0
+unsafeSeqForkUnliftIO
+ :: HasCallStack
+ => ((forall r. Eff es r -> IO r) -> IO a)
+ -- ^ Continuation with the unlifting function in scope.
+ -> Eff es a
+unsafeSeqForkUnliftIO k = unsafeEff $ \es -> do
+ seqForkUnliftIO es k
+
-- | Create an unlifting function with the 'ConcUnlift' strategy.
--
-- This function is __unsafe__ because it can be used to introduce arbitrary
@@ -214,4 +230,5 @@
concUnliftIO es persistence limit k
-- $setup
+-- >>> :seti -XFieldSelectors
-- >>> import Effectful
diff --git a/src/Effectful/Dispatch/Static/Unsafe.hs b/src/Effectful/Dispatch/Static/Unsafe.hs
--- a/src/Effectful/Dispatch/Static/Unsafe.hs
+++ b/src/Effectful/Dispatch/Static/Unsafe.hs
@@ -5,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)
diff --git a/src/Effectful/Error/Dynamic.hs b/src/Effectful/Error/Dynamic.hs
--- a/src/Effectful/Error/Dynamic.hs
+++ b/src/Effectful/Error/Dynamic.hs
@@ -1,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(..)
@@ -17,6 +21,9 @@
, throwErrorWith
, throwError
, throwError_
+ , rethrowErrorWith
+ , rethrowError
+ , rethrowError_
, catchError
, handleError
, tryError
@@ -33,14 +40,7 @@
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
- -- | @since 2.4.0.0
- ThrowErrorWith :: (e -> String) -> 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
@@ -49,6 +49,7 @@
-> Eff es (Either (E.CallStack, e) a)
runError = reinterpret E.runError $ \env -> \case
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)
@@ -118,6 +119,51 @@
-- ^ The error.
-> Eff es a
throwError_ = withFrozenCallStack throwErrorWith (const "")
+
+-- | Throw an error of type @e@ with the given 'E.CallStack' and specify a
+-- display function in case a third-party code catches the internal exception
+-- and 'show's it.
+--
+-- Useful e.g. when you want to catch an error and rethrow it converted to a
+-- different type without losing the original 'E.CallStack'.
+--
+-- @since 2.7.0.0
+rethrowErrorWith
+ :: Error e :> es
+ => (e -> String)
+ -- ^ The display function.
+ -> E.CallStack
+ -- ^ The 'E.CallStack' to attach to the error.
+ -> e
+ -- ^ The error.
+ -> Eff es a
+rethrowErrorWith display cs = send . RethrowErrorWith display cs
+
+-- | Throw an error of type @e@ with the given 'E.CallStack' and 'show' as a
+-- display function.
+--
+-- @since 2.7.0.0
+rethrowError
+ :: (Error e :> es, Show e)
+ => E.CallStack
+ -- ^ The 'E.CallStack' to attach to the error.
+ -> e
+ -- ^ The error.
+ -> Eff es a
+rethrowError = rethrowErrorWith show
+
+-- | Throw an error of type @e@ with the given 'E.CallStack' and no display
+-- function.
+--
+-- @since 2.7.0.0
+rethrowError_
+ :: Error e :> es
+ => E.CallStack
+ -- ^ The 'E.CallStack' to attach to the error.
+ -> e
+ -- ^ The error.
+ -> Eff es a
+rethrowError_ = rethrowErrorWith (const "")
-- | Handle an error of type @e@.
catchError
diff --git a/src/Effectful/Error/Static.hs b/src/Effectful/Error/Static.hs
--- a/src/Effectful/Error/Static.hs
+++ b/src/Effectful/Error/Static.hs
@@ -75,6 +75,20 @@
-- /Hint:/ if you'd like to reproduce the transactional behavior with the
-- t'Effectful.State.Static.Local.State' effect, appropriate usage of
-- '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
@@ -89,6 +103,9 @@
, throwErrorWith
, throwError
, throwError_
+ , rethrowErrorWith
+ , rethrowError
+ , rethrowError_
, catchError
, handleError
, tryError
@@ -193,6 +210,53 @@
-> Eff es a
throwError_ = withFrozenCallStack throwErrorWith (const "")
+-- | Throw an error of type @e@ with the given 'CallStack' and specify a
+-- display function in case a third-party code catches the internal exception
+-- and 'show's it.
+--
+-- Useful e.g. when you want to catch an error and rethrow it converted to a
+-- different type without losing the original 'CallStack'.
+--
+-- @since 2.7.0.0
+rethrowErrorWith
+ :: forall e es a. Error e :> es
+ => (e -> String)
+ -- ^ The display function.
+ -> CallStack
+ -- ^ The 'CallStack' to attach to the error.
+ -> e
+ -- ^ The error.
+ -> Eff es a
+rethrowErrorWith display cs e = do
+ Error eid <- getStaticRep @(Error e)
+ throwIO $ ErrorWrapper eid cs (display e) (toAny e)
+
+-- | Throw an error of type @e@ with the given 'CallStack' and 'show' as a
+-- display function.
+--
+-- @since 2.7.0.0
+rethrowError
+ :: forall e es a. (Error e :> es, Show e)
+ => CallStack
+ -- ^ The 'CallStack' to attach to the error.
+ -> e
+ -- ^ The error.
+ -> Eff es a
+rethrowError = rethrowErrorWith show
+
+-- | Throw an error of type @e@ with the given 'CallStack' and no display
+-- function.
+--
+-- @since 2.7.0.0
+rethrowError_
+ :: forall e es a. Error e :> es
+ => CallStack
+ -- ^ The 'CallStack' to attach to the error.
+ -> e
+ -- ^ The error.
+ -> Eff es a
+rethrowError_ = rethrowErrorWith (const "")
+
-- | Handle an error of type @e@.
catchError
:: forall e es a. (HasCallStack, Error e :> es)
@@ -241,13 +305,22 @@
data ErrorWrapper = ErrorWrapper !ErrorId CallStack String Any
instance Show ErrorWrapper where
- showsPrec _ (ErrorWrapper _ cs errRep _)
- = ("Effectful.Error.Static.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." ++)
-instance Exception ErrorWrapper
+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)
diff --git a/src/Effectful/Exception.hs b/src/Effectful/Exception.hs
--- a/src/Effectful/Exception.hs
+++ b/src/Effectful/Exception.hs
@@ -52,6 +52,7 @@
-- | #cleanup#
-- * Cleanup (no recovery)
+ -- $cleanup
, bracket
, bracket_
, bracketOnError
@@ -59,6 +60,7 @@
, C.ExitCase(..)
, finally
, onException
+ , withException
-- * Utils
@@ -300,7 +302,7 @@
-- | Flipped version of 'catchJust'.
handleJust
- :: (HasCallStack, E.Exception e)
+ :: E.Exception e
=> (e -> Maybe b)
-- ^ The predicate.
-> (b -> Eff es a)
@@ -443,6 +445,15 @@
----------------------------------------
-- 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
@@ -452,8 +463,11 @@
-> (a -> Eff es c)
-- ^ Computation to run in-between.
-> Eff es c
-bracket before after action = reallyUnsafeUnliftIO $ \unlift -> do
- E.bracket (unlift before) (unlift . after) (unlift . action)
+bracket before after action = mask $ \restore -> do
+ a <- before
+ r <- restore (action a) `onException` after a
+ _ <- after a
+ pure r
-- | Lifted 'E.bracket_'.
bracket_
@@ -464,8 +478,7 @@
-> Eff es c
-- ^ Computation to run in-between.
-> Eff es c
-bracket_ before after action = reallyUnsafeUnliftIO $ \unlift -> do
- E.bracket_ (unlift before) (unlift after) (unlift action)
+bracket_ before after action = bracket before (const after) (const action)
-- | Lifted 'E.bracketOnError'.
bracketOnError
@@ -477,8 +490,9 @@
-> (a -> Eff es c)
-- ^ Computation to run in-between.
-> Eff es c
-bracketOnError before after action = reallyUnsafeUnliftIO $ \unlift -> do
- E.bracketOnError (unlift before) (unlift . after) (unlift . action)
+bracketOnError before after action = mask $ \restore -> do
+ a <- before
+ restore (action a) `onException` after a
-- | Generalization of 'bracket'.
--
@@ -499,8 +513,10 @@
-> Eff es b
-- ^ Computation to run last.
-> Eff es a
-finally action handler = reallyUnsafeUnliftIO $ \unlift -> do
- E.finally (unlift action) (unlift handler)
+finally action handler = mask $ \restore -> do
+ r <- restore action `onException` handler
+ _ <- handler
+ pure r
-- | Lifted 'E.onException'.
onException
@@ -509,8 +525,29 @@
-- ^ Computation to run last when an exception or
-- t'Effectful.Error.Static.Error' was thrown.
-> Eff es a
-onException action handler = reallyUnsafeUnliftIO $ \unlift -> do
- E.onException (unlift action) (unlift handler)
+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
diff --git a/src/Effectful/Input/Dynamic.hs b/src/Effectful/Input/Dynamic.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Input/Dynamic.hs
@@ -0,0 +1,68 @@
+-- | The dynamically dispatched variant of the 'Input' effect.
+--
+-- /Note:/ unless you plan to change interpretations at runtime, it's
+-- recommended to use one of the statically dispatched variants,
+-- i.e. "Effectful.Input.Static" or "Effectful.Input.Static.Action".
+--
+-- @since 2.7.0.0
+module Effectful.Input.Dynamic
+ ( -- * Effect
+ Input(..)
+
+ -- ** Handlers
+ , runInput
+ , runInputAction
+
+ -- ** Operations
+ , input
+ , inputs
+ ) where
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+
+-- | Provide access to values of type @i@.
+data Input i :: Effect where
+ Input :: Input i m i
+
+type instance DispatchOf (Input i) = Dynamic
+
+----------------------------------------
+-- Handlers
+
+-- | Run the 'Input' effect with the given value.
+runInput
+ :: HasCallStack
+ => i
+ -- ^ The input value.
+ -> Eff (Input i : es) a
+ -> Eff es a
+runInput inputValue = interpret_ $ \case
+ Input -> pure inputValue
+
+-- | Run the 'Input' effect with the given action that supplies values.
+runInputAction
+ :: forall i es a
+ . HasCallStack
+ => (HasCallStack => Eff es i)
+ -- ^ The action for input generation.
+ -> Eff (Input i : es) a
+ -> Eff es a
+runInputAction inputAction = interpret_ $ \case
+ Input -> inputAction
+
+----------------------------------------
+-- Operations
+
+-- | Fetch the value.
+input :: (HasCallStack, Input i :> es) => Eff es i
+input = send Input
+
+-- | Fetch the result of applying a function to the value.
+--
+-- @'inputs' f ≡ f '<$>' 'input'@
+inputs
+ :: (HasCallStack, Input i :> es)
+ => (i -> a) -- ^ The function to apply to the value.
+ -> Eff es a
+inputs f = f <$> input
diff --git a/src/Effectful/Input/Static.hs b/src/Effectful/Input/Static.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Input/Static.hs
@@ -0,0 +1,49 @@
+-- | Support for access to a value of a particular type.
+--
+-- @since 2.7.0.0
+module Effectful.Input.Static
+ ( -- * Effect
+ Input
+
+ -- ** Handlers
+ , runInput
+
+ -- ** Operations
+ , input
+ , inputs
+ ) where
+
+import Data.Kind
+
+import Effectful
+import Effectful.Dispatch.Static
+
+-- | Provide access to a value of type @i@.
+data Input (i :: Type) :: Effect
+
+type instance DispatchOf (Input i) = Static NoSideEffects
+newtype instance StaticRep (Input i) = Input i
+
+-- | Run the 'Input' effect with the given value.
+runInput
+ :: HasCallStack
+ => i
+ -- ^ The input value.
+ -> Eff (Input i : es) a
+ -> Eff es a
+runInput = evalStaticRep . Input
+
+-- | Fetch the value.
+input :: (HasCallStack, Input i :> es) => Eff es i
+input = do
+ Input i <- getStaticRep
+ pure i
+
+-- | Fetch the result of applying a function to the value.
+--
+-- @'inputs' f ≡ f '<$>' 'input'@
+inputs
+ :: (HasCallStack, Input i :> es)
+ => (i -> a) -- ^ The function to apply to the value.
+ -> Eff es a
+inputs f = f <$> input
diff --git a/src/Effectful/Input/Static/Action.hs b/src/Effectful/Input/Static/Action.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Input/Static/Action.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE ImplicitParams #-}
+-- | Support for access to values supplied by a monadic action.
+--
+-- @since 2.7.0.0
+module Effectful.Input.Static.Action
+ ( -- * Effect
+ Input
+
+ -- ** Handlers
+ , runInput
+
+ -- ** Operations
+ , input
+ , inputs
+ ) where
+
+import Data.Kind
+import GHC.Stack
+
+import Effectful
+import Effectful.Dispatch.Static
+import Effectful.Dispatch.Static.Primitive
+import Effectful.Internal.Utils
+
+-- | Provide access to values of type @i@ supplied by a monadic action.
+data Input (i :: Type) :: Effect
+
+type instance DispatchOf (Input i) = Static NoSideEffects
+
+-- | Wrapper to prevent a space leak on reconstruction of 'Input' in
+-- 'relinkInput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).
+newtype InputImpl i es where
+ InputImpl :: (HasCallStack => Eff es i) -> InputImpl i es
+
+data instance StaticRep (Input i) where
+ Input
+ :: !(Env inputEs)
+ -> !(InputImpl i inputEs)
+ -> StaticRep (Input i)
+
+-- | Run the 'Input' effect with the given action that supplies values.
+runInput
+ :: forall i es a
+ . HasCallStack
+ => (HasCallStack => Eff es i)
+ -- ^ The action for input generation.
+ -> Eff (Input i : es) a
+ -> Eff es a
+runInput inputAction action = unsafeEff $ \es -> do
+ inlineBracket
+ (consEnv (Input es inputImpl) relinkInput es)
+ unconsEnv
+ (unEff action)
+ where
+ inputImpl = InputImpl $ let ?callStack = thawCallStack ?callStack in inputAction
+
+-- | Fetch the value.
+input :: (HasCallStack, Input i :> es) => Eff es i
+input = unsafeEff $ \es -> do
+ Input inputEs (InputImpl inputAction) <- getEnv es
+ -- Corresponds to thawCallStack in runInput.
+ (`unEff` inputEs) $ withFrozenCallStack inputAction
+
+-- | Fetch the result of applying a function to the value.
+--
+-- @'inputs' f ≡ f '<$>' 'input'@
+inputs
+ :: (HasCallStack, Input i :> es)
+ => (i -> a) -- ^ The function to apply to the value.
+ -> Eff es a
+inputs f = f <$> input
+
+----------------------------------------
+-- Helpers
+
+relinkInput :: Relinker StaticRep (Input i)
+relinkInput = Relinker $ \relink (Input inputEs inputAction) -> do
+ newActionEs <- relink inputEs
+ pure $ Input newActionEs inputAction
diff --git a/src/Effectful/Internal/Effect.hs b/src/Effectful/Internal/Effect.hs
--- a/src/Effectful/Internal/Effect.hs
+++ b/src/Effectful/Internal/Effect.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK not-home #-}
-- | Type-safe indexing for 'Effectful.Internal.Monad.Env'.
--
@@ -14,7 +13,6 @@
, KnownPrefix(..)
, IsUnknownSuffixOf
, type (++)
- , KnownEffects(..)
-- * Re-exports
, Type
@@ -135,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
diff --git a/src/Effectful/Internal/Effect/Dynamic.hs b/src/Effectful/Internal/Effect/Dynamic.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Internal/Effect/Dynamic.hs
@@ -0,0 +1,99 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+-- | Definitions and instances for MTL compatibility.
+--
+-- This module is intended for internal use only, and may change without warning
+-- in subsequent releases.
+module Effectful.Internal.Effect.Dynamic where
+
+import Control.Monad.Except qualified as MTL
+import Control.Monad.Reader qualified as MTL
+import Control.Monad.State qualified as MTL
+import Control.Monad.Writer qualified as MTL
+import GHC.Stack (CallStack)
+
+import Effectful.Internal.Effect
+import Effectful.Internal.Env
+import Effectful.Internal.Monad
+
+-- | Provide the ability to handle errors of type @e@.
+data Error e :: Effect where
+ -- | @since 2.4.0.0
+ ThrowErrorWith :: (e -> String) -> e -> Error e m a
+ -- | @since 2.7.0.0
+ RethrowErrorWith :: (e -> String) -> CallStack -> e -> Error e m a
+ CatchError :: m a -> (CallStack -> e -> m a) -> Error e m a
+
+type instance DispatchOf (Error e) = Dynamic
+
+-- | Instance included for compatibility with existing code.
+instance
+ ( Show e
+ , Error e :> es
+ , MTL.MonadError e (Eff es)
+ ) => MTL.MonadError e (Eff es) where
+ throwError = send . ThrowErrorWith show
+ catchError action = send . CatchError action . const
+
+----------------------------------------
+
+data Reader r :: Effect where
+ Ask :: Reader r m r
+ Local :: (r -> r) -> m a -> Reader r m a
+
+type instance DispatchOf (Reader r) = Dynamic
+
+-- | Instance included for compatibility with existing code.
+instance
+ ( Reader r :> es
+ , MTL.MonadReader r (Eff es)
+ ) => MTL.MonadReader r (Eff es) where
+ ask = send Ask
+ local f = send . Local f
+ reader f = f <$> send Ask
+
+----------------------------------------
+
+-- | Provide access to a mutable value of type @s@.
+data State s :: Effect where
+ Get :: State s m s
+ Put :: s -> State s m ()
+ State :: (s -> (a, s)) -> State s m a
+ StateM :: (s -> m (a, s)) -> State s m a
+
+{-# DEPRECATED StateM "Use a combination of Get and Put instead." #-}
+
+type instance DispatchOf (State s) = Dynamic
+
+-- | Instance included for compatibility with existing code.
+instance
+ ( State s :> es
+ , MTL.MonadState s (Eff es)
+ ) => MTL.MonadState s (Eff es) where
+ get = send Get
+ put = send . Put
+ state = send . State
+
+----------------------------------------
+
+-- | Provide access to a write only value of type @w@.
+data Writer w :: Effect where
+ Tell :: w -> Writer w m ()
+ Listen :: m a -> Writer w m (a, w)
+
+type instance DispatchOf (Writer w) = Dynamic
+
+-- | Instance included for compatibility with existing code.
+--
+-- /Warning:/ 'MTL.pass' is not implemented due to ambiguous semantics in
+-- presence of runtime exceptions, so calling it (also indirectly via
+-- 'MTL.censor', which is defined in terms of 'MTL.pass') results in a runtime
+-- error.
+instance
+ ( Monoid w
+ , Writer w :> es
+ , MTL.MonadWriter w (Eff es)
+ ) => MTL.MonadWriter w (Eff es) where
+ writer (a, w) = a <$ send (Tell w)
+ tell = send . Tell
+ listen = send . Listen
+ pass = error "pass is not implemented due to ambiguous semantics in presence of runtime exceptions"
diff --git a/src/Effectful/Internal/Env.hs b/src/Effectful/Internal/Env.hs
--- a/src/Effectful/Internal/Env.hs
+++ b/src/Effectful/Internal/Env.hs
@@ -12,7 +12,9 @@
-- ** StorageData
, StorageData(..)
- , copyStorageData
+ , cloneStorage
+ , replaceStorage
+ , backupStorageData
, restoreStorageData
-- *** Utils
@@ -56,10 +58,11 @@
import Control.Monad
import Control.Monad.Primitive
-import Data.IORef.Strict
+import Data.IORef.Strict qualified as S
import Data.Primitive.PrimArray
import Data.Primitive.SmallArray
import Data.Primitive.Types
+import Data.Proxy
import GHC.Exts ((*#), (+#))
import GHC.Stack
@@ -74,7 +77,7 @@
-- __Warning: the environment is a mutable data structure and cannot be simultaneously used from multiple threads under any circumstances.__
--
-- In order to pass it to a different thread, you need to perform a deep copy
--- with the 'cloneEnv' funtion.
+-- with the 'cloneEnv' function.
--
-- Offers very good performance characteristics for most often performed
-- operations:
@@ -92,17 +95,17 @@
-- - Cloning: /@O(N)@/, where @N@ is the size of the 'Storage'.
--
data Env (es :: [Effect]) = Env
- { envOffset :: !Int
- , envRefs :: !(PrimArray Ref)
- , 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
- sizeOf# _ = 2# *# sizeOf# (undefined :: Int)
- alignment# _ = alignment# (undefined :: Int)
+ sizeOfType# _ = 2# *# sizeOfType# (Proxy @Int)
+ alignmentOfType# _ = alignmentOfType# (Proxy @Int)
indexByteArray# arr i =
let n = 2# *# i
ref = indexByteArray# arr n
@@ -118,7 +121,6 @@
s1 = writeByteArray# arr n ref s0
s2 = writeByteArray# arr (n +# 1#) version s1
in s2
- setByteArray# = defaultSetByteArray#
indexOffAddr# addr i =
let n = 2# *# i
ref = indexOffAddr# addr n
@@ -134,7 +136,6 @@
s1 = writeOffAddr# addr n ref s0
s2 = writeOffAddr# addr (n +# 1#) version s1
in s2
- setOffAddr# = defaultSetOffAddr#
-- | Version of the effect.
newtype Version = Version Int
@@ -142,8 +143,8 @@
-- | A storage of effects.
data Storage = Storage
- { stVersion :: !Version
- , stData :: {-# UNPACK #-} !StorageData
+ { version :: !Version
+ , data_ :: {-# UNPACK #-} !StorageData
}
----------------------------------------
@@ -170,12 +171,29 @@
----------------------------------------
data StorageData = StorageData
- { sdSize :: !Int
- , sdVersions :: !(MutablePrimArray RealWorld Version)
- , sdEffects :: !(SmallMutableArray RealWorld AnyEffect)
- , sdRelinkers :: !(SmallMutableArray RealWorld AnyRelinker)
+ { 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
@@ -193,19 +211,81 @@
fs <- cloneSmallMutableArray fs0 0 fsSize
pure $ StorageData storageSize vs es fs
--- | Restore a shallow copy of the 'StorageData'.
+-- | Relink effects in the storage data to the given storage.
--
--- The copy needs to be from the same 'Env' as the target.
+-- @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 newStorageData env = do
- modifyIORef' (envStorage env) $ \(Storage version oldStorageData) ->
- let oldSize = sdSize oldStorageData
- newSize = sdSize newStorageData
- in if newSize /= oldSize
- then error $ "newSize (" ++ show newSize ++ ") /= oldSize (" ++ show oldSize ++ ")"
- else Storage version newStorageData
+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
@@ -248,26 +328,11 @@
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 :: HasCallStack => Env es -> IO (Env es)
-cloneEnv (Env offset refs storage0) = do
- Storage version storageData0 <- readIORef' storage0
- storageData@(StorageData storageSize _ es fs) <- copyStorageData storageData0
- storage <- newIORef' $ Storage version storageData
- let relinkEffects = \case
- 0 -> pure ()
- k -> do
- let i = k - 1
- Relinker relinker <- fromAnyRelinker <$> readSmallArray fs i
- readSmallArray es i
- >>= relinker (relinkEnv storage) . fromAnyEffect
- >>= writeSmallArray' es i . toAnyEffect
- relinkEffects i
- relinkEffects storageSize
- pure $ Env offset refs storage
-{-# NOINLINE cloneEnv #-}
+cloneEnv env = replaceStorage env =<< cloneStorage env.storage
-- | Get the current size of the environment.
sizeEnv :: Env es -> IO Int
@@ -298,22 +363,25 @@
writePrimArray mrefs 0 ref
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 :: HasCallStack => Env (e : es) -> IO ()
-unconsEnv (Env _ refs storage) = do
+unconsEnv (Env offset refs storage) = do
+ when (offset /= 0) $ do
+ error $ "offset (" ++ show offset ++ ") /= 0"
deleteEffect storage (indexPrimArray refs 0)
-{-# NOINLINE unconsEnv #-}
----------------------------------------
-- | Replace a specific effect in the stack with a new value.
--
--- /Note:/ unlike in 'putEnv' the value in not changed in place, so only the new
+-- /Note:/ unlike in 'putEnv' the value is not changed in place, so only the new
-- environment will see it.
replaceEnv
:: forall e es. (HasCallStack, e :> es)
@@ -330,16 +398,19 @@
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. (HasCallStack, e :> es) => Env es -> IO ()
unreplaceEnv (Env offset refs storage) = do
- deleteEffect storage $ indexPrimArray refs (offset + reifyIndex @e @es)
-{-# NOINLINE unreplaceEnv #-}
+ when (offset /= 0) $ do
+ error $ "offset (" ++ show offset ++ ") /= 0"
+ deleteEffect storage $ indexPrimArray refs (reifyIndex @e @es)
----------------------------------------
@@ -352,7 +423,6 @@
writePrimArray mrefs 0 $ indexPrimArray refs0 (offset + reifyIndex @e @es)
refs <- unsafeFreezePrimArray mrefs
pure $ Env 0 refs storage
-{-# NOINLINE subsumeEnv #-}
----------------------------------------
@@ -429,7 +499,7 @@
=> Env es
-> IO (Int, SmallMutableArray RealWorld AnyEffect)
getLocation (Env offset refs storage) = do
- Storage _ (StorageData _ 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
@@ -439,7 +509,7 @@
++ show storageVersion ++ ")\n"
++ "If you're attempting to run an unlifting function outside "
++ "of the scope of effects it captures, have a look at "
- ++ "UnliftingStrategy (SeqForkUnlift)."
+ ++ "UnliftStrategy (SeqForkUnlift)."
pure (ref, es)
where
Ref ref version = indexPrimArray refs (offset + reifyIndex @e @es)
@@ -459,13 +529,13 @@
-- | Insert an effect into the storage and return its reference.
insertEffect
:: HasCallStack
- => IORef' Storage
+ => S.IORef Storage
-> EffectRep (DispatchOf e) e
-- ^ The representation of the effect.
-> Relinker (EffectRep (DispatchOf e)) e
-> IO Ref
insertEffect storage e f = do
- Storage version (StorageData size 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 ++ ")"
@@ -473,29 +543,34 @@
writePrimArray vs0 size version
writeSmallArray' es0 size (toAnyEffect e)
writeSmallArray' fs0 size (toAnyRelinker f)
- writeIORef' storage $
+ 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 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 (toAnyEffect e)
writeSmallArray' fs size (toAnyRelinker f)
- writeIORef' storage $
+ 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 :: HasCallStack => IORef' Storage -> Ref -> IO ()
+deleteEffect :: HasCallStack => S.IORef Storage -> Ref -> IO ()
deleteEffect storage (Ref ref version) = do
- Storage currentVersion (StorageData size vs es fs) <- readIORef' storage
+ Storage currentVersion (StorageData size vs es fs) <- S.readIORef storage
when (ref /= size - 1) $ do
error $ "ref (" ++ show ref ++ ") /= size - 1 (" ++ show (size - 1) ++ ")"
storageVersion <- readPrimArray vs ref
@@ -505,16 +580,19 @@
writePrimArray vs ref undefinedVersion
writeSmallArray es ref undefinedEffect
writeSmallArray fs ref undefinedRelinker
- writeIORef' storage $ Storage currentVersion (StorageData (size - 1) vs es fs)
+ 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
@@ -543,8 +621,3 @@
-- | A strict version of 'writeSmallArray'.
writeSmallArray' :: SmallMutableArray RealWorld a -> Int -> a -> IO ()
writeSmallArray' arr i a = a `seq` writeSmallArray arr i a
-
-#if !MIN_VERSION_primitive(0,9,0)
-getSizeofSmallMutableArray :: SmallMutableArray RealWorld a -> IO Int
-getSizeofSmallMutableArray arr = pure $! sizeofSmallMutableArray arr
-#endif
diff --git a/src/Effectful/Internal/Monad.hs b/src/Effectful/Internal/Monad.hs
--- a/src/Effectful/Internal/Monad.hs
+++ b/src/Effectful/Internal/Monad.hs
@@ -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,23 @@
, 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
@@ -163,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
@@ -203,20 +207,6 @@
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
- -> ((forall r. Eff es r -> IO r) -> IO a)
- -- ^ Continuation with the unlifting function in scope.
- -> Eff es a
-withConcEffToIO persistence limit k = unsafeEff $ \es ->
- concUnliftIO es persistence limit k
-{-# DEPRECATED withConcEffToIO "Use withEffToIO with the appropriate strategy." #-}
-
-- | Create an unlifting function with the 'SeqUnlift' strategy.
seqUnliftIO
:: HasCallStack
@@ -229,7 +219,7 @@
tid0 <- myThreadId
k $ \m -> do
tid <- myThreadId
- if tid `eqThreadId` tid0
+ if tid == tid0
then unEff m es
else error
$ "If you want to use the unlifting function to run Eff computations "
@@ -256,11 +246,118 @@
-> ((forall r. Eff es r -> IO r) -> IO a)
-- ^ Continuation with the unlifting function in scope.
-> IO a
-concUnliftIO es Ephemeral (Limited uses) = ephemeralConcUnlift es uses
-concUnliftIO es Ephemeral Unlimited = ephemeralConcUnlift es maxBound
-concUnliftIO es Persistent (Limited threads) = persistentConcUnlift es False threads
-concUnliftIO es Persistent Unlimited = persistentConcUnlift es True maxBound
+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
@@ -276,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
@@ -290,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
@@ -308,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
@@ -418,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
@@ -502,21 +656,37 @@
----------------------------------------
-- 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 :: 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
@@ -558,7 +728,7 @@
-> Eff es a
send op = unsafeEff $ \es -> do
Handler handlerEs (HandlerImpl handler) <- getEnv es
- when (envStorage es /= envStorage handlerEs) $ do
+ 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
diff --git a/src/Effectful/Internal/Unlift.hs b/src/Effectful/Internal/Unlift.hs
--- a/src/Effectful/Internal/Unlift.hs
+++ b/src/Effectful/Internal/Unlift.hs
@@ -13,15 +13,19 @@
, Limit(..)
-- * Unlifting functions
- , ephemeralConcUnlift
+ , ephemeralConcLimitedUnlift
+ , ephemeralConcUnlimitedUnlift
, persistentConcUnlift
+ , persistentConcSingleUnlift
+ , persistentConcUnlifts
+ , persistentConcSingleUnlifts
) where
import Control.Concurrent
-import Control.Concurrent.MVar.Strict
+import Control.Concurrent.MVar.Strict qualified as S
import Control.Monad
import Data.Coerce
-import Data.IntMap.Strict qualified as IM
+import Data.Word
import GHC.Conc.Sync (ThreadId(..))
import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)
import GHC.Generics (Generic)
@@ -32,6 +36,7 @@
import Effectful.Internal.Env
import Effectful.Internal.Utils
+import Effectful.Internal.Utils.Word64Map qualified as M
----------------------------------------
-- Unlift strategies
@@ -109,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
@@ -140,16 +217,18 @@
----------------------------------------
-- Unlift functions
--- | Concurrent unlift that doesn't preserve the environment between calls to
--- the unlifting function in threads other than its creator.
-ephemeralConcUnlift
- :: (HasCallStack, forall r. Coercible (m r) (Env es -> IO r))
+-- | 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)
+ -> ((forall r. effEs r -> IO r) -> IO a)
-> IO a
-ephemeralConcUnlift es0 uses k = do
+ephemeralConcLimitedUnlift es0 uses k = do
unless (uses > 0) $ do
error $ "Invalid number of uses: " ++ show uses
tid0 <- myThreadId
@@ -157,31 +236,51 @@
-- 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)
- coerce 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, forall r. Coercible (m r) (Env es -> IO r))
+ :: (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)
+ -> ((forall r. effEs r -> IO r) -> IO a)
-> IO a
persistentConcUnlift es0 cleanUp threads k = do
unless (threads > 0) $ do
@@ -191,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)
- coerce 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 newtype 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
+ }
diff --git a/src/Effectful/Internal/Utils.hs b/src/Effectful/Internal/Utils.hs
--- a/src/Effectful/Internal/Utils.hs
+++ b/src/Effectful/Internal/Utils.hs
@@ -7,7 +7,6 @@
-- * Utils for 'ThreadId'
, weakThreadId
- , eqThreadId
-- * Utils for 'Any'
, Any
@@ -18,12 +17,16 @@
, Unique
, newUnique
- -- * CallStack
+ -- * CallStack
, thawCallStack
+
+ -- * Array capacity
+ , growCapacity
) where
import Control.Exception
import Data.Primitive.ByteArray
+import Data.Word
import GHC.Conc.Sync (ThreadId(..))
import GHC.Exts (Any, RealWorld)
import GHC.Stack.Types (CallStack(..))
@@ -33,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
@@ -53,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
@@ -84,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
@@ -125,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
diff --git a/src/Effectful/Internal/Utils/Word64Map.hs b/src/Effectful/Internal/Utils/Word64Map.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Internal/Utils/Word64Map.hs
@@ -0,0 +1,162 @@
+{-# LANGUAGE Strict #-}
+-- | A minimal, strict map keyed by 'Word64' values (adaptation of
+-- 'Data.IntMap.Strict').
+--
+-- This module is intended for internal use only, and may change without warning
+-- in subsequent releases.
+module Effectful.Internal.Utils.Word64Map
+ ( Word64Map
+ , empty
+ , lookup
+ , insert
+ , delete
+ , updateLookupWithKey
+ ) where
+
+import Data.Bits
+import Data.Word
+import Prelude hiding (lookup)
+
+-- | A map of 'Word64' keys to values of type @a@.
+data Word64Map a
+ = Bin Prefix (Word64Map a) (Word64Map a)
+ | Tip Word64 a
+ | Nil
+
+-- | A @Prefix@ represents some prefix of high-order bits of a @Word64@.
+newtype Prefix = Prefix Word64
+
+unPrefix :: Prefix -> Word64
+unPrefix (Prefix p) = p
+
+----------------------------------------
+
+-- | The empty map.
+empty :: Word64Map a
+empty = Nil
+
+-- | Look up the value at a key in the map.
+lookup :: Word64 -> Word64Map a -> Maybe a
+lookup k = go
+ where
+ go (Bin p l r) | left k p = go l
+ | otherwise = go r
+ go (Tip kx x) | k == kx = Just x
+ | otherwise = Nothing
+ go Nil = Nothing
+
+-- | Insert a new key/value pair in the map. If the key is already present, the
+-- associated value is replaced with the supplied one.
+--
+-- The value is evaluated to WHNF when it is inserted into the map.
+insert :: Word64 -> a -> Word64Map a -> Word64Map a
+insert k x = go
+ where
+ go t@(Bin p l r)
+ | nomatch k p = linkKey k (Tip k x) p t
+ | left k p = Bin p (go l) r
+ | otherwise = Bin p l (go r)
+ go t@(Tip ky _)
+ | k == ky = Tip k x
+ | otherwise = link k (Tip k x) ky t
+ go Nil = Tip k x
+
+-- | Delete a key and its value from the map. When the key is not a member of
+-- the map, the original map is returned.
+delete :: Word64 -> Word64Map a -> Word64Map a
+delete k = go
+ where
+ go t@(Bin p l r)
+ | nomatch k p = t
+ | left k p = binCheckLeft p (go l) r
+ | otherwise = binCheckRight p l (go r)
+ go t@(Tip ky _)
+ | k == ky = Nil
+ | otherwise = t
+ go Nil = Nil
+
+-- | Look up and update the value at a key in the map. The function returns the
+-- original value, if it exists, and the updated map.
+--
+-- The updated value is evaluated to WHNF when it is inserted into the map.
+updateLookupWithKey
+ :: (Word64 -> a -> Maybe a)
+ -> Word64
+ -> Word64Map a
+ -> (Maybe a, Word64Map a)
+updateLookupWithKey f k = go
+ where
+ go t@(Bin p l r)
+ | nomatch k p = (Nothing, t)
+ | left k p = let (found, l') = go l in (found, binCheckLeft p l' r)
+ | otherwise = let (found, r') = go r in (found, binCheckRight p l r')
+ go t@(Tip ky y)
+ | k == ky = case f ky y of
+ Just y' -> (Just y, Tip ky y')
+ Nothing -> (Just y, Nil)
+ | otherwise = (Nothing, t)
+ go Nil = (Nothing, Nil)
+
+----------------------------------------
+-- Internal helpers
+
+-- | Whether the @Word64@ does not start with the given @Prefix@.
+--
+-- A @Word64@ starts with a @Prefix@ if it shares the high bits with the
+-- internal @Word64@ value of the @Prefix@ up to the mask bit.
+--
+-- @nomatch@ is usually used to determine whether a key belongs in a @Bin@,
+-- since all keys in a @Bin@ share a @Prefix@.
+nomatch :: Word64 -> Prefix -> Bool
+nomatch i (Prefix p) = (i `xor` p) .&. prefixMask /= 0
+ where
+ prefixMask = p `xor` (-p)
+
+-- | Whether the @Word64@ is to the left of the split created by a @Bin@ with
+-- this @Prefix@.
+--
+-- This does not imply that the @Word64@ belongs in this @Bin@. That fact is
+-- usually determined first using @nomatch@.
+left :: Word64 -> Prefix -> Bool
+left i p = i < unPrefix p
+
+-- | Link two @Word64Map@s. The maps must not be empty. The @Prefix@es of the
+-- two maps must be different. @k1@ must share the prefix of @t1@. @p2@ must be
+-- the prefix of @t2@.
+linkKey :: Word64 -> Word64Map a -> Prefix -> Word64Map a -> Word64Map a
+linkKey k1 t1 p2 t2 = link k1 t1 (unPrefix p2) t2
+
+-- | Link two @Word64Map@s. The maps must not be empty. The @Prefix@es of the
+-- two maps must be different. @k1@ must share the prefix of @t1@ and @k2@ must
+-- share the prefix of @t2@.
+link :: Word64 -> Word64Map a -> Word64 -> Word64Map a -> Word64Map a
+link k1 t1 k2 t2 = linkWithMask (branchMask k1 k2) k1 t1 k2 t2
+
+-- `linkWithMask` is useful when the `branchMask` has already been computed
+linkWithMask :: Word64 -> Word64 -> Word64Map a -> Word64 -> Word64Map a -> Word64Map a
+linkWithMask m k1 t1 k2 t2
+ | k1 < k2 = Bin p t1 t2
+ | otherwise = Bin p t2 t1
+ where
+ p = Prefix (mask k1 m .|. m)
+
+-- | The prefix of key @i@ up to (but not including) the switching bit @m@.
+mask :: Word64 -> Word64 -> Word64
+mask i m = i .&. (m `xor` (-m))
+
+-- | The first switching bit where the two prefixes disagree.
+--
+-- Precondition for defined behavior: p1 /= p2.
+branchMask :: Word64 -> Word64 -> Word64
+branchMask k1 k2 =
+ unsafeShiftL 1 (finiteBitSize (0 :: Word64) - 1 - countLeadingZeros (k1 `xor` k2))
+
+-- | Smart constructor that collapses an empty left subtree.
+binCheckLeft :: Prefix -> Word64Map a -> Word64Map a -> Word64Map a
+binCheckLeft _ Nil r = r
+binCheckLeft p l r = Bin p l r
+
+-- | Smart constructor that collapses an empty right subtree.
+binCheckRight :: Prefix -> Word64Map a -> Word64Map a -> Word64Map a
+binCheckRight _ l Nil = l
+binCheckRight p l r = Bin p l r
diff --git a/src/Effectful/Labeled.hs b/src/Effectful/Labeled.hs
--- a/src/Effectful/Labeled.hs
+++ b/src/Effectful/Labeled.hs
@@ -23,6 +23,10 @@
-- | Assign a label to an effect.
--
+-- /Note:/ labeled effects are best used together with the
+-- [effectful-plugin](https://hackage.haskell.org/package/effectful-plugin)
+-- package, as it significantly improves their usability.
+--
-- The constructor is for sending labeled operations of a dynamically dispatched
-- effect to the handler:
--
@@ -39,7 +43,6 @@
-- send $ Labeled @"x" X
-- :}
-- 333
---
newtype Labeled (label :: k) (e :: Effect) :: Effect where
-- | @since 2.4.0.0
Labeled :: forall label e m a. e m a -> Labeled label e m a
diff --git a/src/Effectful/Labeled/Error.hs b/src/Effectful/Labeled/Error.hs
--- a/src/Effectful/Labeled/Error.hs
+++ b/src/Effectful/Labeled/Error.hs
@@ -16,11 +16,15 @@
, throwErrorWith
, throwError
, throwError_
+ , rethrowErrorWith
+ , rethrowError
+ , rethrowError_
, catchError
, handleError
, tryError
-- * Re-exports
+ , Labeled(..)
, E.HasCallStack
, E.CallStack
, E.getCallStack
@@ -104,6 +108,55 @@
-- ^ The error.
-> Eff es a
throwError_ = withFrozenCallStack (throwErrorWith @label) (const "")
+
+-- | Throw an error of type @e@ with the given 'E.CallStack' and specify a
+-- display function in case a third-party code catches the internal exception
+-- and 'show's it.
+--
+-- Useful e.g. when you want to catch an error and rethrow it converted to a
+-- different type without losing the original 'E.CallStack'.
+--
+-- @since 2.7.0.0
+rethrowErrorWith
+ :: forall label e es a
+ . Labeled label (Error e) :> es
+ => (e -> String)
+ -- ^ The display function.
+ -> E.CallStack
+ -- ^ The 'E.CallStack' to attach to the error.
+ -> e
+ -- ^ The error.
+ -> Eff es a
+rethrowErrorWith display cs =
+ send . Labeled @label . RethrowErrorWith display cs
+
+-- | Throw an error of type @e@ with the given 'E.CallStack' and 'show' as a
+-- display function.
+--
+-- @since 2.7.0.0
+rethrowError
+ :: forall label e es a
+ . (Labeled label (Error e) :> es, Show e)
+ => E.CallStack
+ -- ^ The 'E.CallStack' to attach to the error.
+ -> e
+ -- ^ The error.
+ -> Eff es a
+rethrowError = rethrowErrorWith @label show
+
+-- | Throw an error of type @e@ with the given 'E.CallStack' and no display
+-- function.
+--
+-- @since 2.7.0.0
+rethrowError_
+ :: forall label e es a
+ . Labeled label (Error e) :> es
+ => E.CallStack
+ -- ^ The 'E.CallStack' to attach to the error.
+ -> e
+ -- ^ The error.
+ -> Eff es a
+rethrowError_ = rethrowErrorWith @label (const "")
-- | Handle an error of type @e@.
catchError
diff --git a/src/Effectful/Labeled/Input.hs b/src/Effectful/Labeled/Input.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Labeled/Input.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+-- | Convenience functions for the 'Labeled' 'Input' effect.
+--
+-- @since 2.7.0.0
+module Effectful.Labeled.Input
+ ( -- * Effect
+ Input
+
+ -- ** Handlers
+ , runInput
+ , runInputAction
+
+ -- ** Operations
+ , input
+ , inputs
+
+ -- * Re-exports
+ , Labeled(..)
+ ) where
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Labeled
+import Effectful.Input.Dynamic (Input(..))
+import Effectful.Input.Dynamic qualified as I
+
+-- | Run the 'Input' effect with the given value.
+runInput
+ :: forall label i es a
+ . HasCallStack
+ => i
+ -- ^ The input value.
+ -> Eff (Labeled label (Input i) : es) a
+ -> Eff es a
+runInput = runLabeled @label . I.runInput
+
+-- | Run the 'Input' effect with the given action that supplies values.
+runInputAction
+ :: forall label i es a
+ . HasCallStack
+ => (HasCallStack => Eff es i)
+ -- ^ The action for input generation.
+ -> Eff (Labeled label (Input i) : es) a
+ -> Eff es a
+runInputAction = runLabeled @label . I.runInputAction
+
+----------------------------------------
+-- Operations
+
+-- | Fetch the value.
+input
+ :: forall label i es
+ . (HasCallStack, Labeled label (Input i) :> es)
+ => Eff es i
+input = send $ Labeled @label Input
+
+-- | Fetch the result of applying a function to the value.
+--
+-- @'inputs' f ≡ f '<$>' 'input'@
+inputs
+ :: forall label i es a
+ . (HasCallStack, Labeled label (Input i) :> es)
+ => (i -> a) -- ^ The function to apply to the value.
+ -> Eff es a
+inputs f = f <$> input @label
diff --git a/src/Effectful/Labeled/Output.hs b/src/Effectful/Labeled/Output.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Labeled/Output.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+-- | Convenience functions for the 'Labeled' 'Output' effect.
+--
+-- @since 2.7.0.0
+module Effectful.Labeled.Output
+ ( -- * Effect
+ Output(..)
+
+ -- ** Handlers
+ , runOutputAction
+ , runOutputLocalArray
+ , runOutputLocalList
+ , runOutputSharedArray
+ , runOutputSharedList
+
+ -- ** Operations
+ , output
+
+ -- * Re-exports
+ , Labeled(..)
+ , Array
+ ) where
+
+import Data.Primitive.Array
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Labeled
+import Effectful.Output.Dynamic (Output(..))
+import Effectful.Output.Dynamic qualified as O
+
+----------------------------------------
+-- Handlers
+
+-- | Run the 'Output' effect with the given action for receiving values.
+runOutputAction
+ :: forall label o es a
+ . HasCallStack
+ => (HasCallStack => o -> Eff es ())
+ -- ^ The action for output generation.
+ -> Eff (Labeled label (Output o) : es) a
+ -> Eff es a
+runOutputAction = runLabeled @label . O.runOutputAction
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated array (via "Effectful.Output.Static.Local.Array").
+runOutputLocalArray
+ :: forall label o es a
+ . HasCallStack
+ => Eff (Labeled label (Output o) : es) a
+ -> Eff es (a, Array o)
+runOutputLocalArray = runLabeled @label O.runOutputLocalArray
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated list (via "Effectful.Output.Static.Local.List").
+runOutputLocalList
+ :: forall label o es a
+ . HasCallStack
+ => Eff (Labeled label (Output o) : es) a
+ -> Eff es (a, [o])
+runOutputLocalList = runLabeled @label O.runOutputLocalList
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated array (via "Effectful.Output.Static.Shared.Array").
+runOutputSharedArray
+ :: forall label o es a
+ . HasCallStack
+ => Eff (Labeled label (Output o) : es) a
+ -> Eff es (a, Array o)
+runOutputSharedArray = runLabeled @label O.runOutputSharedArray
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated list (via "Effectful.Output.Static.Shared.List").
+runOutputSharedList
+ :: forall label o es a
+ . HasCallStack
+ => Eff (Labeled label (Output o) : es) a
+ -> Eff es (a, [o])
+runOutputSharedList = runLabeled @label O.runOutputSharedList
+
+----------------------------------------
+-- Operations
+
+-- | Feed the value to the underlying handler.
+output
+ :: forall label o es
+ . (HasCallStack, Labeled label (Output o) :> es)
+ => o
+ -> Eff es ()
+output = send . Labeled @label . Output
diff --git a/src/Effectful/Labeled/Provider.hs b/src/Effectful/Labeled/Provider.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Labeled/Provider.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+-- | Convenience functions for the 'Labeled' 'Provider' effect.
+--
+-- @since 2.7.0.0
+module Effectful.Labeled.Provider
+ ( -- * Effect
+ Provider(..)
+ , Provider_
+
+ -- ** Handlers
+ , runProvider
+ , runProvider_
+
+ -- ** Operations
+ , provide
+ , provide_
+ , provideWith
+ , provideWith_
+
+ -- * Re-exports
+ , Labeled(..)
+ ) where
+
+import Data.Coerce
+import Data.Functor.Identity
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Labeled
+import Effectful.Provider (Provider(..), Provider_)
+import Effectful.Provider qualified as P
+
+-- | Run the labeled 'Provider' effect with a given effect handler.
+runProvider
+ :: forall label e input f es a
+ . HasCallStack
+ => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r))
+ -- ^ The effect handler.
+ -> Eff (Labeled label (Provider e input f) : es) a
+ -> Eff es a
+runProvider provider = runLabeled @label (P.runProvider provider)
+
+-- | Run the labeled 'Provider' effect with a given effect handler that doesn't
+-- change its return type.
+runProvider_
+ :: forall label e input es a
+ . HasCallStack
+ => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r)
+ -- ^ The effect handler.
+ -> Eff (Labeled label (Provider_ e input) : es) a
+ -> Eff es a
+runProvider_ provider = runLabeled @label (P.runProvider_ provider)
+
+----------------------------------------
+-- Operations
+
+-- | Run the effect handler.
+provide
+ :: forall label e f es a
+ . (HasCallStack, Labeled label (Provider e () f) :> es)
+ => Eff (e : es) a
+ -> Eff es (f a)
+provide = send . Labeled @label . P.ProvideWith ()
+
+-- | Run the effect handler with unchanged return type.
+provide_
+ :: forall label e es a
+ . (HasCallStack, Labeled label (Provider_ e ()) :> es)
+ => Eff (e : es) a
+ -> Eff es a
+provide_ = dropIdentity . send . Labeled @label . P.ProvideWith ()
+
+-- | Run the effect handler with a given input.
+provideWith
+ :: forall label e input f es a
+ . (HasCallStack, Labeled label (Provider e input f) :> es)
+ => input
+ -- ^ The input to the effect handler.
+ -> Eff (e : es) a
+ -> Eff es (f a)
+provideWith input = send . Labeled @label . P.ProvideWith input
+
+-- | Run the effect handler that doesn't change its return type with a given
+-- input.
+provideWith_
+ :: forall label e input es a
+ . (HasCallStack, Labeled label (Provider_ e input) :> es)
+ => input
+ -- ^ The input to the effect handler.
+ -> Eff (e : es) a
+ -> Eff es a
+provideWith_ input = dropIdentity . send . Labeled @label . P.ProvideWith input
+
+----------------------------------------
+-- Helpers
+
+dropIdentity :: Eff es (Identity a) -> Eff es a
+dropIdentity = coerce
diff --git a/src/Effectful/Labeled/Provider/List.hs b/src/Effectful/Labeled/Provider/List.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Labeled/Provider/List.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+-- | Convenience functions for the 'Labeled' 'ProviderList' effect.
+--
+-- @since 2.7.0.0
+module Effectful.Labeled.Provider.List
+ ( -- * Effect
+ ProviderList(..)
+ , ProviderList_
+
+ -- ** Handlers
+ , runProviderList
+ , runProviderList_
+
+ -- ** Operations
+ , provideList
+ , provideList_
+ , provideListWith
+ , provideListWith_
+
+ -- * Re-exports
+ , Labeled(..)
+ , type (++)
+ , KnownSubset
+ ) where
+
+import Data.Coerce
+import Data.Functor.Identity
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Labeled
+import Effectful.Provider.List (ProviderList(..), ProviderList_)
+import Effectful.Provider.List qualified as P
+
+-- | Run the labeled 'ProviderList' effect with a given handler.
+runProviderList
+ :: forall label providedEs input f es a
+ . (HasCallStack, KnownSubset providedEs (providedEs ++ es))
+ => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r))
+ -- ^ The handler.
+ -> Eff (Labeled label (ProviderList providedEs input f) : es) a
+ -> Eff es a
+runProviderList provider = runLabeled @label (P.runProviderList provider)
+
+-- | Run the labeled 'ProviderList' effect with a given handler that doesn't
+-- change its return type.
+runProviderList_
+ :: forall label providedEs input es a
+ . (HasCallStack, KnownSubset providedEs (providedEs ++ es))
+ => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r)
+ -- ^ The handler.
+ -> Eff (Labeled label (ProviderList_ providedEs input) : es) a
+ -> Eff es a
+runProviderList_ provider = runLabeled @label (P.runProviderList_ provider)
+
+----------------------------------------
+-- Operations
+
+-- | Run the handler.
+provideList
+ :: forall label providedEs f es a
+ . (HasCallStack, Labeled label (ProviderList providedEs () f) :> es)
+ => Eff (providedEs ++ es) a
+ -> Eff es (f a)
+provideList = send . Labeled @label . P.ProvideListWith @providedEs ()
+
+-- | Run the handler with unchanged return type.
+provideList_
+ :: forall label providedEs es a
+ . (HasCallStack, Labeled label (ProviderList_ providedEs ()) :> es)
+ => Eff (providedEs ++ es) a
+ -> Eff es a
+provideList_ = dropIdentity . send . Labeled @label . P.ProvideListWith @providedEs ()
+
+-- | Run the handler with a given input.
+provideListWith
+ :: forall label providedEs input f es a
+ . (HasCallStack, Labeled label (ProviderList providedEs input f) :> es)
+ => input
+ -- ^ The input to the handler.
+ -> Eff (providedEs ++ es) a
+ -> Eff es (f a)
+provideListWith input = send . Labeled @label . P.ProvideListWith @providedEs input
+
+-- | Run the handler that doesn't change its return type with a given input.
+provideListWith_
+ :: forall label providedEs input es a
+ . (HasCallStack, Labeled label (ProviderList_ providedEs input) :> es)
+ => input
+ -- ^ The input to the handler.
+ -> Eff (providedEs ++ es) a
+ -> Eff es a
+provideListWith_ input =
+ dropIdentity . send . Labeled @label . P.ProvideListWith @providedEs input
+
+----------------------------------------
+-- Helpers
+
+dropIdentity :: Eff es (Identity a) -> Eff es a
+dropIdentity = coerce
diff --git a/src/Effectful/Labeled/Reader.hs b/src/Effectful/Labeled/Reader.hs
--- a/src/Effectful/Labeled/Reader.hs
+++ b/src/Effectful/Labeled/Reader.hs
@@ -13,6 +13,9 @@
, ask
, asks
, local
+
+ -- * Re-exports
+ , Labeled(..)
) where
import Effectful
diff --git a/src/Effectful/Labeled/ReturnWith.hs b/src/Effectful/Labeled/ReturnWith.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Labeled/ReturnWith.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+-- | Convenience functions for the 'Labeled' 'ReturnWith' effect.
+--
+-- @since 2.7.0.0
+module Effectful.Labeled.ReturnWith
+ ( -- * Effect
+ ReturnWith(..)
+
+ -- ** Handlers
+ , runReturnWith
+
+ -- ** Operations
+ , returnWith
+
+ -- * Re-exports
+ , Labeled(..)
+ ) where
+
+import GHC.Stack (withFrozenCallStack)
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Labeled
+import Effectful.ReturnWith.Dynamic (ReturnWith(..))
+import Effectful.ReturnWith.Dynamic qualified as R
+
+-- | Run a computation that can return early with a value of type @r@ (via
+-- "Effectful.ReturnWith.Static").
+runReturnWith
+ :: forall label r es
+ . HasCallStack
+ => Eff (Labeled label (ReturnWith r) : es) r
+ -> Eff es r
+runReturnWith = runLabeled @label R.runReturnWith
+
+-- | Return early with the given value.
+returnWith
+ :: forall label r es a
+ . (HasCallStack, Labeled label (ReturnWith r) :> es)
+ => r
+ -- ^ The value.
+ -> Eff es a
+returnWith = withFrozenCallStack send . Labeled @label . ReturnWith
diff --git a/src/Effectful/Labeled/State.hs b/src/Effectful/Labeled/State.hs
--- a/src/Effectful/Labeled/State.hs
+++ b/src/Effectful/Labeled/State.hs
@@ -1,4 +1,7 @@
{-# 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
@@ -26,6 +29,9 @@
, modify
, stateM
, modifyM
+
+ -- * Re-exports
+ , Labeled(..)
) where
import Effectful
@@ -175,3 +181,6 @@
-- ^ .
-> Eff es ()
modifyM f = stateM @label (\s -> ((), ) <$> f s)
+
+{-# DEPRECATED stateM, modifyM
+ "Use a combination of get and put instead." #-}
diff --git a/src/Effectful/Labeled/Writer.hs b/src/Effectful/Labeled/Writer.hs
--- a/src/Effectful/Labeled/Writer.hs
+++ b/src/Effectful/Labeled/Writer.hs
@@ -20,6 +20,9 @@
, tell
, listen
, listens
+
+ -- * Re-exports
+ , Labeled(..)
) where
import Effectful
diff --git a/src/Effectful/NonDet.hs b/src/Effectful/NonDet.hs
--- a/src/Effectful/NonDet.hs
+++ b/src/Effectful/NonDet.hs
@@ -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(..)
@@ -22,14 +26,12 @@
) where
import Control.Applicative
-import Data.IORef.Strict
import GHC.Generics
import GHC.Stack
import Effectful
import Effectful.Dispatch.Dynamic
import Effectful.Dispatch.Static
-import Effectful.Dispatch.Static.Primitive
import Effectful.Error.Static
import Effectful.Internal.Env qualified as I
import Effectful.Internal.Monad (NonDet(..))
@@ -47,6 +49,16 @@
| 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)
@@ -85,7 +97,7 @@
runNonDetRollback = reinterpret setup $ \env -> \case
Empty -> throwError ErrorEmpty
m1 :<|>: m2 -> do
- backupData <- unsafeEff backupStorageData
+ backupData <- unsafeEff I.backupStorageData
localSeqUnlift env $ \unlift -> do
mr <- (Just <$> unlift m1) `catchError` \_ ErrorEmpty -> do
-- If m1 failed, restore the data.
@@ -96,7 +108,7 @@
Nothing -> unlift m2
where
setup action = do
- backupData <- unsafeEff backupStorageData
+ backupData <- unsafeEff I.backupStorageData
runError @ErrorEmpty action >>= \case
Right r -> pure $ Right r
Left (cs, _) -> do
@@ -139,6 +151,3 @@
noError :: Either (cs, e) a -> Either cs a
noError = either (Left . fst) Right
-
-backupStorageData :: HasCallStack => Env es -> IO I.StorageData
-backupStorageData env = I.copyStorageData . I.stData =<< readIORef' (I.envStorage env)
diff --git a/src/Effectful/Output/Dynamic.hs b/src/Effectful/Output/Dynamic.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Output/Dynamic.hs
@@ -0,0 +1,86 @@
+-- | The dynamically dispatched variant of the 'Output' effect.
+--
+-- /Note:/ unless you plan to change interpretations at runtime, it's
+-- recommended to use one of the statically dispatched variants,
+-- i.e. "Effectful.Output.Static.Action", "Effectful.Output.Static.Local.Array",
+-- "Effectful.Output.Static.Local.List", "Effectful.Output.Static.Shared.Array"
+-- or "Effectful.Output.Static.Shared.List".
+--
+-- @since 2.7.0.0
+module Effectful.Output.Dynamic
+ ( -- * Effect
+ Output(..)
+
+ -- ** Handlers
+ , runOutputAction
+ , runOutputLocalArray
+ , runOutputLocalList
+ , runOutputSharedArray
+ , runOutputSharedList
+
+ -- ** Operations
+ , output
+ ) where
+
+import Data.Primitive.Array
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Output.Static.Local.Array qualified as LA
+import Effectful.Output.Static.Local.List qualified as LL
+import Effectful.Output.Static.Shared.Array qualified as SA
+import Effectful.Output.Static.Shared.List qualified as SL
+
+-- | Provide the ability to feed values of type @o@ to a handler.
+data Output o :: Effect where
+ Output :: o -> Output o m ()
+
+type instance DispatchOf (Output o) = Dynamic
+
+----------------------------------------
+-- Handlers
+
+-- | Run the 'Output' effect with the given action for receiving values.
+runOutputAction
+ :: forall o es a
+ . HasCallStack
+ => (HasCallStack => o -> Eff es ())
+ -- ^ The action for output generation.
+ -> Eff (Output o : es) a
+ -> Eff es a
+runOutputAction outputAction = interpret_ $ \case
+ Output o -> outputAction $! o
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated array (via "Effectful.Output.Static.Local.Array").
+runOutputLocalArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
+runOutputLocalArray = reinterpret_ LA.runOutput $ \case
+ Output o -> LA.output o
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated list (via "Effectful.Output.Static.Local.List").
+runOutputLocalList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
+runOutputLocalList = reinterpret_ LL.runOutput $ \case
+ Output o -> LL.output o
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated array (via "Effectful.Output.Static.Shared.Array").
+runOutputSharedArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
+runOutputSharedArray = reinterpret_ SA.runOutput $ \case
+ Output o -> SA.output o
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated list (via "Effectful.Output.Static.Shared.List").
+runOutputSharedList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
+runOutputSharedList = reinterpret_ SL.runOutput $ \case
+ Output o -> SL.output o
+
+----------------------------------------
+-- Operations
+
+-- | Feed the value to the underlying handler.
+output
+ :: (HasCallStack, Output o :> es)
+ => o -- ^ The value.
+ -> Eff es ()
+output = send . Output
diff --git a/src/Effectful/Output/Static/Action.hs b/src/Effectful/Output/Static/Action.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Output/Static/Action.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE ImplicitParams #-}
+-- | Support for feeding values of a particular type to a monadic action.
+--
+-- @since 2.7.0.0
+module Effectful.Output.Static.Action
+ ( -- * Effect
+ Output
+
+ -- ** Handlers
+ , runOutput
+
+ -- ** Operations
+ , output
+ ) where
+
+import Data.Kind
+import GHC.Stack
+
+import Effectful
+import Effectful.Dispatch.Static
+import Effectful.Dispatch.Static.Primitive
+import Effectful.Internal.Utils
+
+-- | Provide the ability to feed values of type @o@ to a monadic action.
+data Output (o :: Type) :: Effect
+
+type instance DispatchOf (Output o) = Static NoSideEffects
+
+-- | Wrapper to prevent a space leak on reconstruction of 'Output' in
+-- 'relinkOutput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).
+newtype OutputImpl o es where
+ OutputImpl :: (HasCallStack => o -> Eff es ()) -> OutputImpl o es
+
+data instance StaticRep (Output o) where
+ Output
+ :: !(Env actionEs)
+ -> !(OutputImpl o actionEs)
+ -> StaticRep (Output o)
+
+-- | Run the 'Output' effect with the given action for receiving values.
+runOutput
+ :: forall o es a
+ . HasCallStack
+ => (HasCallStack => o -> Eff es ())
+ -- ^ The action for receiving values.
+ -> Eff (Output o : es) a
+ -> Eff es a
+runOutput outputAction action = unsafeEff $ \es -> do
+ inlineBracket
+ (consEnv (Output es outputImpl) relinkOutput es)
+ unconsEnv
+ (unEff action)
+ where
+ outputImpl = OutputImpl $ let ?callStack = thawCallStack ?callStack in outputAction
+
+-- | Feed the value to the underlying monadic action.
+output
+ :: (HasCallStack, Output o :> es)
+ => o -- ^ The value.
+ -> Eff es ()
+output !o = unsafeEff $ \es -> do
+ Output actionEs (OutputImpl outputAction) <- getEnv es
+ -- Corresponds to thawCallStack in runOutput.
+ (`unEff` actionEs) $ withFrozenCallStack outputAction o
+
+----------------------------------------
+-- Helpers
+
+relinkOutput :: Relinker StaticRep (Output o)
+relinkOutput = Relinker $ \relink (Output actionEs outputAction) -> do
+ newActionEs <- relink actionEs
+ pure $ Output newActionEs outputAction
diff --git a/src/Effectful/Output/Static/Local/Array.hs b/src/Effectful/Output/Static/Local/Array.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Output/Static/Local/Array.hs
@@ -0,0 +1,79 @@
+-- | Support for accumulation of values in a thread local array.
+--
+-- @since 2.7.0.0
+module Effectful.Output.Static.Local.Array
+ ( -- * Effect
+ Output
+
+ -- ** Handlers
+ , runOutput
+
+ -- ** Operations
+ , output
+
+ -- * Re-exports
+ , Array
+ ) where
+
+import Control.Monad.Primitive
+import Data.Kind
+import Data.Primitive.Array
+
+import Effectful
+import Effectful.Dispatch.Static
+import Effectful.Dispatch.Static.Primitive
+import Effectful.Internal.Utils
+
+-- | Provide access to accumulation of values of type @o@ in a thread local
+-- array.
+data Output (o :: Type) :: Effect
+
+type instance DispatchOf (Output o) = Static NoSideEffects
+data instance StaticRep (Output o) = Output !Int !(MutableArray RealWorld o)
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated array.
+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
+runOutput = runOutputImpl $ \(Output size arr) -> do
+ freezeArray arr 0 size
+
+-- | Append the value to the end of the array.
+output
+ :: (HasCallStack, Output o :> es)
+ => o -- ^ The value.
+ -> Eff es ()
+output !o = unsafeEff $ \es -> do
+ Output size arr0 <- getEnv es
+ let len0 = sizeofMutableArray arr0
+ arr <- case size `compare` len0 of
+ GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"
+ LT -> pure arr0
+ EQ -> do
+ let len = growCapacity len0
+ arr <- newArray len undefinedValue
+ copyMutableArray arr 0 arr0 0 size
+ pure arr
+ writeArray arr size o
+ putEnv es $ Output (size + 1) arr
+
+----------------------------------------
+-- Helpers
+
+runOutputImpl
+ :: HasCallStack
+ => (StaticRep (Output o) -> IO acc)
+ -> Eff (Output o : es) a
+ -> Eff es (a, acc)
+runOutputImpl f action = unsafeEff $ \es0 -> do
+ arr <- newArray 0 undefinedValue
+ inlineBracket
+ (consEnv (Output 0 arr) relinkOutput es0)
+ unconsEnv
+ (\es -> (,) <$> unEff action es <*> (f =<< getEnv es))
+ where
+ relinkOutput = Relinker $ \_ (Output size arr0) -> do
+ arr <- cloneMutableArray arr0 0 (sizeofMutableArray arr0)
+ pure $ Output size arr
+
+undefinedValue :: HasCallStack => a
+undefinedValue = error "Undefined value"
diff --git a/src/Effectful/Output/Static/Local/List.hs b/src/Effectful/Output/Static/Local/List.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Output/Static/Local/List.hs
@@ -0,0 +1,39 @@
+-- | Support for accumulation of values in a thread local list.
+--
+-- @since 2.7.0.0
+module Effectful.Output.Static.Local.List
+ ( -- * Effect
+ Output
+
+ -- ** Handlers
+ , runOutput
+
+ -- ** Operations
+ , output
+ ) where
+
+import Data.Kind
+
+import Effectful
+import Effectful.Dispatch.Static
+
+-- | Provide access to accumulation of values of type @o@ in a thread local
+-- list.
+data Output (o :: Type) :: Effect
+
+type instance DispatchOf (Output o) = Static NoSideEffects
+newtype instance StaticRep (Output o) = Output [o]
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated list.
+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
+runOutput action = do
+ (a, Output acc) <- runStaticRep (Output []) action
+ pure (a, reverse acc)
+
+-- | Append the value to the end of the list.
+output
+ :: (HasCallStack, Output o :> es)
+ => o -- ^ The value.
+ -> Eff es ()
+output !o = stateStaticRep $ \(Output acc) -> ((), Output (o : acc))
diff --git a/src/Effectful/Output/Static/Shared/Array.hs b/src/Effectful/Output/Static/Shared/Array.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Output/Static/Shared/Array.hs
@@ -0,0 +1,77 @@
+-- | Support for accumulation of values in a shared array.
+--
+-- @since 2.7.0.0
+module Effectful.Output.Static.Shared.Array
+ ( -- * Effect
+ Output
+
+ -- ** Handlers
+ , runOutput
+
+ -- ** Operations
+ , output
+
+ -- * Re-exports
+ , Array
+ ) where
+
+import Control.Concurrent.MVar.Strict qualified as S
+import Control.Monad.Primitive
+import Data.Kind
+import Data.Primitive.Array
+
+import Effectful
+import Effectful.Dispatch.Static
+import Effectful.Dispatch.Static.Primitive
+import Effectful.Internal.Utils
+
+-- | Provide access to accumulation of values of type @o@ in a shared array.
+data Output (o :: Type) :: Effect
+
+data OutputData o = OutputData !Int !(MutableArray RealWorld o)
+
+type instance DispatchOf (Output o) = Static NoSideEffects
+newtype instance StaticRep (Output o) = Output (S.MVar (OutputData o))
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated array.
+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)
+runOutput = runOutputImpl $ \(OutputData size arr) -> do
+ freezeArray arr 0 size
+
+-- | Append the value to the end of the array.
+output
+ :: (HasCallStack, Output o :> es)
+ => o -- ^ The value.
+ -> Eff es ()
+output !o = unsafeEff $ \es -> do
+ Output v <- getEnv es
+ S.modifyMVar_ v $ \(OutputData size arr0) -> do
+ let len0 = sizeofMutableArray arr0
+ arr <- case size `compare` len0 of
+ GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"
+ LT -> pure arr0
+ EQ -> do
+ let len = growCapacity len0
+ arr <- newArray len undefinedValue
+ copyMutableArray arr 0 arr0 0 size
+ pure arr
+ writeArray arr size o
+ pure $ OutputData (size + 1) arr
+
+----------------------------------------
+-- Helpers
+
+runOutputImpl
+ :: HasCallStack
+ => (OutputData o -> IO acc)
+ -> Eff (Output o : es) a
+ -> Eff es (a, acc)
+runOutputImpl f action = do
+ v <- unsafeEff_ $ S.newMVar . OutputData 0 =<< newArray 0 undefinedValue
+ a <- evalStaticRep (Output v) action
+ acc <- unsafeEff_ $ f =<< S.readMVar v
+ pure (a, acc)
+
+undefinedValue :: HasCallStack => a
+undefinedValue = error "Undefined value"
diff --git a/src/Effectful/Output/Static/Shared/List.hs b/src/Effectful/Output/Static/Shared/List.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/Output/Static/Shared/List.hs
@@ -0,0 +1,43 @@
+-- | Support for accumulation of values in a shared list.
+--
+-- @since 2.7.0.0
+module Effectful.Output.Static.Shared.List
+ ( -- * Effect
+ Output
+
+ -- ** Handlers
+ , runOutput
+
+ -- ** Operations
+ , output
+ ) where
+
+import Control.Concurrent.MVar.Strict qualified as S
+import Data.Kind
+
+import Effectful
+import Effectful.Dispatch.Static
+import Effectful.Dispatch.Static.Primitive
+
+-- | Provide access to accumulation of values of type @o@ in a shared list.
+data Output (o :: Type) :: Effect
+
+type instance DispatchOf (Output o) = Static NoSideEffects
+newtype instance StaticRep (Output o) = Output (S.MVar [o])
+
+-- | Run the 'Output' effect and return the final value along with the
+-- accumulated list.
+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])
+runOutput action = do
+ v <- unsafeEff_ $ S.newMVar []
+ a <- evalStaticRep (Output v) action
+ (a, ) . reverse <$> unsafeEff_ (S.readMVar v)
+
+-- | Append the value to the end of the list.
+output
+ :: (HasCallStack, Output o :> es)
+ => o -- ^ The value.
+ -> Eff es ()
+output !o = unsafeEff $ \es -> do
+ Output v <- getEnv es
+ S.modifyMVar_ v $ \acc -> pure (o : acc)
diff --git a/src/Effectful/Provider.hs b/src/Effectful/Provider.hs
--- a/src/Effectful/Provider.hs
+++ b/src/Effectful/Provider.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE ImplicitParams #-}
-- | Turn an effect handler into an effectful operation.
--
-- @since 2.3.0.0
@@ -7,7 +6,7 @@
-- $example
-- * Effect
- Provider
+ Provider(..)
, Provider_
-- ** Handlers
@@ -21,18 +20,13 @@
, 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
--
@@ -110,61 +104,83 @@
-- $ 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
-
--- | Wrapper to prevent a space leak on reconstruction of 'Provider' in
--- 'relinkProvider' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).
-newtype ProviderImpl input f e es where
- ProviderImpl
- :: (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r))
- -> ProviderImpl input f e es
-
-data instance StaticRep (Provider e input f) where
- Provider
- :: !(Env handlerEs)
- -> !(ProviderImpl input f e handlerEs)
- -> StaticRep (Provider e input f)
+type instance DispatchOf (Provider e input f) = Dynamic
-- | Run the 'Provider' effect with a given effect handler.
runProvider
- :: HasCallStack
+ :: forall e input f es a
+ . HasCallStack
=> (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r))
-- ^ The effect handler.
-> Eff (Provider e input f : es) a
-> Eff es a
-runProvider provider action = runProviderImpl action $
- ProviderImpl (let ?callStack = thawCallStack ?callStack in provider)
+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_
- :: HasCallStack
+ :: forall e input es a
+ . HasCallStack
=> (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r)
-- ^ The effect handler.
-> Eff (Provider_ e input : es) a
-> Eff es a
-runProvider_ provider action = runProviderImpl action $
- ProviderImpl $ let ?callStack = thawCallStack ?callStack
- in \input -> coerce . provider 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 :: (HasCallStack, Provider e () f :> es) => Eff (e : es) a -> Eff es (f a)
-provide = provideWith ()
+provide = send . ProvideWith ()
-- | Run the effect handler with unchanged return type.
provide_ :: (HasCallStack, Provider_ e () :> es) => Eff (e : es) a -> Eff es a
-provide_ = provideWith_ ()
+provide_ = dropIdentity . send . ProvideWith ()
-- | Run the effect handler with a given input.
provideWith
@@ -173,13 +189,7 @@
-- ^ The input to the effect handler.
-> Eff (e : es) a
-> Eff es (f a)
-provideWith input action = unsafeEff $ \es -> do
- Provider handlerEs (ProviderImpl handler) <- getEnv es
- (`unEff` handlerEs)
- -- Corresponds to thawCallStack in runProvider.
- . withFrozenCallStack handler input
- . unsafeEff $ \eProviderEs -> do
- unEff action =<< copyRef eProviderEs es
+provideWith input = send . ProvideWith input
-- | Run the effect handler that doesn't change its return type with a given
-- input.
@@ -189,42 +199,10 @@
-- ^ 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
-runProviderImpl
- :: HasCallStack
- => Eff (Provider e input f : es) a
- -> ProviderImpl input f e es
- -> Eff es a
-runProviderImpl action providerImpl = unsafeEff $ \es -> do
- inlineBracket
- (consEnv (Provider es providerImpl) relinkProvider es)
- unconsEnv
- (unEff action)
-{-# INLINE runProviderImpl #-}
-
-relinkProvider :: Relinker StaticRep (Provider e input f)
-relinkProvider = Relinker $ \relink (Provider handlerEs run) -> do
- newHandlerEs <- relink handlerEs
- pure $ Provider newHandlerEs run
-
-copyRef
- :: HasCallStack
- => Env (e : handlerEs)
- -> Env es
- -> IO (Env (e : es))
-copyRef (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do
- when (hstorage /= storage) $ do
- error "storages do not match"
- let size = sizeofPrimArray refs0 - offset
- mrefs <- newPrimArray (size + 1)
- writePrimArray mrefs 0 $ indexPrimArray hrefs hoffset
- copyPrimArray mrefs 1 refs0 offset size
- refs <- unsafeFreezePrimArray mrefs
- pure $ Env 0 refs storage
+dropIdentity :: Eff es (Identity a) -> Eff es a
+dropIdentity = coerce
diff --git a/src/Effectful/Provider/List.hs b/src/Effectful/Provider/List.hs
--- a/src/Effectful/Provider/List.hs
+++ b/src/Effectful/Provider/List.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ImplicitParams #-}
-- | Turn a handler of multiple effects into an effectful operation.
--
-- Generalizes "Effectful.Provider".
@@ -7,7 +6,7 @@
-- @since 2.3.1.0
module Effectful.Provider.List
( -- * Effect
- ProviderList
+ ProviderList(..)
, ProviderList_
-- ** Handlers
@@ -22,70 +21,66 @@
-- * 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 @providedEs@ with a given
-- @input@.
--
-- /Note:/ @f@ can be used to alter the return type of the handler. If that's
-- unnecessary, use 'ProviderList_'.
-data ProviderList (providedEs :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect
+data ProviderList (providedEs :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect where
+ -- | Run the effect handlers with a given input.
+ --
+ -- @since 2.7.0.0
+ ProvideListWith
+ :: forall providedEs input f es a
+ . input
+ -> Eff (providedEs ++ es) a
+ -> ProviderList providedEs input f (Eff es) (f a)
-- | A restricted variant of 'ProviderList' with unchanged return type of the
-- handler.
type ProviderList_ providedEs input = ProviderList providedEs input Identity
-type instance DispatchOf (ProviderList providedEs input f) = Static NoSideEffects
-
--- | Wrapper to prevent a space leak on reconstruction of 'ProviderList' in
--- 'relinkProviderList' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).
-newtype ProviderListImpl input f providedEs es where
- ProviderListImpl
- :: (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r))
- -> ProviderListImpl input f providedEs es
-
-data instance StaticRep (ProviderList providedEs input f) where
- ProviderList
- :: KnownEffects providedEs
- => !(Env handlerEs)
- -> !(ProviderListImpl input f providedEs handlerEs)
- -> StaticRep (ProviderList providedEs input f)
+type instance DispatchOf (ProviderList providedEs input f) = Dynamic
-- | Run the 'ProviderList' effect with a given handler.
runProviderList
- :: (HasCallStack, KnownEffects providedEs)
+ :: forall providedEs input f es a
+ . (HasCallStack, KnownSubset providedEs (providedEs ++ es))
=> (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r))
-- ^ The handler.
-> Eff (ProviderList providedEs input f : es) a
-> Eff es a
-runProviderList providerList action = runProviderListImpl action $
- ProviderListImpl (let ?callStack = thawCallStack ?callStack in providerList)
+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_
- :: (HasCallStack, KnownEffects providedEs)
+ :: forall providedEs input es a
+ . (HasCallStack, KnownSubset providedEs (providedEs ++ es))
=> (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r)
-- ^ The handler.
-> Eff (ProviderList_ providedEs input : es) a
-> Eff es a
-runProviderList_ providerList action = runProviderListImpl action $
- ProviderListImpl $ let ?callStack = thawCallStack ?callStack
- in \input -> coerce . providerList 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
@@ -93,7 +88,7 @@
. (HasCallStack, ProviderList providedEs () f :> es)
=> Eff (providedEs ++ es) a
-> Eff es (f a)
-provideList = provideListWith @providedEs ()
+provideList = send . ProvideListWith @providedEs ()
-- | Run the handler with unchanged return type.
provideList_
@@ -101,7 +96,7 @@
. (HasCallStack, ProviderList_ providedEs () :> es)
=> Eff (providedEs ++ es) a
-> Eff es a
-provideList_ = provideListWith_ @providedEs ()
+provideList_ = dropIdentity . send . ProvideListWith @providedEs ()
-- | Run the handler with a given input.
provideListWith
@@ -111,14 +106,7 @@
-- ^ The input to the handler.
-> Eff (providedEs ++ es) a
-> Eff es (f a)
-provideListWith input action = unsafeEff $ \es -> do
- ProviderList (handlerEs :: Env handlerEs) (ProviderListImpl providerList) <- do
- getEnv @(ProviderList providedEs input f) es
- (`unEff` handlerEs)
- -- Corresponds to a thawCallStack in runProviderList.
- . withFrozenCallStack providerList input
- . unsafeEff $ \eHandlerEs -> do
- unEff action =<< copyRefs @providedEs @handlerEs eHandlerEs es
+provideListWith input = send . ProvideListWith @providedEs input
-- | Run the handler that doesn't change its return type with a given input.
provideListWith_
@@ -128,44 +116,10 @@
-- ^ The input to the handler.
-> Eff (providedEs ++ es) a
-> Eff es a
-provideListWith_ input = adapt . provideListWith @providedEs input
- where
- adapt :: Eff es (Identity a) -> Eff es a
- adapt = coerce
+provideListWith_ input = dropIdentity . send . ProvideListWith @providedEs input
----------------------------------------
-- Helpers
-runProviderListImpl
- :: (HasCallStack, KnownEffects providedEs)
- => Eff (ProviderList providedEs input f : es) a
- -> ProviderListImpl input f providedEs es
- -> Eff es a
-runProviderListImpl action providerListImpl = unsafeEff $ \es -> do
- inlineBracket
- (consEnv (ProviderList es providerListImpl) relinkProviderList es)
- unconsEnv
- (unEff action)
-{-# INLINE runProviderListImpl #-}
-
-relinkProviderList :: Relinker StaticRep (ProviderList e input f)
-relinkProviderList = Relinker $ \relink (ProviderList handlerEs run) -> do
- newHandlerEs <- relink handlerEs
- pure $ ProviderList newHandlerEs run
-
-copyRefs
- :: forall providedEs handlerEs es
- . (HasCallStack, KnownEffects providedEs)
- => Env (providedEs ++ handlerEs)
- -> Env es
- -> IO (Env (providedEs ++ es))
-copyRefs (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do
- when (hstorage /= storage) $ do
- error "storages do not match"
- let providedEsSize = knownEffectsLength @providedEs
- esSize = sizeofPrimArray refs0 - offset
- mrefs <- newPrimArray (providedEsSize + esSize)
- copyPrimArray mrefs 0 hrefs hoffset providedEsSize
- copyPrimArray mrefs providedEsSize refs0 offset esSize
- refs <- unsafeFreezePrimArray mrefs
- pure $ Env 0 refs storage
+dropIdentity :: Eff es (Identity a) -> Eff es a
+dropIdentity = coerce
diff --git a/src/Effectful/Reader/Dynamic.hs b/src/Effectful/Reader/Dynamic.hs
--- a/src/Effectful/Reader/Dynamic.hs
+++ b/src/Effectful/Reader/Dynamic.hs
@@ -1,7 +1,8 @@
-- | The dynamically dispatched variant of the 'Reader' effect.
--
--- /Note:/ unless you plan to change interpretations at runtime, it's
--- recommended to use the statically dispatched variant,
+-- /Note:/ unless you plan to change interpretations at runtime or you need the
+-- t'Control.Monad.Reader.MonadReader' instance for compatibility with existing
+-- code, it's recommended to use the statically dispatched variant,
-- i.e. "Effectful.Reader.Static".
module Effectful.Reader.Dynamic
( -- * Effect
@@ -19,24 +20,21 @@
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
:: 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.
--
@@ -51,6 +49,7 @@
withReader f m = do
r <- ask
raise $ runReader (f r) m
+{-# DEPRECATED withReader "withReader doesn't work correctly for all potential interpreters" #-}
----------------------------------------
-- Operations
diff --git a/src/Effectful/Reader/Static.hs b/src/Effectful/Reader/Static.hs
--- a/src/Effectful/Reader/Static.hs
+++ b/src/Effectful/Reader/Static.hs
@@ -1,4 +1,8 @@
-- | Support for access to a read only value of a particular type.
+--
+-- /Note:/ strictly speaking the value is not read only because of 'local'. If
+-- you want to ensure that the initial value never changes, use
+-- "Effectful.Input.Static".
module Effectful.Reader.Static
( -- * Effect
Reader
diff --git a/src/Effectful/ReturnWith/Dynamic.hs b/src/Effectful/ReturnWith/Dynamic.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/ReturnWith/Dynamic.hs
@@ -0,0 +1,49 @@
+-- | The dynamically dispatched variant of the 'ReturnWith' effect.
+--
+-- /Note:/ unless you plan to change interpretations at runtime, it's
+-- recommended to use the statically dispatched variant,
+-- i.e. "Effectful.ReturnWith.Static".
+--
+-- All caveats described in "Effectful.ReturnWith.Static" (in particular the
+-- interaction with threads) apply.
+--
+-- @since 2.7.0.0
+module Effectful.ReturnWith.Dynamic
+ ( -- * Effect
+ ReturnWith(..)
+
+ -- ** Handlers
+ , runReturnWith
+
+ -- ** Operations
+ , returnWith
+ ) where
+
+import GHC.Stack (withFrozenCallStack)
+
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.ReturnWith.Static qualified as R
+
+-- | Provide the ability to return early with a value of type @r@.
+data ReturnWith r :: Effect where
+ ReturnWith :: r -> ReturnWith r m a
+
+type instance DispatchOf (ReturnWith r) = Dynamic
+
+-- | Run a computation that can return early with a value of type @r@ (via
+-- "Effectful.ReturnWith.Static").
+runReturnWith
+ :: HasCallStack
+ => Eff (ReturnWith r : es) r
+ -> Eff es r
+runReturnWith = reinterpret_ R.runReturnWith $ \case
+ ReturnWith r -> R.returnWith r
+
+-- | Return early with the given value.
+returnWith
+ :: (HasCallStack, ReturnWith r :> es)
+ => r
+ -- ^ The value.
+ -> Eff es a
+returnWith = withFrozenCallStack send . ReturnWith
diff --git a/src/Effectful/ReturnWith/Static.hs b/src/Effectful/ReturnWith/Static.hs
new file mode 100644
--- /dev/null
+++ b/src/Effectful/ReturnWith/Static.hs
@@ -0,0 +1,112 @@
+-- | Support for early return from a computation.
+--
+-- >>> import Control.Monad (when)
+--
+-- >>> :{
+-- classify :: ReturnWith String :> es => Int -> Eff es String
+-- classify n = do
+-- when (n < 0) $ returnWith "negative"
+-- when (n == 0) $ returnWith "zero"
+-- pure "positive"
+-- :}
+--
+-- >>> runEff . runReturnWith $ classify 5
+-- "positive"
+--
+-- >>> runEff . runReturnWith $ classify (-5)
+-- "negative"
+--
+-- === Interaction with threads
+--
+-- The 'ReturnWith' effect uses runtime exceptions underneath, so the usual
+-- rules apply. In particular, in multi-threaded code a call to 'returnWith' in
+-- a child thread will not automatically propagate to the parent. If you need
+-- that, use functions such as @withAsync@ from the
+-- [Effectful.Concurrent.Async](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent-Async.html)
+-- module of the @effectful@ package (which propagate exceptions from child
+-- threads to their parents) or arrange the propagation yourself.
+--
+-- For more information see the documentation of the
+-- [Concurrent](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent.html#t:Concurrent)
+-- effect.
+--
+-- @since 2.7.0.0
+module Effectful.ReturnWith.Static
+ ( -- * Effect
+ ReturnWith
+
+ -- ** Handlers
+ , runReturnWith
+
+ -- ** Operations
+ , returnWith
+ ) where
+
+import Data.Kind
+import GHC.Stack
+
+import Effectful
+import Effectful.Dispatch.Static
+import Effectful.Exception
+import Effectful.Internal.Utils
+
+-- | Provide the ability to return early with a value of type @r@.
+data ReturnWith (r :: Type) :: Effect
+
+type instance DispatchOf (ReturnWith r) = Static NoSideEffects
+newtype instance StaticRep (ReturnWith r) = ReturnWith ReturnWithId
+
+-- | Run a computation that can return early with a value of type @r@.
+runReturnWith
+ :: forall r es
+ . HasCallStack
+ => Eff (ReturnWith r : es) r
+ -> Eff es r
+runReturnWith action = do
+ rid <- unsafeEff_ newReturnWithId
+ evalStaticRep (ReturnWith @r rid) $ do
+ catchJust (matchReturnWith rid) action pure
+
+-- | Return early with the given value.
+returnWith
+ :: forall r es a. (HasCallStack, ReturnWith r :> es)
+ => r
+ -- ^ The value.
+ -> Eff es a
+returnWith r = do
+ ReturnWith rid <- getStaticRep @(ReturnWith r)
+ withFrozenCallStack throwIO $ ReturnWithWrapper rid callStack (toAny r)
+
+----------------------------------------
+-- Helpers
+
+newtype ReturnWithId = ReturnWithId Unique
+ deriving newtype Eq
+
+-- | A unique is picked so that distinct 'ReturnWith' handlers for the same
+-- type don't catch each other's values.
+newReturnWithId :: IO ReturnWithId
+newReturnWithId = ReturnWithId <$> newUnique
+
+data ReturnWithWrapper = ReturnWithWrapper !ReturnWithId CallStack Any
+
+instance Show ReturnWithWrapper where
+ showsPrec p (ReturnWithWrapper _ cs _)
+ = showParen (p > 10)
+ $ ("Effectful.ReturnWith.Static.ReturnWithWrapper\n" ++)
+ . (prettyCallStack cs ++)
+ . ("\n\nIf you see this message, most likely a call to returnWith " ++)
+ . ("escaped the scope of its handler, e.g. by being made from a thread " ++)
+ . ("that outlived it, or was caught by an overly zealous exception " ++)
+ . ("handler. For more information see the documentation of the " ++)
+ . ("Effectful.ReturnWith.Static module." ++)
+
+instance Exception ReturnWithWrapper where
+ -- See discussion in https://github.com/haskell-effectful/effectful/pull/232.
+ toException = asyncExceptionToException
+ fromException = asyncExceptionFromException
+
+matchReturnWith :: ReturnWithId -> ReturnWithWrapper -> Maybe r
+matchReturnWith rid (ReturnWithWrapper rtag _ r)
+ | rid == rtag = Just (fromAny r)
+ | otherwise = Nothing
diff --git a/src/Effectful/State/Dynamic.hs b/src/Effectful/State/Dynamic.hs
--- a/src/Effectful/State/Dynamic.hs
+++ b/src/Effectful/State/Dynamic.hs
@@ -1,7 +1,11 @@
+-- The handlers need to interpret the deprecated StateM operation until it's
+-- removed.
+{-# OPTIONS_GHC -Wno-deprecations #-}
-- | The dynamically dispatched variant of the 'State' effect.
--
--- /Note:/ unless you plan to change interpretations at runtime, it's
--- recommended to use one of the statically dispatched variants,
+-- /Note:/ unless you plan to change interpretations at runtime or you need the
+-- t'Control.Monad.State.MonadState' instance for compatibility with existing
+-- code, it's recommended to use one of the statically dispatched variants,
-- i.e. "Effectful.State.Static.Local" or "Effectful.State.Static.Shared".
module Effectful.State.Dynamic
( -- * Effect
@@ -31,18 +35,10 @@
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
@@ -149,3 +145,6 @@
=> (s -> Eff es s)
-> Eff es ()
modifyM f = stateM (\s -> ((), ) <$> f s)
+
+{-# DEPRECATED stateM, modifyM
+ "Use a combination of get and put instead." #-}
diff --git a/src/Effectful/State/Static/Local.hs b/src/Effectful/State/Static/Local.hs
--- a/src/Effectful/State/Static/Local.hs
+++ b/src/Effectful/State/Static/Local.hs
@@ -137,3 +137,6 @@
=> (s -> Eff es s) -- ^ The monadic function to modify the state.
-> Eff es ()
modifyM f = stateM (\s -> ((), ) <$> f s)
+
+{-# DEPRECATED stateM, modifyM
+ "State modifications made via operations of the same State effect within the callback are discarded. Use a combination of get and put instead." #-}
diff --git a/src/Effectful/State/Static/Shared.hs b/src/Effectful/State/Static/Shared.hs
--- a/src/Effectful/State/Static/Shared.hs
+++ b/src/Effectful/State/Static/Shared.hs
@@ -1,6 +1,6 @@
-- | Support for access to a shared, mutable value of a particular type.
--
--- The value is shared between multiple threads. If you want each thead to
+-- The value is shared between multiple threads. If you want each thread to
-- manage its own version of the value, use "Effectful.State.Static.Local".
--
-- /Note:/ unlike the 'Control.Monad.Trans.State.StateT' monad transformer from
@@ -47,7 +47,7 @@
, modifyM
) where
-import Control.Concurrent.MVar.Strict
+import Control.Concurrent.MVar.Strict qualified as S
import Data.Kind
import Effectful
@@ -58,55 +58,58 @@
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 :: 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 :: 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 :: 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 :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es (a, s)
+runStateMVar :: HasCallStack => S.MVar s -> Eff (State s : es) a -> Eff es (a, s)
runStateMVar v m = do
a <- evalStaticRep (State v) m
- (a, ) <$> unsafeEff_ (readMVar' v)
+ (a, ) <$> unsafeEff_ (S.readMVar v)
--- | Run the 'State' effect with the given initial state 'MVar'' and return the
+-- | Run the 'State' effect with the given initial state 'S.MVar' and return the
-- final value, discarding the final state.
-evalStateMVar :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es a
+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 :: HasCallStack => MVar' s -> Eff (State s : es) a -> Eff es s
+execStateMVar :: HasCallStack => S.MVar s -> Eff (State s : es) a -> Eff es s
execStateMVar v m = do
_ <- evalStaticRep (State v) m
- unsafeEff_ $ readMVar' v
+ unsafeEff_ $ S.readMVar v
+{-# DEPRECATED runStateMVar, evalStateMVar, execStateMVar
+ "If you need access to the state from outside of the State effect, manage an explicit MVar yourself." #-}
+
-- | Fetch the current value of the state.
get :: (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.
--
@@ -118,7 +121,7 @@
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.
--
@@ -126,7 +129,7 @@
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.
--
@@ -142,7 +145,7 @@
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,3 +156,6 @@
-- /Note:/ this function gets an exclusive access to the state for its duration.
modifyM :: (HasCallStack, State s :> es) => (s -> Eff es s) -> Eff es ()
modifyM f = stateM (\s -> ((), ) <$> f s)
+
+{-# DEPRECATED stateM, modifyM
+ "Operations of the same State effect used within the callback deadlock. Use a combination of get and put instead, or an explicit MVar if you need atomic updates." #-}
diff --git a/src/Effectful/Writer/Dynamic.hs b/src/Effectful/Writer/Dynamic.hs
--- a/src/Effectful/Writer/Dynamic.hs
+++ b/src/Effectful/Writer/Dynamic.hs
@@ -1,8 +1,12 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
-- | The dynamically dispatched variant of the 'Writer' effect.
--
--- /Note:/ unless you plan to change interpretations at runtime, it's
--- recommended to use one of the statically dispatched variants,
+-- /Note:/ unless you plan to change interpretations at runtime or you need the
+-- t'Control.Monad.Writer.MonadWriter' instance for compatibility with existing
+-- code, it's recommended to use one of the statically dispatched variants,
-- i.e. "Effectful.Writer.Static.Local" or "Effectful.Writer.Static.Shared".
+--
+-- __If you just want to accumulate values, use "Effectful.Output.Dynamic".__
module Effectful.Writer.Dynamic
( -- * Effect
Writer(..)
@@ -25,15 +29,9 @@
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
diff --git a/src/Effectful/Writer/Static/Local.hs b/src/Effectful/Writer/Static/Local.hs
--- a/src/Effectful/Writer/Static/Local.hs
+++ b/src/Effectful/Writer/Static/Local.hs
@@ -8,6 +8,8 @@
-- is inefficient. __This applies, in particular, to the standard list type__,
-- which makes the 'Writer' effect pretty niche.
--
+-- __If you just want to accumulate values, use "Effectful.Output.Static.Local.Array" or "Effectful.Output.Static.Local.List".__
+--
-- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the
-- @transformers@ package includes additional operations
-- 'Control.Monad.Trans.Writer.Strict.pass' and
diff --git a/src/Effectful/Writer/Static/Shared.hs b/src/Effectful/Writer/Static/Shared.hs
--- a/src/Effectful/Writer/Static/Shared.hs
+++ b/src/Effectful/Writer/Static/Shared.hs
@@ -1,6 +1,6 @@
-- | Support for access to a write only value of a particular type.
--
--- The value is shared between multiple threads. If you want each thead to
+-- The value is shared between multiple threads. If you want each thread to
-- manage its own version of the value, use "Effectful.Writer.Static.Local".
--
-- /Warning:/ 'Writer'\'s state will be accumulated via __left-associated__ uses
@@ -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,7 +29,7 @@
, listens
) where
-import Control.Concurrent.MVar.Strict
+import Control.Concurrent.MVar.Strict qualified as S
import Control.Exception (onException, uninterruptibleMask)
import Data.Kind
@@ -39,33 +41,57 @@
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 :: (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 :: (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 :: (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':
@@ -86,7 +112,7 @@
-- 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) -> (v, Writer v1)
a <- unmask (unEff m es) `onException` merge es v0 v1
@@ -96,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
@@ -115,5 +141,6 @@
pure (a, f w)
-- $setup
+-- >>> import Control.Concurrent
-- >>> import Control.Exception (ErrorCall)
-- >>> import Effectful.Exception