effectful-core 2.5.1.0 → 2.7.1.0
raw patch · 50 files changed
Files
- CHANGELOG.md +98/−0
- README.md +2/−2
- cbits/utils.c +0/−5
- effectful-core.cabal +34/−31
- src/Effectful.hs +2/−2
- src/Effectful/Dispatch/Dynamic.hs +180/−103
- src/Effectful/Dispatch/Static.hs +17/−0
- src/Effectful/Dispatch/Static/Unsafe.hs +0/−47
- src/Effectful/Error/Dynamic.hs +56/−10
- src/Effectful/Error/Static.hs +76/−3
- src/Effectful/Exception.hs +48/−11
- src/Effectful/Input/Dynamic.hs +68/−0
- src/Effectful/Input/Static.hs +49/−0
- src/Effectful/Input/Static/Action.hs +79/−0
- src/Effectful/Internal/Effect.hs +0/−15
- src/Effectful/Internal/Effect/Dynamic.hs +99/−0
- src/Effectful/Internal/Env.hs +143/−70
- src/Effectful/Internal/Monad.hs +220/−50
- src/Effectful/Internal/Unlift.hs +324/−146
- src/Effectful/Internal/Utils.hs +23/−37
- src/Effectful/Internal/Utils/Word64Map.hs +162/−0
- src/Effectful/Labeled.hs +4/−1
- src/Effectful/Labeled/Error.hs +53/−0
- src/Effectful/Labeled/Input.hs +65/−0
- src/Effectful/Labeled/Output.hs +90/−0
- src/Effectful/Labeled/Provider.hs +98/−0
- src/Effectful/Labeled/Provider/List.hs +100/−0
- src/Effectful/Labeled/Reader.hs +3/−0
- src/Effectful/Labeled/ReturnWith.hs +43/−0
- src/Effectful/Labeled/State.hs +9/−0
- src/Effectful/Labeled/Writer.hs +3/−0
- src/Effectful/NonDet.hs +16/−7
- src/Effectful/Output/Dynamic.hs +86/−0
- src/Effectful/Output/Static/Action.hs +72/−0
- src/Effectful/Output/Static/Local/Array.hs +79/−0
- src/Effectful/Output/Static/Local/List.hs +39/−0
- src/Effectful/Output/Static/Shared/Array.hs +77/−0
- src/Effectful/Output/Static/Shared/List.hs +43/−0
- src/Effectful/Provider.hs +52/−74
- src/Effectful/Provider/List.hs +34/−80
- src/Effectful/Reader/Dynamic.hs +13/−14
- src/Effectful/Reader/Static.hs +4/−0
- src/Effectful/ReturnWith/Dynamic.hs +49/−0
- src/Effectful/ReturnWith/Static.hs +112/−0
- src/Effectful/State/Dynamic.hs +10/−11
- src/Effectful/State/Static/Local.hs +3/−0
- src/Effectful/State/Static/Shared.hs +26/−20
- src/Effectful/Writer/Dynamic.hs +7/−9
- src/Effectful/Writer/Static/Local.hs +2/−0
- src/Effectful/Writer/Static/Shared.hs +38/−11
CHANGELOG.md view
@@ -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
README.md view
@@ -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) -<img src="https://user-images.githubusercontent.com/387658/127747903-f728437f-2ee4-47b8-9f0c-5102fd44c8e4.png" width="128">+<img src="https://raw.githubusercontent.com/haskell-effectful/effectful/master/logo.svg" width="150"> An easy to use, fast extensible effects library with seamless integration with the existing Haskell ecosystem.
− cbits/utils.c
@@ -1,5 +0,0 @@-// Correct implementation of ThreadId# equality for GHC < 9.-long effectful_eq_thread(void *tso1, void *tso2)-{- return tso1 == tso2;-}
effectful-core.cabal view
@@ -1,7 +1,7 @@-cabal-version: 3.0+cabal-version: 3.8 build-type: Simple name: effectful-core-version: 2.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 @<https://hackage.haskell.org/package/effectful effectful>@ package for the "batteries-included" variant.@@ -21,7 +21,7 @@ CHANGELOG.md README.md -tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.5, 9.8.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
src/Effectful.hs view
@@ -46,7 +46,6 @@ , withUnliftStrategy , withSeqEffToIO , withEffToIO- , withConcEffToIO -- ** Lifting , raise@@ -64,6 +63,7 @@ import Control.Monad.IO.Unlift import Effectful.Internal.Effect+import Effectful.Internal.Effect.Dynamic () import Effectful.Internal.Env import Effectful.Internal.Monad @@ -148,7 +148,7 @@ -- -- These libraries can trivially be used with the 'Eff' monad since it provides -- typical instances that these libraries require the underlying monad to have,--- such as t'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
src/Effectful/Dispatch/Dynamic.hs view
@@ -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 <interactive>:... -- handler, called at src/Effectful/Dispatch/Dynamic.hs:... -- passthrough, called at <interactive>:... -- handler, called at src/Effectful/Dispatch/Dynamic.hs:... -- send, called at <interactive>:...+-- ... interpose :: (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
src/Effectful/Dispatch/Static.hs view
@@ -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
src/Effectful/Dispatch/Static/Unsafe.hs view
@@ -5,50 +5,3 @@ ) where import Effectful.Internal.Monad---- | Utility for lifting 'IO' computations of type------ @'IO' a -> 'IO' b@------ to------ @'Eff' es a -> 'Eff' es b@------ This function is __really unsafe__ because:------ - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'--- computations.------ - The 'IO' computation must run its argument in a way that's perceived as--- sequential to the outside observer, e.g. in the same thread or in a worker--- thread that finishes before the argument is run again.------ __Warning:__ if you disregard the second point, you will experience weird--- bugs, data races or internal consistency check failures.------ When in doubt, use 'Effectful.Dispatch.Static.unsafeLiftMapIO', especially--- since this version saves only a simple safety check per call of--- @reallyUnsafeLiftMapIO f@.-reallyUnsafeLiftMapIO :: (IO a -> IO b) -> Eff es a -> Eff es b-reallyUnsafeLiftMapIO f m = unsafeEff $ \es -> f (unEff m es)---- | Create an unlifting function.------ This function is __really unsafe__ because:------ - It can be used to introduce arbitrary 'IO' actions into pure 'Eff'--- computations.------ - Unlifted 'Eff' computations must be run in a way that's perceived as--- sequential to the outside observer, e.g. in the same thread as the caller--- of 'reallyUnsafeUnliftIO' or in a worker thread that finishes before--- another unlifted computation is run.------ __Warning:__ if you disregard the second point, you will experience weird--- bugs, data races or internal consistency check failures.------ When in doubt, use 'Effectful.Dispatch.Static.unsafeSeqUnliftIO', especially--- since this version saves only a simple safety check per call of the unlifting--- function.-reallyUnsafeUnliftIO :: ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a-reallyUnsafeUnliftIO k = unsafeEff $ \es -> k (`unEff` es)
src/Effectful/Error/Dynamic.hs view
@@ -1,8 +1,12 @@ -- | The dynamically dispatched variant of the 'Error' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use the statically dispatched variant,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.Except.MonadError' instance for compatibility with existing+-- code, it's recommended to use the statically dispatched variant, -- i.e. "Effectful.Error.Static".+--+-- All caveats described in "Effectful.Error.Static" (in particular the+-- interaction with threads) apply. module Effectful.Error.Dynamic ( -- * Effect Error(..)@@ -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 "<opaque>")++-- | Throw an error of type @e@ with the given 'E.CallStack' and specify a+-- display function in case a third-party code catches the internal exception+-- and 'show's it.+--+-- Useful e.g. when you want to catch an error and rethrow it converted to a+-- different type without losing the original 'E.CallStack'.+--+-- @since 2.7.0.0+rethrowErrorWith+ :: Error e :> es+ => (e -> String)+ -- ^ The display function.+ -> E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowErrorWith display cs = send . RethrowErrorWith display cs++-- | Throw an error of type @e@ with the given 'E.CallStack' and 'show' as a+-- display function.+--+-- @since 2.7.0.0+rethrowError+ :: (Error e :> es, Show e)+ => E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError = rethrowErrorWith show++-- | Throw an error of type @e@ with the given 'E.CallStack' and no display+-- function.+--+-- @since 2.7.0.0+rethrowError_+ :: Error e :> es+ => E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError_ = rethrowErrorWith (const "<opaque>") -- | Handle an error of type @e@. catchError
src/Effectful/Error/Static.hs view
@@ -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 "<opaque>") +-- | Throw an error of type @e@ with the given 'CallStack' and specify a+-- display function in case a third-party code catches the internal exception+-- and 'show's it.+--+-- Useful e.g. when you want to catch an error and rethrow it converted to a+-- different type without losing the original 'CallStack'.+--+-- @since 2.7.0.0+rethrowErrorWith+ :: forall e es a. Error e :> es+ => (e -> String)+ -- ^ The display function.+ -> CallStack+ -- ^ The 'CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowErrorWith display cs e = do+ Error eid <- getStaticRep @(Error e)+ throwIO $ ErrorWrapper eid cs (display e) (toAny e)++-- | Throw an error of type @e@ with the given 'CallStack' and 'show' as a+-- display function.+--+-- @since 2.7.0.0+rethrowError+ :: forall e es a. (Error e :> es, Show e)+ => CallStack+ -- ^ The 'CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError = rethrowErrorWith show++-- | Throw an error of type @e@ with the given 'CallStack' and no display+-- function.+--+-- @since 2.7.0.0+rethrowError_+ :: forall e es a. Error e :> es+ => CallStack+ -- ^ The 'CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError_ = rethrowErrorWith (const "<opaque>")+ -- | Handle an error of type @e@. catchError :: forall e es a. (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)
src/Effectful/Exception.hs view
@@ -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
+ src/Effectful/Input/Dynamic.hs view
@@ -0,0 +1,68 @@+-- | The dynamically dispatched variant of the 'Input' effect.+--+-- /Note:/ unless you plan to change interpretations at runtime, it's+-- recommended to use one of the statically dispatched variants,+-- i.e. "Effectful.Input.Static" or "Effectful.Input.Static.Action".+--+-- @since 2.7.0.0+module Effectful.Input.Dynamic+ ( -- * Effect+ Input(..)++ -- ** Handlers+ , runInput+ , runInputAction++ -- ** Operations+ , input+ , inputs+ ) where++import Effectful+import Effectful.Dispatch.Dynamic++-- | Provide access to values of type @i@.+data Input i :: Effect where+ Input :: Input i m i++type instance DispatchOf (Input i) = Dynamic++----------------------------------------+-- Handlers++-- | Run the 'Input' effect with the given value.+runInput+ :: HasCallStack+ => i+ -- ^ The input value.+ -> Eff (Input i : es) a+ -> Eff es a+runInput inputValue = interpret_ $ \case+ Input -> pure inputValue++-- | Run the 'Input' effect with the given action that supplies values.+runInputAction+ :: forall i es a+ . HasCallStack+ => (HasCallStack => Eff es i)+ -- ^ The action for input generation.+ -> Eff (Input i : es) a+ -> Eff es a+runInputAction inputAction = interpret_ $ \case+ Input -> inputAction++----------------------------------------+-- Operations++-- | Fetch the value.+input :: (HasCallStack, Input i :> es) => Eff es i+input = send Input++-- | Fetch the result of applying a function to the value.+--+-- @'inputs' f ≡ f '<$>' 'input'@+inputs+ :: (HasCallStack, Input i :> es)+ => (i -> a) -- ^ The function to apply to the value.+ -> Eff es a+inputs f = f <$> input
+ src/Effectful/Input/Static.hs view
@@ -0,0 +1,49 @@+-- | Support for access to a value of a particular type.+--+-- @since 2.7.0.0+module Effectful.Input.Static+ ( -- * Effect+ Input++ -- ** Handlers+ , runInput++ -- ** Operations+ , input+ , inputs+ ) where++import Data.Kind++import Effectful+import Effectful.Dispatch.Static++-- | Provide access to a value of type @i@.+data Input (i :: Type) :: Effect++type instance DispatchOf (Input i) = Static NoSideEffects+newtype instance StaticRep (Input i) = Input i++-- | Run the 'Input' effect with the given value.+runInput+ :: HasCallStack+ => i+ -- ^ The input value.+ -> Eff (Input i : es) a+ -> Eff es a+runInput = evalStaticRep . Input++-- | Fetch the value.+input :: (HasCallStack, Input i :> es) => Eff es i+input = do+ Input i <- getStaticRep+ pure i++-- | Fetch the result of applying a function to the value.+--+-- @'inputs' f ≡ f '<$>' 'input'@+inputs+ :: (HasCallStack, Input i :> es)+ => (i -> a) -- ^ The function to apply to the value.+ -> Eff es a+inputs f = f <$> input
+ src/Effectful/Input/Static/Action.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE ImplicitParams #-}+-- | Support for access to values supplied by a monadic action.+--+-- @since 2.7.0.0+module Effectful.Input.Static.Action+ ( -- * Effect+ Input++ -- ** Handlers+ , runInput++ -- ** Operations+ , input+ , inputs+ ) where++import Data.Kind+import GHC.Stack++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils++-- | Provide access to values of type @i@ supplied by a monadic action.+data Input (i :: Type) :: Effect++type instance DispatchOf (Input i) = Static NoSideEffects++-- | Wrapper to prevent a space leak on reconstruction of 'Input' in+-- 'relinkInput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).+newtype InputImpl i es where+ InputImpl :: (HasCallStack => Eff es i) -> InputImpl i es++data instance StaticRep (Input i) where+ Input+ :: !(Env inputEs)+ -> !(InputImpl i inputEs)+ -> StaticRep (Input i)++-- | Run the 'Input' effect with the given action that supplies values.+runInput+ :: forall i es a+ . HasCallStack+ => (HasCallStack => Eff es i)+ -- ^ The action for input generation.+ -> Eff (Input i : es) a+ -> Eff es a+runInput inputAction action = unsafeEff $ \es -> do+ inlineBracket+ (consEnv (Input es inputImpl) relinkInput es)+ unconsEnv+ (unEff action)+ where+ inputImpl = InputImpl $ let ?callStack = thawCallStack ?callStack in inputAction++-- | Fetch the value.+input :: (HasCallStack, Input i :> es) => Eff es i+input = unsafeEff $ \es -> do+ Input inputEs (InputImpl inputAction) <- getEnv es+ -- Corresponds to thawCallStack in runInput.+ (`unEff` inputEs) $ withFrozenCallStack inputAction++-- | Fetch the result of applying a function to the value.+--+-- @'inputs' f ≡ f '<$>' 'input'@+inputs+ :: (HasCallStack, Input i :> es)+ => (i -> a) -- ^ The function to apply to the value.+ -> Eff es a+inputs f = f <$> input++----------------------------------------+-- Helpers++relinkInput :: Relinker StaticRep (Input i)+relinkInput = Relinker $ \relink (Input inputEs inputAction) -> do+ newActionEs <- relink inputEs+ pure $ Input newActionEs inputAction
src/Effectful/Internal/Effect.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} -- | Type-safe indexing for 'Effectful.Internal.Monad.Env'. --@@ -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
+ src/Effectful/Internal/Effect/Dynamic.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -Wno-orphans #-}+-- | Definitions and instances for MTL compatibility.+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Effect.Dynamic where++import Control.Monad.Except qualified as MTL+import Control.Monad.Reader qualified as MTL+import Control.Monad.State qualified as MTL+import Control.Monad.Writer qualified as MTL+import GHC.Stack (CallStack)++import Effectful.Internal.Effect+import Effectful.Internal.Env+import Effectful.Internal.Monad++-- | Provide the ability to handle errors of type @e@.+data Error e :: Effect where+ -- | @since 2.4.0.0+ ThrowErrorWith :: (e -> String) -> e -> Error e m a+ -- | @since 2.7.0.0+ RethrowErrorWith :: (e -> String) -> CallStack -> e -> Error e m a+ CatchError :: m a -> (CallStack -> e -> m a) -> Error e m a++type instance DispatchOf (Error e) = Dynamic++-- | Instance included for compatibility with existing code.+instance+ ( Show e+ , Error e :> es+ , MTL.MonadError e (Eff es)+ ) => MTL.MonadError e (Eff es) where+ throwError = send . ThrowErrorWith show+ catchError action = send . CatchError action . const++----------------------------------------++data Reader r :: Effect where+ Ask :: Reader r m r+ Local :: (r -> r) -> m a -> Reader r m a++type instance DispatchOf (Reader r) = Dynamic++-- | Instance included for compatibility with existing code.+instance+ ( Reader r :> es+ , MTL.MonadReader r (Eff es)+ ) => MTL.MonadReader r (Eff es) where+ ask = send Ask+ local f = send . Local f+ reader f = f <$> send Ask++----------------------------------------++-- | Provide access to a mutable value of type @s@.+data State s :: Effect where+ Get :: State s m s+ Put :: s -> State s m ()+ State :: (s -> (a, s)) -> State s m a+ StateM :: (s -> m (a, s)) -> State s m a++{-# DEPRECATED StateM "Use a combination of Get and Put instead." #-}++type instance DispatchOf (State s) = Dynamic++-- | Instance included for compatibility with existing code.+instance+ ( State s :> es+ , MTL.MonadState s (Eff es)+ ) => MTL.MonadState s (Eff es) where+ get = send Get+ put = send . Put+ state = send . State++----------------------------------------++-- | Provide access to a write only value of type @w@.+data Writer w :: Effect where+ Tell :: w -> Writer w m ()+ Listen :: m a -> Writer w m (a, w)++type instance DispatchOf (Writer w) = Dynamic++-- | Instance included for compatibility with existing code.+--+-- /Warning:/ 'MTL.pass' is not implemented due to ambiguous semantics in+-- presence of runtime exceptions, so calling it (also indirectly via+-- 'MTL.censor', which is defined in terms of 'MTL.pass') results in a runtime+-- error.+instance+ ( Monoid w+ , Writer w :> es+ , MTL.MonadWriter w (Eff es)+ ) => MTL.MonadWriter w (Eff es) where+ writer (a, w) = a <$ send (Tell w)+ tell = send . Tell+ listen = send . Listen+ pass = error "pass is not implemented due to ambiguous semantics in presence of runtime exceptions"
src/Effectful/Internal/Env.hs view
@@ -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
src/Effectful/Internal/Monad.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_HADDOCK not-home #-} -- | The 'Eff' monad.@@ -46,18 +45,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
src/Effectful/Internal/Unlift.hs view
@@ -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+ }
src/Effectful/Internal/Utils.hs view
@@ -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
+ src/Effectful/Internal/Utils/Word64Map.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE Strict #-}+-- | A minimal, strict map keyed by 'Word64' values (adaptation of+-- 'Data.IntMap.Strict').+--+-- This module is intended for internal use only, and may change without warning+-- in subsequent releases.+module Effectful.Internal.Utils.Word64Map+ ( Word64Map+ , empty+ , lookup+ , insert+ , delete+ , updateLookupWithKey+ ) where++import Data.Bits+import Data.Word+import Prelude hiding (lookup)++-- | A map of 'Word64' keys to values of type @a@.+data Word64Map a+ = Bin Prefix (Word64Map a) (Word64Map a)+ | Tip Word64 a+ | Nil++-- | A @Prefix@ represents some prefix of high-order bits of a @Word64@.+newtype Prefix = Prefix Word64++unPrefix :: Prefix -> Word64+unPrefix (Prefix p) = p++----------------------------------------++-- | The empty map.+empty :: Word64Map a+empty = Nil++-- | Look up the value at a key in the map.+lookup :: Word64 -> Word64Map a -> Maybe a+lookup k = go+ where+ go (Bin p l r) | left k p = go l+ | otherwise = go r+ go (Tip kx x) | k == kx = Just x+ | otherwise = Nothing+ go Nil = Nothing++-- | Insert a new key/value pair in the map. If the key is already present, the+-- associated value is replaced with the supplied one.+--+-- The value is evaluated to WHNF when it is inserted into the map.+insert :: Word64 -> a -> Word64Map a -> Word64Map a+insert k x = go+ where+ go t@(Bin p l r)+ | nomatch k p = linkKey k (Tip k x) p t+ | left k p = Bin p (go l) r+ | otherwise = Bin p l (go r)+ go t@(Tip ky _)+ | k == ky = Tip k x+ | otherwise = link k (Tip k x) ky t+ go Nil = Tip k x++-- | Delete a key and its value from the map. When the key is not a member of+-- the map, the original map is returned.+delete :: Word64 -> Word64Map a -> Word64Map a+delete k = go+ where+ go t@(Bin p l r)+ | nomatch k p = t+ | left k p = binCheckLeft p (go l) r+ | otherwise = binCheckRight p l (go r)+ go t@(Tip ky _)+ | k == ky = Nil+ | otherwise = t+ go Nil = Nil++-- | Look up and update the value at a key in the map. The function returns the+-- original value, if it exists, and the updated map.+--+-- The updated value is evaluated to WHNF when it is inserted into the map.+updateLookupWithKey+ :: (Word64 -> a -> Maybe a)+ -> Word64+ -> Word64Map a+ -> (Maybe a, Word64Map a)+updateLookupWithKey f k = go+ where+ go t@(Bin p l r)+ | nomatch k p = (Nothing, t)+ | left k p = let (found, l') = go l in (found, binCheckLeft p l' r)+ | otherwise = let (found, r') = go r in (found, binCheckRight p l r')+ go t@(Tip ky y)+ | k == ky = case f ky y of+ Just y' -> (Just y, Tip ky y')+ Nothing -> (Just y, Nil)+ | otherwise = (Nothing, t)+ go Nil = (Nothing, Nil)++----------------------------------------+-- Internal helpers++-- | Whether the @Word64@ does not start with the given @Prefix@.+--+-- A @Word64@ starts with a @Prefix@ if it shares the high bits with the+-- internal @Word64@ value of the @Prefix@ up to the mask bit.+--+-- @nomatch@ is usually used to determine whether a key belongs in a @Bin@,+-- since all keys in a @Bin@ share a @Prefix@.+nomatch :: Word64 -> Prefix -> Bool+nomatch i (Prefix p) = (i `xor` p) .&. prefixMask /= 0+ where+ prefixMask = p `xor` (-p)++-- | Whether the @Word64@ is to the left of the split created by a @Bin@ with+-- this @Prefix@.+--+-- This does not imply that the @Word64@ belongs in this @Bin@. That fact is+-- usually determined first using @nomatch@.+left :: Word64 -> Prefix -> Bool+left i p = i < unPrefix p++-- | Link two @Word64Map@s. The maps must not be empty. The @Prefix@es of the+-- two maps must be different. @k1@ must share the prefix of @t1@. @p2@ must be+-- the prefix of @t2@.+linkKey :: Word64 -> Word64Map a -> Prefix -> Word64Map a -> Word64Map a+linkKey k1 t1 p2 t2 = link k1 t1 (unPrefix p2) t2++-- | Link two @Word64Map@s. The maps must not be empty. The @Prefix@es of the+-- two maps must be different. @k1@ must share the prefix of @t1@ and @k2@ must+-- share the prefix of @t2@.+link :: Word64 -> Word64Map a -> Word64 -> Word64Map a -> Word64Map a+link k1 t1 k2 t2 = linkWithMask (branchMask k1 k2) k1 t1 k2 t2++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Word64 -> Word64 -> Word64Map a -> Word64 -> Word64Map a -> Word64Map a+linkWithMask m k1 t1 k2 t2+ | k1 < k2 = Bin p t1 t2+ | otherwise = Bin p t2 t1+ where+ p = Prefix (mask k1 m .|. m)++-- | The prefix of key @i@ up to (but not including) the switching bit @m@.+mask :: Word64 -> Word64 -> Word64+mask i m = i .&. (m `xor` (-m))++-- | The first switching bit where the two prefixes disagree.+--+-- Precondition for defined behavior: p1 /= p2.+branchMask :: Word64 -> Word64 -> Word64+branchMask k1 k2 =+ unsafeShiftL 1 (finiteBitSize (0 :: Word64) - 1 - countLeadingZeros (k1 `xor` k2))++-- | Smart constructor that collapses an empty left subtree.+binCheckLeft :: Prefix -> Word64Map a -> Word64Map a -> Word64Map a+binCheckLeft _ Nil r = r+binCheckLeft p l r = Bin p l r++-- | Smart constructor that collapses an empty right subtree.+binCheckRight :: Prefix -> Word64Map a -> Word64Map a -> Word64Map a+binCheckRight _ l Nil = l+binCheckRight p l r = Bin p l r
src/Effectful/Labeled.hs view
@@ -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
src/Effectful/Labeled/Error.hs view
@@ -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 "<opaque>")++-- | Throw an error of type @e@ with the given 'E.CallStack' and specify a+-- display function in case a third-party code catches the internal exception+-- and 'show's it.+--+-- Useful e.g. when you want to catch an error and rethrow it converted to a+-- different type without losing the original 'E.CallStack'.+--+-- @since 2.7.0.0+rethrowErrorWith+ :: forall label e es a+ . Labeled label (Error e) :> es+ => (e -> String)+ -- ^ The display function.+ -> E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowErrorWith display cs =+ send . Labeled @label . RethrowErrorWith display cs++-- | Throw an error of type @e@ with the given 'E.CallStack' and 'show' as a+-- display function.+--+-- @since 2.7.0.0+rethrowError+ :: forall label e es a+ . (Labeled label (Error e) :> es, Show e)+ => E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError = rethrowErrorWith @label show++-- | Throw an error of type @e@ with the given 'E.CallStack' and no display+-- function.+--+-- @since 2.7.0.0+rethrowError_+ :: forall label e es a+ . Labeled label (Error e) :> es+ => E.CallStack+ -- ^ The 'E.CallStack' to attach to the error.+ -> e+ -- ^ The error.+ -> Eff es a+rethrowError_ = rethrowErrorWith @label (const "<opaque>") -- | Handle an error of type @e@. catchError
+ src/Effectful/Labeled/Input.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Input' effect.+--+-- @since 2.7.0.0+module Effectful.Labeled.Input+ ( -- * Effect+ Input++ -- ** Handlers+ , runInput+ , runInputAction++ -- ** Operations+ , input+ , inputs++ -- * Re-exports+ , Labeled(..)+ ) where++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Input.Dynamic (Input(..))+import Effectful.Input.Dynamic qualified as I++-- | Run the 'Input' effect with the given value.+runInput+ :: forall label i es a+ . HasCallStack+ => i+ -- ^ The input value.+ -> Eff (Labeled label (Input i) : es) a+ -> Eff es a+runInput = runLabeled @label . I.runInput++-- | Run the 'Input' effect with the given action that supplies values.+runInputAction+ :: forall label i es a+ . HasCallStack+ => (HasCallStack => Eff es i)+ -- ^ The action for input generation.+ -> Eff (Labeled label (Input i) : es) a+ -> Eff es a+runInputAction = runLabeled @label . I.runInputAction++----------------------------------------+-- Operations++-- | Fetch the value.+input+ :: forall label i es+ . (HasCallStack, Labeled label (Input i) :> es)+ => Eff es i+input = send $ Labeled @label Input++-- | Fetch the result of applying a function to the value.+--+-- @'inputs' f ≡ f '<$>' 'input'@+inputs+ :: forall label i es a+ . (HasCallStack, Labeled label (Input i) :> es)+ => (i -> a) -- ^ The function to apply to the value.+ -> Eff es a+inputs f = f <$> input @label
+ src/Effectful/Labeled/Output.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Output' effect.+--+-- @since 2.7.0.0+module Effectful.Labeled.Output+ ( -- * Effect+ Output(..)++ -- ** Handlers+ , runOutputAction+ , runOutputLocalArray+ , runOutputLocalList+ , runOutputSharedArray+ , runOutputSharedList++ -- ** Operations+ , output++ -- * Re-exports+ , Labeled(..)+ , Array+ ) where++import Data.Primitive.Array++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Output.Dynamic (Output(..))+import Effectful.Output.Dynamic qualified as O++----------------------------------------+-- Handlers++-- | Run the 'Output' effect with the given action for receiving values.+runOutputAction+ :: forall label o es a+ . HasCallStack+ => (HasCallStack => o -> Eff es ())+ -- ^ The action for output generation.+ -> Eff (Labeled label (Output o) : es) a+ -> Eff es a+runOutputAction = runLabeled @label . O.runOutputAction++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array (via "Effectful.Output.Static.Local.Array").+runOutputLocalArray+ :: forall label o es a+ . HasCallStack+ => Eff (Labeled label (Output o) : es) a+ -> Eff es (a, Array o)+runOutputLocalArray = runLabeled @label O.runOutputLocalArray++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list (via "Effectful.Output.Static.Local.List").+runOutputLocalList+ :: forall label o es a+ . HasCallStack+ => Eff (Labeled label (Output o) : es) a+ -> Eff es (a, [o])+runOutputLocalList = runLabeled @label O.runOutputLocalList++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array (via "Effectful.Output.Static.Shared.Array").+runOutputSharedArray+ :: forall label o es a+ . HasCallStack+ => Eff (Labeled label (Output o) : es) a+ -> Eff es (a, Array o)+runOutputSharedArray = runLabeled @label O.runOutputSharedArray++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list (via "Effectful.Output.Static.Shared.List").+runOutputSharedList+ :: forall label o es a+ . HasCallStack+ => Eff (Labeled label (Output o) : es) a+ -> Eff es (a, [o])+runOutputSharedList = runLabeled @label O.runOutputSharedList++----------------------------------------+-- Operations++-- | Feed the value to the underlying handler.+output+ :: forall label o es+ . (HasCallStack, Labeled label (Output o) :> es)+ => o+ -> Eff es ()+output = send . Labeled @label . Output
+ src/Effectful/Labeled/Provider.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'Provider' effect.+--+-- @since 2.7.0.0+module Effectful.Labeled.Provider+ ( -- * Effect+ Provider(..)+ , Provider_++ -- ** Handlers+ , runProvider+ , runProvider_++ -- ** Operations+ , provide+ , provide_+ , provideWith+ , provideWith_++ -- * Re-exports+ , Labeled(..)+ ) where++import Data.Coerce+import Data.Functor.Identity++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Provider (Provider(..), Provider_)+import Effectful.Provider qualified as P++-- | Run the labeled 'Provider' effect with a given effect handler.+runProvider+ :: forall label e input f es a+ . HasCallStack+ => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r))+ -- ^ The effect handler.+ -> Eff (Labeled label (Provider e input f) : es) a+ -> Eff es a+runProvider provider = runLabeled @label (P.runProvider provider)++-- | Run the labeled 'Provider' effect with a given effect handler that doesn't+-- change its return type.+runProvider_+ :: forall label e input es a+ . HasCallStack+ => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r)+ -- ^ The effect handler.+ -> Eff (Labeled label (Provider_ e input) : es) a+ -> Eff es a+runProvider_ provider = runLabeled @label (P.runProvider_ provider)++----------------------------------------+-- Operations++-- | Run the effect handler.+provide+ :: forall label e f es a+ . (HasCallStack, Labeled label (Provider e () f) :> es)+ => Eff (e : es) a+ -> Eff es (f a)+provide = send . Labeled @label . P.ProvideWith ()++-- | Run the effect handler with unchanged return type.+provide_+ :: forall label e es a+ . (HasCallStack, Labeled label (Provider_ e ()) :> es)+ => Eff (e : es) a+ -> Eff es a+provide_ = dropIdentity . send . Labeled @label . P.ProvideWith ()++-- | Run the effect handler with a given input.+provideWith+ :: forall label e input f es a+ . (HasCallStack, Labeled label (Provider e input f) :> es)+ => input+ -- ^ The input to the effect handler.+ -> Eff (e : es) a+ -> Eff es (f a)+provideWith input = send . Labeled @label . P.ProvideWith input++-- | Run the effect handler that doesn't change its return type with a given+-- input.+provideWith_+ :: forall label e input es a+ . (HasCallStack, Labeled label (Provider_ e input) :> es)+ => input+ -- ^ The input to the effect handler.+ -> Eff (e : es) a+ -> Eff es a+provideWith_ input = dropIdentity . send . Labeled @label . P.ProvideWith input++----------------------------------------+-- Helpers++dropIdentity :: Eff es (Identity a) -> Eff es a+dropIdentity = coerce
+ src/Effectful/Labeled/Provider/List.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'ProviderList' effect.+--+-- @since 2.7.0.0+module Effectful.Labeled.Provider.List+ ( -- * Effect+ ProviderList(..)+ , ProviderList_++ -- ** Handlers+ , runProviderList+ , runProviderList_++ -- ** Operations+ , provideList+ , provideList_+ , provideListWith+ , provideListWith_++ -- * Re-exports+ , Labeled(..)+ , type (++)+ , KnownSubset+ ) where++import Data.Coerce+import Data.Functor.Identity++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Provider.List (ProviderList(..), ProviderList_)+import Effectful.Provider.List qualified as P++-- | Run the labeled 'ProviderList' effect with a given handler.+runProviderList+ :: forall label providedEs input f es a+ . (HasCallStack, KnownSubset providedEs (providedEs ++ es))+ => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es (f r))+ -- ^ The handler.+ -> Eff (Labeled label (ProviderList providedEs input f) : es) a+ -> Eff es a+runProviderList provider = runLabeled @label (P.runProviderList provider)++-- | Run the labeled 'ProviderList' effect with a given handler that doesn't+-- change its return type.+runProviderList_+ :: forall label providedEs input es a+ . (HasCallStack, KnownSubset providedEs (providedEs ++ es))+ => (forall r. HasCallStack => input -> Eff (providedEs ++ es) r -> Eff es r)+ -- ^ The handler.+ -> Eff (Labeled label (ProviderList_ providedEs input) : es) a+ -> Eff es a+runProviderList_ provider = runLabeled @label (P.runProviderList_ provider)++----------------------------------------+-- Operations++-- | Run the handler.+provideList+ :: forall label providedEs f es a+ . (HasCallStack, Labeled label (ProviderList providedEs () f) :> es)+ => Eff (providedEs ++ es) a+ -> Eff es (f a)+provideList = send . Labeled @label . P.ProvideListWith @providedEs ()++-- | Run the handler with unchanged return type.+provideList_+ :: forall label providedEs es a+ . (HasCallStack, Labeled label (ProviderList_ providedEs ()) :> es)+ => Eff (providedEs ++ es) a+ -> Eff es a+provideList_ = dropIdentity . send . Labeled @label . P.ProvideListWith @providedEs ()++-- | Run the handler with a given input.+provideListWith+ :: forall label providedEs input f es a+ . (HasCallStack, Labeled label (ProviderList providedEs input f) :> es)+ => input+ -- ^ The input to the handler.+ -> Eff (providedEs ++ es) a+ -> Eff es (f a)+provideListWith input = send . Labeled @label . P.ProvideListWith @providedEs input++-- | Run the handler that doesn't change its return type with a given input.+provideListWith_+ :: forall label providedEs input es a+ . (HasCallStack, Labeled label (ProviderList_ providedEs input) :> es)+ => input+ -- ^ The input to the handler.+ -> Eff (providedEs ++ es) a+ -> Eff es a+provideListWith_ input =+ dropIdentity . send . Labeled @label . P.ProvideListWith @providedEs input++----------------------------------------+-- Helpers++dropIdentity :: Eff es (Identity a) -> Eff es a+dropIdentity = coerce
src/Effectful/Labeled/Reader.hs view
@@ -13,6 +13,9 @@ , ask , asks , local++ -- * Re-exports+ , Labeled(..) ) where import Effectful
+ src/Effectful/Labeled/ReturnWith.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+-- | Convenience functions for the 'Labeled' 'ReturnWith' effect.+--+-- @since 2.7.0.0+module Effectful.Labeled.ReturnWith+ ( -- * Effect+ ReturnWith(..)++ -- ** Handlers+ , runReturnWith++ -- ** Operations+ , returnWith++ -- * Re-exports+ , Labeled(..)+ ) where++import GHC.Stack (withFrozenCallStack)++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.ReturnWith.Dynamic (ReturnWith(..))+import Effectful.ReturnWith.Dynamic qualified as R++-- | Run a computation that can return early with a value of type @r@ (via+-- "Effectful.ReturnWith.Static").+runReturnWith+ :: forall label r es+ . HasCallStack+ => Eff (Labeled label (ReturnWith r) : es) r+ -> Eff es r+runReturnWith = runLabeled @label R.runReturnWith++-- | Return early with the given value.+returnWith+ :: forall label r es a+ . (HasCallStack, Labeled label (ReturnWith r) :> es)+ => r+ -- ^ The value.+ -> Eff es a+returnWith = withFrozenCallStack send . Labeled @label . ReturnWith
src/Effectful/Labeled/State.hs view
@@ -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." #-}
src/Effectful/Labeled/Writer.hs view
@@ -20,6 +20,9 @@ , tell , listen , listens++ -- * Re-exports+ , Labeled(..) ) where import Effectful
src/Effectful/NonDet.hs view
@@ -1,5 +1,9 @@ -- | Provider of the t'Control.Applicative.Alternative' and -- t'Control.Monad.MonadPlus' instance for 'Eff'.+--+-- /Note:/ the 'NonDet' effect uses the t'Effectful.Error.Static.Error' effect+-- underneath, so caveats described in "Effectful.Error.Static" (in particular+-- the interaction with threads) apply. module Effectful.NonDet ( -- * Effect NonDet(..)@@ -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)
+ src/Effectful/Output/Dynamic.hs view
@@ -0,0 +1,86 @@+-- | The dynamically dispatched variant of the 'Output' effect.+--+-- /Note:/ unless you plan to change interpretations at runtime, it's+-- recommended to use one of the statically dispatched variants,+-- i.e. "Effectful.Output.Static.Action", "Effectful.Output.Static.Local.Array",+-- "Effectful.Output.Static.Local.List", "Effectful.Output.Static.Shared.Array"+-- or "Effectful.Output.Static.Shared.List".+--+-- @since 2.7.0.0+module Effectful.Output.Dynamic+ ( -- * Effect+ Output(..)++ -- ** Handlers+ , runOutputAction+ , runOutputLocalArray+ , runOutputLocalList+ , runOutputSharedArray+ , runOutputSharedList++ -- ** Operations+ , output+ ) where++import Data.Primitive.Array++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Output.Static.Local.Array qualified as LA+import Effectful.Output.Static.Local.List qualified as LL+import Effectful.Output.Static.Shared.Array qualified as SA+import Effectful.Output.Static.Shared.List qualified as SL++-- | Provide the ability to feed values of type @o@ to a handler.+data Output o :: Effect where+ Output :: o -> Output o m ()++type instance DispatchOf (Output o) = Dynamic++----------------------------------------+-- Handlers++-- | Run the 'Output' effect with the given action for receiving values.+runOutputAction+ :: forall o es a+ . HasCallStack+ => (HasCallStack => o -> Eff es ())+ -- ^ The action for output generation.+ -> Eff (Output o : es) a+ -> Eff es a+runOutputAction outputAction = interpret_ $ \case+ Output o -> outputAction $! o++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array (via "Effectful.Output.Static.Local.Array").+runOutputLocalArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)+runOutputLocalArray = reinterpret_ LA.runOutput $ \case+ Output o -> LA.output o++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list (via "Effectful.Output.Static.Local.List").+runOutputLocalList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])+runOutputLocalList = reinterpret_ LL.runOutput $ \case+ Output o -> LL.output o++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array (via "Effectful.Output.Static.Shared.Array").+runOutputSharedArray :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)+runOutputSharedArray = reinterpret_ SA.runOutput $ \case+ Output o -> SA.output o++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list (via "Effectful.Output.Static.Shared.List").+runOutputSharedList :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])+runOutputSharedList = reinterpret_ SL.runOutput $ \case+ Output o -> SL.output o++----------------------------------------+-- Operations++-- | Feed the value to the underlying handler.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output = send . Output
+ src/Effectful/Output/Static/Action.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ImplicitParams #-}+-- | Support for feeding values of a particular type to a monadic action.+--+-- @since 2.7.0.0+module Effectful.Output.Static.Action+ ( -- * Effect+ Output++ -- ** Handlers+ , runOutput++ -- ** Operations+ , output+ ) where++import Data.Kind+import GHC.Stack++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils++-- | Provide the ability to feed values of type @o@ to a monadic action.+data Output (o :: Type) :: Effect++type instance DispatchOf (Output o) = Static NoSideEffects++-- | Wrapper to prevent a space leak on reconstruction of 'Output' in+-- 'relinkOutput' (see https://gitlab.haskell.org/ghc/ghc/-/issues/25520).+newtype OutputImpl o es where+ OutputImpl :: (HasCallStack => o -> Eff es ()) -> OutputImpl o es++data instance StaticRep (Output o) where+ Output+ :: !(Env actionEs)+ -> !(OutputImpl o actionEs)+ -> StaticRep (Output o)++-- | Run the 'Output' effect with the given action for receiving values.+runOutput+ :: forall o es a+ . HasCallStack+ => (HasCallStack => o -> Eff es ())+ -- ^ The action for receiving values.+ -> Eff (Output o : es) a+ -> Eff es a+runOutput outputAction action = unsafeEff $ \es -> do+ inlineBracket+ (consEnv (Output es outputImpl) relinkOutput es)+ unconsEnv+ (unEff action)+ where+ outputImpl = OutputImpl $ let ?callStack = thawCallStack ?callStack in outputAction++-- | Feed the value to the underlying monadic action.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output !o = unsafeEff $ \es -> do+ Output actionEs (OutputImpl outputAction) <- getEnv es+ -- Corresponds to thawCallStack in runOutput.+ (`unEff` actionEs) $ withFrozenCallStack outputAction o++----------------------------------------+-- Helpers++relinkOutput :: Relinker StaticRep (Output o)+relinkOutput = Relinker $ \relink (Output actionEs outputAction) -> do+ newActionEs <- relink actionEs+ pure $ Output newActionEs outputAction
+ src/Effectful/Output/Static/Local/Array.hs view
@@ -0,0 +1,79 @@+-- | Support for accumulation of values in a thread local array.+--+-- @since 2.7.0.0+module Effectful.Output.Static.Local.Array+ ( -- * Effect+ Output++ -- ** Handlers+ , runOutput++ -- ** Operations+ , output++ -- * Re-exports+ , Array+ ) where++import Control.Monad.Primitive+import Data.Kind+import Data.Primitive.Array++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils++-- | Provide access to accumulation of values of type @o@ in a thread local+-- array.+data Output (o :: Type) :: Effect++type instance DispatchOf (Output o) = Static NoSideEffects+data instance StaticRep (Output o) = Output !Int !(MutableArray RealWorld o)++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array.+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)+runOutput = runOutputImpl $ \(Output size arr) -> do+ freezeArray arr 0 size++-- | Append the value to the end of the array.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output !o = unsafeEff $ \es -> do+ Output size arr0 <- getEnv es+ let len0 = sizeofMutableArray arr0+ arr <- case size `compare` len0 of+ GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"+ LT -> pure arr0+ EQ -> do+ let len = growCapacity len0+ arr <- newArray len undefinedValue+ copyMutableArray arr 0 arr0 0 size+ pure arr+ writeArray arr size o+ putEnv es $ Output (size + 1) arr++----------------------------------------+-- Helpers++runOutputImpl+ :: HasCallStack+ => (StaticRep (Output o) -> IO acc)+ -> Eff (Output o : es) a+ -> Eff es (a, acc)+runOutputImpl f action = unsafeEff $ \es0 -> do+ arr <- newArray 0 undefinedValue+ inlineBracket+ (consEnv (Output 0 arr) relinkOutput es0)+ unconsEnv+ (\es -> (,) <$> unEff action es <*> (f =<< getEnv es))+ where+ relinkOutput = Relinker $ \_ (Output size arr0) -> do+ arr <- cloneMutableArray arr0 0 (sizeofMutableArray arr0)+ pure $ Output size arr++undefinedValue :: HasCallStack => a+undefinedValue = error "Undefined value"
+ src/Effectful/Output/Static/Local/List.hs view
@@ -0,0 +1,39 @@+-- | Support for accumulation of values in a thread local list.+--+-- @since 2.7.0.0+module Effectful.Output.Static.Local.List+ ( -- * Effect+ Output++ -- ** Handlers+ , runOutput++ -- ** Operations+ , output+ ) where++import Data.Kind++import Effectful+import Effectful.Dispatch.Static++-- | Provide access to accumulation of values of type @o@ in a thread local+-- list.+data Output (o :: Type) :: Effect++type instance DispatchOf (Output o) = Static NoSideEffects+newtype instance StaticRep (Output o) = Output [o]++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list.+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])+runOutput action = do+ (a, Output acc) <- runStaticRep (Output []) action+ pure (a, reverse acc)++-- | Append the value to the end of the list.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output !o = stateStaticRep $ \(Output acc) -> ((), Output (o : acc))
@@ -0,0 +1,77 @@+-- | Support for accumulation of values in a shared array.+--+-- @since 2.7.0.0+module Effectful.Output.Static.Shared.Array+ ( -- * Effect+ Output++ -- ** Handlers+ , runOutput++ -- ** Operations+ , output++ -- * Re-exports+ , Array+ ) where++import Control.Concurrent.MVar.Strict qualified as S+import Control.Monad.Primitive+import Data.Kind+import Data.Primitive.Array++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Utils++-- | Provide access to accumulation of values of type @o@ in a shared array.+data Output (o :: Type) :: Effect++data OutputData o = OutputData !Int !(MutableArray RealWorld o)++type instance DispatchOf (Output o) = Static NoSideEffects+newtype instance StaticRep (Output o) = Output (S.MVar (OutputData o))++-- | Run the 'Output' effect and return the final value along with the+-- accumulated array.+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, Array o)+runOutput = runOutputImpl $ \(OutputData size arr) -> do+ freezeArray arr 0 size++-- | Append the value to the end of the array.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output !o = unsafeEff $ \es -> do+ Output v <- getEnv es+ S.modifyMVar_ v $ \(OutputData size arr0) -> do+ let len0 = sizeofMutableArray arr0+ arr <- case size `compare` len0 of+ GT -> error $ "size (" ++ show size ++ ") > len0 (" ++ show len0 ++ ")"+ LT -> pure arr0+ EQ -> do+ let len = growCapacity len0+ arr <- newArray len undefinedValue+ copyMutableArray arr 0 arr0 0 size+ pure arr+ writeArray arr size o+ pure $ OutputData (size + 1) arr++----------------------------------------+-- Helpers++runOutputImpl+ :: HasCallStack+ => (OutputData o -> IO acc)+ -> Eff (Output o : es) a+ -> Eff es (a, acc)+runOutputImpl f action = do+ v <- unsafeEff_ $ S.newMVar . OutputData 0 =<< newArray 0 undefinedValue+ a <- evalStaticRep (Output v) action+ acc <- unsafeEff_ $ f =<< S.readMVar v+ pure (a, acc)++undefinedValue :: HasCallStack => a+undefinedValue = error "Undefined value"
@@ -0,0 +1,43 @@+-- | Support for accumulation of values in a shared list.+--+-- @since 2.7.0.0+module Effectful.Output.Static.Shared.List+ ( -- * Effect+ Output++ -- ** Handlers+ , runOutput++ -- ** Operations+ , output+ ) where++import Control.Concurrent.MVar.Strict qualified as S+import Data.Kind++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive++-- | Provide access to accumulation of values of type @o@ in a shared list.+data Output (o :: Type) :: Effect++type instance DispatchOf (Output o) = Static NoSideEffects+newtype instance StaticRep (Output o) = Output (S.MVar [o])++-- | Run the 'Output' effect and return the final value along with the+-- accumulated list.+runOutput :: HasCallStack => Eff (Output o : es) a -> Eff es (a, [o])+runOutput action = do+ v <- unsafeEff_ $ S.newMVar []+ a <- evalStaticRep (Output v) action+ (a, ) . reverse <$> unsafeEff_ (S.readMVar v)++-- | Append the value to the end of the list.+output+ :: (HasCallStack, Output o :> es)+ => o -- ^ The value.+ -> Eff es ()+output !o = unsafeEff $ \es -> do+ Output v <- getEnv es+ S.modifyMVar_ v $ \acc -> pure (o : acc)
src/Effectful/Provider.hs view
@@ -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
src/Effectful/Provider/List.hs view
@@ -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
src/Effectful/Reader/Dynamic.hs view
@@ -1,7 +1,8 @@ -- | The dynamically dispatched variant of the 'Reader' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use the statically dispatched variant,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.Reader.MonadReader' instance for compatibility with existing+-- code, it's recommended to use the statically dispatched variant, -- i.e. "Effectful.Reader.Static". module Effectful.Reader.Dynamic ( -- * Effect@@ -19,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
src/Effectful/Reader/Static.hs view
@@ -1,4 +1,8 @@ -- | Support for access to a read only value of a particular type.+--+-- /Note:/ strictly speaking the value is not read only because of 'local'. If+-- you want to ensure that the initial value never changes, use+-- "Effectful.Input.Static". module Effectful.Reader.Static ( -- * Effect Reader
+ src/Effectful/ReturnWith/Dynamic.hs view
@@ -0,0 +1,49 @@+-- | The dynamically dispatched variant of the 'ReturnWith' effect.+--+-- /Note:/ unless you plan to change interpretations at runtime, it's+-- recommended to use the statically dispatched variant,+-- i.e. "Effectful.ReturnWith.Static".+--+-- All caveats described in "Effectful.ReturnWith.Static" (in particular the+-- interaction with threads) apply.+--+-- @since 2.7.0.0+module Effectful.ReturnWith.Dynamic+ ( -- * Effect+ ReturnWith(..)++ -- ** Handlers+ , runReturnWith++ -- ** Operations+ , returnWith+ ) where++import GHC.Stack (withFrozenCallStack)++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.ReturnWith.Static qualified as R++-- | Provide the ability to return early with a value of type @r@.+data ReturnWith r :: Effect where+ ReturnWith :: r -> ReturnWith r m a++type instance DispatchOf (ReturnWith r) = Dynamic++-- | Run a computation that can return early with a value of type @r@ (via+-- "Effectful.ReturnWith.Static").+runReturnWith+ :: HasCallStack+ => Eff (ReturnWith r : es) r+ -> Eff es r+runReturnWith = reinterpret_ R.runReturnWith $ \case+ ReturnWith r -> R.returnWith r++-- | Return early with the given value.+returnWith+ :: (HasCallStack, ReturnWith r :> es)+ => r+ -- ^ The value.+ -> Eff es a+returnWith = withFrozenCallStack send . ReturnWith
+ src/Effectful/ReturnWith/Static.hs view
@@ -0,0 +1,112 @@+-- | Support for early return from a computation.+--+-- >>> import Control.Monad (when)+--+-- >>> :{+-- classify :: ReturnWith String :> es => Int -> Eff es String+-- classify n = do+-- when (n < 0) $ returnWith "negative"+-- when (n == 0) $ returnWith "zero"+-- pure "positive"+-- :}+--+-- >>> runEff . runReturnWith $ classify 5+-- "positive"+--+-- >>> runEff . runReturnWith $ classify (-5)+-- "negative"+--+-- === Interaction with threads+--+-- The 'ReturnWith' effect uses runtime exceptions underneath, so the usual+-- rules apply. In particular, in multi-threaded code a call to 'returnWith' in+-- a child thread will not automatically propagate to the parent. If you need+-- that, use functions such as @withAsync@ from the+-- [Effectful.Concurrent.Async](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent-Async.html)+-- module of the @effectful@ package (which propagate exceptions from child+-- threads to their parents) or arrange the propagation yourself.+--+-- For more information see the documentation of the+-- [Concurrent](https://hackage.haskell.org/package/effectful/docs/Effectful-Concurrent.html#t:Concurrent)+-- effect.+--+-- @since 2.7.0.0+module Effectful.ReturnWith.Static+ ( -- * Effect+ ReturnWith++ -- ** Handlers+ , runReturnWith++ -- ** Operations+ , returnWith+ ) where++import Data.Kind+import GHC.Stack++import Effectful+import Effectful.Dispatch.Static+import Effectful.Exception+import Effectful.Internal.Utils++-- | Provide the ability to return early with a value of type @r@.+data ReturnWith (r :: Type) :: Effect++type instance DispatchOf (ReturnWith r) = Static NoSideEffects+newtype instance StaticRep (ReturnWith r) = ReturnWith ReturnWithId++-- | Run a computation that can return early with a value of type @r@.+runReturnWith+ :: forall r es+ . HasCallStack+ => Eff (ReturnWith r : es) r+ -> Eff es r+runReturnWith action = do+ rid <- unsafeEff_ newReturnWithId+ evalStaticRep (ReturnWith @r rid) $ do+ catchJust (matchReturnWith rid) action pure++-- | Return early with the given value.+returnWith+ :: forall r es a. (HasCallStack, ReturnWith r :> es)+ => r+ -- ^ The value.+ -> Eff es a+returnWith r = do+ ReturnWith rid <- getStaticRep @(ReturnWith r)+ withFrozenCallStack throwIO $ ReturnWithWrapper rid callStack (toAny r)++----------------------------------------+-- Helpers++newtype ReturnWithId = ReturnWithId Unique+ deriving newtype Eq++-- | A unique is picked so that distinct 'ReturnWith' handlers for the same+-- type don't catch each other's values.+newReturnWithId :: IO ReturnWithId+newReturnWithId = ReturnWithId <$> newUnique++data ReturnWithWrapper = ReturnWithWrapper !ReturnWithId CallStack Any++instance Show ReturnWithWrapper where+ showsPrec p (ReturnWithWrapper _ cs _)+ = showParen (p > 10)+ $ ("Effectful.ReturnWith.Static.ReturnWithWrapper\n" ++)+ . (prettyCallStack cs ++)+ . ("\n\nIf you see this message, most likely a call to returnWith " ++)+ . ("escaped the scope of its handler, e.g. by being made from a thread " ++)+ . ("that outlived it, or was caught by an overly zealous exception " ++)+ . ("handler. For more information see the documentation of the " ++)+ . ("Effectful.ReturnWith.Static module." ++)++instance Exception ReturnWithWrapper where+ -- See discussion in https://github.com/haskell-effectful/effectful/pull/232.+ toException = asyncExceptionToException+ fromException = asyncExceptionFromException++matchReturnWith :: ReturnWithId -> ReturnWithWrapper -> Maybe r+matchReturnWith rid (ReturnWithWrapper rtag _ r)+ | rid == rtag = Just (fromAny r)+ | otherwise = Nothing
src/Effectful/State/Dynamic.hs view
@@ -1,7 +1,11 @@+-- The handlers need to interpret the deprecated StateM operation until it's+-- removed.+{-# OPTIONS_GHC -Wno-deprecations #-} -- | The dynamically dispatched variant of the 'State' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use one of the statically dispatched variants,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.State.MonadState' instance for compatibility with existing+-- code, it's recommended to use one of the statically dispatched variants, -- i.e. "Effectful.State.Static.Local" or "Effectful.State.Static.Shared". module Effectful.State.Dynamic ( -- * Effect@@ -31,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." #-}
src/Effectful/State/Static/Local.hs view
@@ -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." #-}
@@ -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." #-}
src/Effectful/Writer/Dynamic.hs view
@@ -1,8 +1,12 @@+{-# OPTIONS_GHC -Wno-orphans #-} -- | The dynamically dispatched variant of the 'Writer' effect. ----- /Note:/ unless you plan to change interpretations at runtime, it's--- recommended to use one of the statically dispatched variants,+-- /Note:/ unless you plan to change interpretations at runtime or you need the+-- t'Control.Monad.Writer.MonadWriter' instance for compatibility with existing+-- code, it's recommended to use one of the statically dispatched variants, -- i.e. "Effectful.Writer.Static.Local" or "Effectful.Writer.Static.Shared".+--+-- __If you just want to accumulate values, use "Effectful.Output.Dynamic".__ module Effectful.Writer.Dynamic ( -- * Effect Writer(..)@@ -25,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
src/Effectful/Writer/Static/Local.hs view
@@ -8,6 +8,8 @@ -- is inefficient. __This applies, in particular, to the standard list type__, -- which makes the 'Writer' effect pretty niche. --+-- __If you just want to accumulate values, use "Effectful.Output.Static.Local.Array" or "Effectful.Output.Static.Local.List".__+-- -- /Note:/ while the 'Control.Monad.Trans.Writer.Strict.Writer' from the -- @transformers@ package includes additional operations -- 'Control.Monad.Trans.Writer.Strict.pass' and
@@ -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