effectful 2.3.0.0 → 2.7.1.0
raw patch · 57 files changed
Files
- CHANGELOG.md +184/−0
- README.md +4/−4
- bench/Concurrency.hs +32/−26
- bench/Countdown.hs +82/−26
- bench/FileSizes.hs +51/−32
- bench/Main.hs +22/−6
- bench/Unlift.hs +2/−2
- effectful.cabal +72/−35
- src/Effectful/Concurrent.hs +23/−19
- src/Effectful/Concurrent/Async.hs +82/−46
- src/Effectful/Concurrent/Chan.hs +1/−1
- src/Effectful/Concurrent/Chan/Strict.hs +50/−0
- src/Effectful/Concurrent/Effect.hs +4/−4
- src/Effectful/Concurrent/MVar.hs +15/−2
- src/Effectful/Concurrent/MVar/Strict.hs +38/−33
- src/Effectful/Concurrent/MVar/Strict/Compat.hs +138/−0
- src/Effectful/Concurrent/QSem.hs +1/−1
- src/Effectful/Concurrent/QSemN.hs +1/−1
- src/Effectful/Concurrent/STM.hs +18/−3
- src/Effectful/Console/ByteString.hs +3/−3
- src/Effectful/Console/ByteString/Lazy.hs +3/−3
- src/Effectful/Console/Effect.hs +1/−1
- src/Effectful/Environment.hs +2/−2
- src/Effectful/FileSystem.hs +1/−1
- src/Effectful/FileSystem/Effect.hs +1/−1
- src/Effectful/FileSystem/File/OsPath.hs +150/−0
- src/Effectful/FileSystem/IO.hs +1/−1
- src/Effectful/FileSystem/IO/ByteString.hs +8/−10
- src/Effectful/FileSystem/IO/ByteString/Builder.hs +6/−7
- src/Effectful/FileSystem/IO/ByteString/Lazy.hs +3/−3
- src/Effectful/FileSystem/IO/File.hs +1/−1
- src/Effectful/FileSystem/OsPath.hs +345/−0
- src/Effectful/Prim/IORef.hs +79/−0
- src/Effectful/Prim/IORef/Strict.hs +66/−0
- src/Effectful/Process.hs +2/−2
- src/Effectful/Temporary.hs +2/−2
- src/Effectful/Timeout.hs +2/−2
- tests/AsyncTests.hs +2/−2
- tests/ConcurrencyTests.hs +50/−2
- tests/EnvTests.hs +136/−27
- tests/EnvironmentTests.hs +1/−1
- tests/ErrorTests.hs +25/−1
- tests/ExceptionTests.hs +131/−0
- tests/FileSystemTests.hs +53/−0
- tests/InputTests.hs +64/−0
- tests/LabeledTests.hs +61/−0
- tests/Main.hs +14/−0
- tests/NonDetTests.hs +99/−7
- tests/OutputTests.hs +97/−0
- tests/PrimTests.hs +1/−1
- tests/ReaderTests.hs +15/−19
- tests/ReturnWithTests.hs +88/−0
- tests/StateTests.hs +32/−13
- tests/TimeoutTests.hs +2/−2
- tests/UnliftTests.hs +100/−14
- tests/Utils.hs +10/−3
- tests/Word64MapTests.hs +95/−0
CHANGELOG.md view
@@ -1,3 +1,187 @@+# effectful-2.7.1.0 (2026-08-24)+* Re-export `Effectful.Labeled.Provider` and `Effectful.Labeled.Provider.List`+ from `effectful-core`.+* 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-2.7.0.0 (2026-08-24)+* Add `OsPath` variants of the `FilePath` based APIs+ (`Effectful.FileSystem.OsPath` for `System.Directory.OsPath` and+ `Effectful.FileSystem.File.OsPath` for `System.File.OsPath` from the+ `file-io` package).+* `runInBoundThread` and `runInUnboundThread` from `Effectful.Concurrent` no+ longer run the computation in a cloned environment, so changes to thread-local+ effects made within are no longer discarded.+* 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.+* 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).+* Fix typo in `Effectful.Concurrent.Async.waitEitherCatchCancel`.+* 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.+ - Drop ticks from the API of `Effectful.Concurrent.Chan.Strict`,+ `Effectful.Concurrent.MVar.Strict` and `Effectful.Prim.IORef.Strict` to+ match `strict-mutable-base` 2.0.0.0.+* **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-2.6.1.0 (2025-08-30)+* Add `MonadError`, `MonadReader`, `MonadState` and `MonadWriter` instances for+ `Eff` for compatibility with existing code.+* Re-export `writeTMVar` from `stm-2.5.1.0` in `Effectful.Concurrent.STM`.+* Add `cancelMany` to `Effectful.Concurrent.Async`.++# effectful-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.+* Re-export `ThreadId` from `Effectful.Concurrent` for convenience.+* **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-2.5.1.0 (2024-11-27)+* Add `passthrough` to `Effectful.Dispatch.Dynamic` for passing operations to+ the upstream handler within `interpose` and `impose` without having to fully+ pattern match on them.+* **Bugfixes**:+ - Fix a potential space leak related to `HasCallStack` quirks (see+ https://gitlab.haskell.org/ghc/ghc/-/issues/25520 for more information).++# effectful-2.5.0.0 (2024-10-23)+* Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make+ `emptyEff` and `sumEff` generate better call stacks.+* Explicitly define `setByteArray#` and `setOffAddr#` in the `Prim` instance of+ `Ref` for `primitive` < 0.9.0.0.+* **Bugfixes**:+ - `OnEmptyRollback` strategy of the `NonDet` effect is no longer broken.+* **Breaking changes**:+ - Remove `restoreEnv` function from `Effectful.Dispatch.Static.Primitive`+ since it was broken.+ - Base `Effectful.Exception` on `Control.Exception` instead of the+ `safe-exceptions` library for consistency with provided `MonadThrow` and+ `MonadCatch` instances.++# effectful-2.4.0.0 (2024-10-08)+* Add utility functions for handling effects that take the effect handler as the+ last parameter to `Effectful.Dispatch.Dynamic`.+* Add utility functions for handling first order effects to+ `Effectful.Dispatch.Dynamic`.+* Improve `Effectful.Labeled`, add `Effectful.Labeled.Error`,+ `Effectful.Labeled.Reader`, `Effectful.Labeled.State` and+ `Effectful.Labeled.Writer`.+* Add `throwErrorWith` and `throwError_` to `Effectful.Error.Static` and+ `Effectful.Error.Dynamic`.+* Add `HasCallStack` constraints where appropriate for better debugging+ experience.+* Add a `SeqForkUnlift` strategy to support running unlifting functions outside+ of the scope of effects they capture.+* Add `Effectful.Exception` with appropriate re-exports from the+ `safe-exceptions` library.+* Add `Effectful.Concurrent.Chan.Strict`.+* Add `Effectful.Prim.IORef` and `Effectful.Prim.IORef.Strict`.+* **Bugfixes**:+ - Ensure that a `LocalEnv` is only used in a thread it belongs to.+ - Properly roll back changes made to the environment when `OnEmptyRollback`+ policy for the `NonDet` effect is selected.+ - Fix a bug in `stateM` and `modifyM` of thread local `State` effect that+ might've caused dropped state updates+ ([#237](https://github.com/haskell-effectful/effectful/issues/237)).+* **Breaking changes**:+ - `localSeqLend`, `localLend`, `localSeqBorrow` and `localBorrow` now take a+ list of effects instead of a single one.+ - `Effectful.Error.Static.throwError` now requires the error type to have a+ `Show` constraint. If this is not the case for some of your error types, use+ `throwError_` for them.+ - `ThrowError` operation from the dynamic version of the `Error` effect was+ replaced with `ThrowErrorWith`.+ - `stateEnv` and `modifyEnv` now take pure modification functions. If you rely+ on their old forms, switch to a combination of `getEnv` and `putEnv`.+ - `runStateMVar`, `evalStateMVar` and `execStateMVar` now take a strict+ `MVar'` from the `strict-mutable-base` package.+ - `Effectful.Concurrent.MVar.Strict` is now a lifted version of+ `Control.Concurrent.MVar.Strict` from `strict-mutable-base`. The original+ module was renamed to `Effectful.Concurrent.MVar.Strict.Compat` and+ deprecated.++# effectful-2.3.1.0 (2024-06-07)+* Drop support for GHC 8.8.+* Remove inaccurate information from the `Show` instance of `ErrorWrapper`.+* Add `Effectful.Provider.List`, generalization of `Effectful.Provider`.+* Respect `withFrozenCallStack` used by callers of `send`.+* Support exchange of effects between the environment of the handler and the+ local one via `localSeqLend`, `localLend`, `localSeqBorrow` and `localBorrow`+ from `Effectful.Dispatch.Dynamic`.+ # effectful-2.3.0.0 (2023-09-13) * Deprecate `withConcEffToIO`. * Make `withEffToIO` take an explicit unlifting strategy for the sake of
README.md view
@@ -1,13 +1,12 @@ # effectful -[](https://github.com/haskell-effectful/effectful/actions?query=branch%3Amaster)+[](https://github.com/haskell-effectful/effectful/actions/workflows/haskell-ci.yml) [](https://hackage.haskell.org/package/effectful)-[](https://packdeps.haskellers.com/feed?needle=andrzej@rybczak.net) [](https://www.stackage.org/lts/package/effectful) [](https://www.stackage.org/nightly/package/effectful) -<img src="https://user-images.githubusercontent.com/387658/127747903-f728437f-2ee4-47b8-9f0c-5102fd44c8e4.png" width="128">+<img src="https://raw.githubusercontent.com/haskell-effectful/effectful/master/logo.svg" width="150"> An easy to use, fast extensible effects library with seamless integration with the existing Haskell ecosystem.@@ -161,7 +160,8 @@ For the examples see the *Introduction* sections of [`Effectful.Dispatch.Dynamic`](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Dynamic.html) and-[`Effectful.Dispatch.Static`](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Static.html).+[`Effectful.Dispatch.Static`](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Static.html)+(when in doubt, start with dynamic dispatch). ## Acknowledgements
bench/Concurrency.hs view
@@ -9,45 +9,58 @@ import Test.Tasty.Bench hiding (env) #endif +import Control.Concurrent import Control.Concurrent.Async import Control.Monad-import qualified Effectful.Concurrent.Async as A import Effectful+import Effectful.Concurrent.Async qualified as A+import Effectful.Concurrent.STM import Effectful.Dispatch.Dynamic import Utils concurrencyBenchmark :: Benchmark concurrencyBenchmark = bgroup "concurrency"- [ bgroup "shallow" $ map shallowBench [1, 10, 100]- , bgroup "deep" $ map deepBench [1, 10, 100]+ [ bgroup "shallow" $+ [ bench "MultiFork" $ nfAppIO (runShallow . testMultiFork) 1000+ ] ++ map shallowBenchUnmask [1, 10, 100]+ , bgroup "deep" $+ [ bench "MultiFork" $ nfAppIO (runDeep . testMultiFork) 1000+ ] ++ map deepBenchUnmask [1, 10, 100] ] -shallowBench :: Int -> Benchmark-shallowBench n = bgroup ("unmask " ++ show n ++ "x")+testMultiFork :: IOE :> es => Int -> Eff es ()+testMultiFork threads = runConcurrent $ do+ v <- newTVarIO 0+ withEffToIO (ConcUnlift Persistent $ Limited threads) $ \unlift -> do+ replicateM_ threads . liftIO . forkIO . unlift . atomically $ modifyTVar' v (+1)+ atomically $ do+ acc <- readTVar v+ when (acc < threads) retry++----------------------------------------++shallowBenchUnmask :: Int -> Benchmark+shallowBenchUnmask n = bgroup ("unmask " ++ show n ++ "x") [ bench "async (IO)" $ nfAppIO (asyncBenchIO n) op , bench "async (Eff)" $ nfAppIO (runShallow . A.runConcurrent . asyncBench n) op , bench "Fork (localUnliftIO/withLiftMapIO)" $ nfAppIO (runShallow . runFork1 . forkBench n) op- , bench "Fork (localUnlift/withLiftMap)" $- nfAppIO (runShallow . runFork2 . forkBench n) op , bench "Fork (localLiftUnliftIO)" $- nfAppIO (runShallow . runFork3 . forkBench n) op+ nfAppIO (runShallow . runFork2 . forkBench n) op , bench "Fork (localLiftUnlift)" $- nfAppIO (runShallow . runFork4 . forkBench n) op+ nfAppIO (runShallow . runFork3 . forkBench n) op ] -deepBench :: Int -> Benchmark-deepBench n = bgroup ("unmask " ++ show n ++ "x")+deepBenchUnmask :: Int -> Benchmark+deepBenchUnmask n = bgroup ("unmask " ++ show n ++ "x") [ bench "async (Eff)" $ nfAppIO (runDeep . A.runConcurrent . asyncBench n) op , bench "Fork (localUnliftIO/withLiftMapIO)" $ nfAppIO (runDeep . runFork1 . forkBench n) op- , bench "Fork (localUnlift/withLiftMap)" $- nfAppIO (runDeep . runFork2 . forkBench n) op , bench "Fork (localLiftUnliftIO)" $- nfAppIO (runDeep . runFork3 . forkBench n) op+ nfAppIO (runDeep . runFork2 . forkBench n) op , bench "Fork (localLiftUnlift)" $- nfAppIO (runDeep . runFork4 . forkBench n) op+ nfAppIO (runDeep . runFork3 . forkBench n) op ] op :: Monad m => m Int@@ -67,23 +80,16 @@ localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask --- | Uses 'localUnlift' and 'withLiftMap'.-runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a-runFork2 = reinterpret A.runConcurrent $ \env -> \case- ForkWithUnmask m -> withLiftMap env $ \liftMap -> do- localUnlift env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do- A.asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask- -- | Uses 'localLiftUnliftIO'.-runFork3 :: IOE :> es => Eff (Fork : es) a -> Eff es a-runFork3 = interpret $ \env -> \case+runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a+runFork2 = interpret $ \env -> \case ForkWithUnmask m -> do localLiftUnliftIO env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift -- | Uses 'localLiftUnlift'.-runFork4 :: IOE :> es => Eff (Fork : es) a -> Eff es a-runFork4 = reinterpret A.runConcurrent $ \env -> \case+runFork3 :: IOE :> es => Eff (Fork : es) a -> Eff es a+runFork3 = reinterpret A.runConcurrent $ \env -> \case ForkWithUnmask m -> do localLiftUnlift env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do A.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift
bench/Countdown.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+-- The deprecated stateM and StateM need to be benchmarked until they're+-- removed.+{-# OPTIONS_GHC -Wno-deprecations #-} module Countdown where import Control.Monad.ST@@ -6,51 +9,51 @@ -- eff #ifdef VERSION_eff-import qualified Control.Effect as L+import Control.Effect qualified as L #endif -- cleff #ifdef VERSION_cleff-import qualified Cleff as C-import qualified Cleff.Reader as C-import qualified Cleff.State as C+import Cleff qualified as C+import Cleff.Reader qualified as C+import Cleff.State qualified as C #endif -- effectful-import qualified Effectful as E-import qualified Effectful.Dispatch.Dynamic as E-import qualified Effectful.Labeled as E-import qualified Effectful.Reader.Static as E-import qualified Effectful.State.Dynamic as ED-import qualified Effectful.State.Static.Local as EL-import qualified Effectful.State.Static.Shared as ES+import Effectful qualified as E+import Effectful.Dispatch.Dynamic qualified as E+import Effectful.Labeled qualified as E+import Effectful.Reader.Static qualified as E+import Effectful.State.Dynamic qualified as ED+import Effectful.State.Static.Local qualified as EL+import Effectful.State.Static.Shared qualified as ES -- freer-simple #ifdef VERSION_freer_simple-import qualified Control.Monad.Freer as FS-import qualified Control.Monad.Freer.Reader as FS-import qualified Control.Monad.Freer.State as FS+import Control.Monad.Freer qualified as FS+import Control.Monad.Freer.Reader qualified as FS+import Control.Monad.Freer.State qualified as FS #endif -- fused-effects #ifdef VERSION_fused_effects-import qualified Control.Algebra as FE-import qualified Control.Carrier.Reader as FE-import qualified Control.Carrier.State.Strict as FE+import Control.Algebra qualified as FE+import Control.Carrier.Reader qualified as FE+import Control.Carrier.State.Strict qualified as FE #endif -- mtl #ifdef VERSION_mtl-import qualified Control.Monad.Reader as M-import qualified Control.Monad.State as M+import Control.Monad.Reader qualified as M+import Control.Monad.State qualified as M import Data.Functor.Identity #endif -- polysemy #ifdef VERSION_polysemy-import qualified Polysemy as P-import qualified Polysemy.Reader as P-import qualified Polysemy.State as P+import Polysemy qualified as P+import Polysemy.Reader qualified as P+import Polysemy.State qualified as P #endif ----------------------------------------@@ -95,11 +98,11 @@ programMtl {-# NOINLINE programMtl #-} -countdownMtl :: Integer -> (Integer, Integer)-countdownMtl n = flip M.runState n $ programMtl+countdownMtlTransformers :: Integer -> (Integer, Integer)+countdownMtlTransformers n = flip M.runState n $ programMtl -countdownMtlDeep :: Integer -> (Integer, Integer)-countdownMtlDeep n = runIdentity+countdownMtlTransformersDeep :: Integer -> (Integer, Integer)+countdownMtlTransformersDeep n = runIdentity . runR . runR . runR . runR . runR . flip M.runStateT n . runR . runR . runR . runR . runR@@ -107,6 +110,18 @@ where runR = flip M.runReaderT () +countdownMtlEffectful :: Integer -> (Integer, Integer)+countdownMtlEffectful n = E.runPureEff . ED.runStateLocal n $ programMtl++countdownMtlEffectfulDeep :: Integer -> (Integer, Integer)+countdownMtlEffectfulDeep n = E.runPureEff+ . runR . runR . runR . runR . runR+ . ED.runStateLocal n+ . runR . runR . runR . runR . runR+ $ programMtl+ where+ runR = E.runReader ()+ #endif ----------------------------------------@@ -282,6 +297,47 @@ . runDoubleStateShared n . runR . runR . runR . runR . runR $ programEffectfulDynamic+ where+ runR = E.runReader ()++----------------------------------------+-- effectful (labeled-dynamic-send)++programEffectfulLabeledDynamicSend+ :: E.Labeled "s" (ED.State Integer) E.:> es+ => E.Eff es Integer+programEffectfulLabeledDynamicSend = do+ n <- E.send . E.Labeled @"s" $ ED.Get @Integer+ if n <= 0+ then pure n+ else do+ E.send . E.Labeled @"s" $ ED.Put (n - 1)+ programEffectfulLabeledDynamicSend+{-# NOINLINE programEffectfulLabeledDynamicSend #-}++countdownEffectfulLabeledDynSendLocal :: Integer -> (Integer, Integer)+countdownEffectfulLabeledDynSendLocal n =+ E.runPureEff . E.runLabeled @"s" (ED.runStateLocal n) $ programEffectfulLabeledDynamicSend++countdownEffectfulLabeledDynSendShared :: Integer -> (Integer, Integer)+countdownEffectfulLabeledDynSendShared n =+ E.runPureEff . E.runLabeled @"s" (ED.runStateShared n) $ programEffectfulLabeledDynamicSend++countdownEffectfulLabeledDynSendLocalDeep :: Integer -> (Integer, Integer)+countdownEffectfulLabeledDynSendLocalDeep n = E.runPureEff+ . runR . runR . runR . runR . runR+ . E.runLabeled @"s" (ED.runStateLocal n)+ . runR . runR . runR . runR . runR+ $ programEffectfulLabeledDynamicSend+ where+ runR = E.runReader ()++countdownEffectfulLabeledDynSendSharedDeep :: Integer -> (Integer, Integer)+countdownEffectfulLabeledDynSendSharedDeep n = E.runPureEff+ . runR . runR . runR . runR . runR+ . E.runLabeled @"s" (ED.runStateShared n)+ . runR . runR . runR . runR . runR+ $ programEffectfulLabeledDynamicSend where runR = E.runReader ()
bench/FileSizes.hs view
@@ -1,59 +1,59 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FieldSelectors #-} module FileSizes where import Control.Exception import Control.Monad.IO.Class import Data.IORef import Data.Text (Text)+import Data.Text qualified as T import System.Posix-import qualified Data.Text as T -- effectful-import qualified Effectful as E-import qualified Effectful.Dispatch.Dynamic as E-import qualified Effectful.Reader.Static as E-import qualified Effectful.State.Static.Local as E+import Effectful qualified as E+import Effectful.Dispatch.Dynamic qualified as E+import Effectful.Reader.Static qualified as E+import Effectful.State.Static.Local qualified as E -- eff #ifdef VERSION_eff-import qualified Control.Effect as L+import Control.Effect qualified as L #endif -- cleff #ifdef VERSION_cleff-import qualified Cleff as C-import qualified Cleff.Reader as C-import qualified Cleff.State as C+import Cleff qualified as C+import Cleff.Reader qualified as C+import Cleff.State qualified as C #endif -- freer-simple #ifdef VERSION_freer_simple-import qualified Control.Monad.Freer as FS-import qualified Control.Monad.Freer.Reader as FS-import qualified Control.Monad.Freer.State as FS+import Control.Monad.Freer qualified as FS+import Control.Monad.Freer.Reader qualified as FS+import Control.Monad.Freer.State qualified as FS #endif -- fused-effects #ifdef VERSION_fused_effects-import qualified Control.Algebra as FE-import qualified Control.Effect.Sum as FE-import qualified Control.Carrier.Reader as FE-import qualified Control.Carrier.State.Strict as FE+import Control.Algebra qualified as FE+import Control.Effect.Sum qualified as FE+import Control.Carrier.Reader qualified as FE+import Control.Carrier.State.Strict qualified as FE #endif -- mtl #ifdef VERSION_mtl-import qualified Control.Monad.State as M-import qualified Control.Monad.Reader as M+import Control.Monad.State qualified as M+import Control.Monad.Reader qualified as M #endif -- polysemy #ifdef VERSION_polysemy-import qualified Polysemy as P-import qualified Polysemy.Reader as P-import qualified Polysemy.State as P+import Polysemy qualified as P+import Polysemy.Reader qualified as P+import Polysemy.State qualified as P #endif tryGetFileSize :: FilePath -> IO (Maybe Int)@@ -102,7 +102,7 @@ effectful_tryFileSize = E.send . Effectful_tryFileSize effectful_runFile :: E.IOE E.:> es => E.Eff (Effectful_File : es) a -> E.Eff es a-effectful_runFile = E.interpret \_ -> \case+effectful_runFile = E.interpret_ \case Effectful_tryFileSize path -> liftIO $ tryGetFileSize path data Effectful_Logging :: E.Effect where@@ -116,7 +116,7 @@ effectful_runLogging :: E.Eff (Effectful_Logging : es) a -> E.Eff es (a, [Text])-effectful_runLogging = E.reinterpret (E.runState []) \_ -> \case+effectful_runLogging = E.reinterpret_ (E.runState []) \case Effectful_logMsg msg -> E.modify (msg :) ----------@@ -363,7 +363,7 @@ fe_tryFileSize = FE.send . FE_tryFileSize newtype FE_FileC m a = FE_FileC { fe_runFileC :: m a }- deriving (Applicative, Functor, Monad, MonadIO)+ deriving newtype (Applicative, Functor, Monad, MonadIO) instance ( MonadIO m@@ -380,7 +380,7 @@ fe_logMsg = FE.send . FE_logMsg . T.pack newtype FE_LoggingC m a = FE_LoggingC { fe_runLoggingC :: FE.StateC [Text] m a }- deriving (Applicative, Functor, Monad)+ deriving newtype (Applicative, Functor, Monad) instance ( FE.Algebra sig m@@ -439,8 +439,11 @@ class Monad m => MonadFile m where mtl_tryFileSize :: FilePath -> m (Maybe Int) +instance Effectful_File E.:> es => MonadFile (E.Eff es) where+ mtl_tryFileSize = effectful_tryFileSize+ newtype FileT m a = FileT { runFileT :: m a }- deriving (Functor, Applicative, Monad, MonadIO)+ deriving newtype (Functor, Applicative, Monad, MonadIO) instance M.MonadTrans FileT where lift = FileT@@ -458,8 +461,11 @@ class Monad m => MonadLog m where mtl_logMsg :: String -> m () +instance Effectful_Logging E.:> es => MonadLog (E.Eff es) where+ mtl_logMsg = effectful_logMsg+ newtype LoggingT m a = LoggingT (M.StateT [Text] m a)- deriving (Functor, Applicative, Monad, MonadIO, M.MonadTrans)+ deriving newtype (Functor, Applicative, Monad, MonadIO, M.MonadTrans) instance {-# OVERLAPPABLE #-} ( MonadLog m@@ -492,17 +498,30 @@ pure $ sum sizes {-# NOINLINE mtl_program #-} -mtl_calculateFileSizes :: [FilePath] -> IO (Int, [Text])-mtl_calculateFileSizes = runFileT . runLoggingT . mtl_program+mtl_calculateFileSizesTransformers :: [FilePath] -> IO (Int, [Text])+mtl_calculateFileSizesTransformers = runFileT . runLoggingT . mtl_program -mtl_calculateFileSizesDeep :: [FilePath] -> IO (Int, [Text])-mtl_calculateFileSizesDeep+mtl_calculateFileSizesTransformersDeep :: [FilePath] -> IO (Int, [Text])+mtl_calculateFileSizesTransformersDeep = runR . runR . runR . runR . runR . runFileT . runLoggingT . runR . runR . runR . runR . runR . mtl_program where runR = flip M.runReaderT ()++mtl_calculateFileSizesEffectful :: [FilePath] -> IO (Int, [Text])+mtl_calculateFileSizesEffectful =+ E.runEff . effectful_runFile . effectful_runLogging . mtl_program++mtl_calculateFileSizesEffectfulDeep :: [FilePath] -> IO (Int, [Text])+mtl_calculateFileSizesEffectfulDeep = E.runEff+ . runR . runR . runR . runR . runR+ . effectful_runFile . effectful_runLogging+ . runR . runR . runR . runR . runR+ . mtl_program+ where+ runR = E.runReader () #endif
bench/Main.hs view
@@ -64,6 +64,10 @@ [ bench "shallow" $ nf countdownEffectfulDynLocal n , bench "deep" $ nf countdownEffectfulDynLocalDeep n ]+ , bgroup "effectful (local/dynamic/labeled/send)"+ [ bench "shallow" $ nf countdownEffectfulLabeledDynSendLocal n+ , bench "deep" $ nf countdownEffectfulLabeledDynSendLocalDeep n+ ] , bgroup "effectful (shared/static)" [ bench "shallow" $ nf countdownEffectfulShared n , bench "deep" $ nf countdownEffectfulSharedDeep n@@ -72,6 +76,10 @@ [ bench "shallow" $ nf countdownEffectfulDynShared n , bench "deep" $ nf countdownEffectfulDynSharedDeep n ]+ , bgroup "effectful (shared/dynamic/labeled/send)"+ [ bench "shallow" $ nf countdownEffectfulLabeledDynSendShared n+ , bench "deep" $ nf countdownEffectfulLabeledDynSendSharedDeep n+ ] #ifdef VERSION_cleff , bgroup "cleff (local)" [ bench "shallow" $ nf countdownCleffLocal n@@ -95,10 +103,14 @@ ] #endif #ifdef VERSION_mtl- , bgroup "mtl"- [ bench "shallow" $ nf countdownMtl n- , bench "deep" $ nf countdownMtlDeep n+ , bgroup "mtl (effectful)"+ [ bench "shallow" $ nf countdownMtlEffectful n+ , bench "deep" $ nf countdownMtlEffectfulDeep n ]+ , bgroup "mtl (transformers)"+ [ bench "shallow" $ nf countdownMtlTransformers n+ , bench "deep" $ nf countdownMtlTransformersDeep n+ ] #endif #ifdef VERSION_fused_effects , bgroup "fused-effects"@@ -140,9 +152,13 @@ ] #endif #ifdef VERSION_mtl- , bgroup "mtl"- [ bench "shallow" $ nfAppIO mtl_calculateFileSizes (take n files)- , bench "deep" $ nfAppIO mtl_calculateFileSizesDeep (take n files)+ , bgroup "mtl (effectful)"+ [ bench "shallow" $ nfAppIO mtl_calculateFileSizesEffectful (take n files)+ , bench "deep" $ nfAppIO mtl_calculateFileSizesEffectfulDeep (take n files)+ ]+ , bgroup "mtl (transformers)"+ [ bench "shallow" $ nfAppIO mtl_calculateFileSizesTransformers (take n files)+ , bench "deep" $ nfAppIO mtl_calculateFileSizesTransformersDeep (take n files) ] #endif #ifdef VERSION_fused_effects
bench/Unlift.hs view
@@ -9,12 +9,12 @@ import Test.Tasty.Bench #endif -import qualified UnliftIO as U+import UnliftIO qualified as U import Effectful+import Effectful.Concurrent.Async qualified as A import Effectful.State.Dynamic import Utils-import qualified Effectful.Concurrent.Async as A unliftBenchmark :: Benchmark unliftBenchmark = bgroup "unlifting"
effectful.cabal view
@@ -1,7 +1,7 @@-cabal-version: 2.4+cabal-version: 3.8 build-type: Simple name: effectful-version: 2.3.0.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 is the "batteries-included" variant. See the @<https://hackage.haskell.org/package/effectful-core effectful-core>@ package if you need a more limited dependency footprint or want to browse@@ -22,8 +22,7 @@ CHANGELOG.md README.md -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.7 || ==9.6.2- || ==9.8.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@@ -35,44 +34,39 @@ default: False common language- ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors+ ghc-options: -Wall+ -Wcompat+ -Wmissing-deriving-strategies+ -Werror=prepositive-qualified-module - default-language: Haskell2010+ default-language: GHC2021 - default-extensions: BangPatterns- ConstraintKinds- DataKinds- DeriveFunctor- DeriveGeneric- FlexibleContexts- FlexibleInstances- GADTs- GeneralizedNewtypeDeriving+ default-extensions: DataKinds+ DeepSubsumption+ DerivingStrategies+ DuplicateRecordFields LambdaCase- MultiParamTypeClasses+ NoFieldSelectors NoStarIsType- RankNTypes- RecordWildCards+ OverloadedRecordDot RoleAnnotations- ScopedTypeVariables- StandaloneDeriving- TupleSections- TypeApplications TypeFamilies- TypeOperators+ UndecidableInstances library import: language - build-depends: base >= 4.13 && < 5- , async >= 2.2.2+ build-depends: base >= 4.18 && < 5+ , async >= 2.2.5 , bytestring >= 0.10- , directory >= 1.3.2- , effectful-core >= 2.3.0.0 && < 2.3.1.0+ , directory >= 1.3.8+ , effectful-core >= 2.7.1.0 && < 2.7.2.0+ , file-io >= 0.1.4+ , filepath >= 1.4.100 , process >= 1.6.9-+ , strict-mutable-base >= 2.0.0.0 && < 3 , time >= 1.9.2- , stm >= 2.5.0.0+ , stm >= 2.5.1.0 , unliftio >= 0.2.20 hs-source-dirs: src@@ -80,8 +74,10 @@ exposed-modules: Effectful.Concurrent Effectful.Concurrent.Async Effectful.Concurrent.Chan+ Effectful.Concurrent.Chan.Strict Effectful.Concurrent.MVar Effectful.Concurrent.MVar.Strict+ Effectful.Concurrent.MVar.Strict.Compat Effectful.Concurrent.STM Effectful.Concurrent.QSem Effectful.Concurrent.QSemN@@ -89,11 +85,15 @@ Effectful.Console.ByteString.Lazy Effectful.Environment Effectful.FileSystem+ Effectful.FileSystem.File.OsPath Effectful.FileSystem.IO Effectful.FileSystem.IO.ByteString Effectful.FileSystem.IO.ByteString.Builder Effectful.FileSystem.IO.ByteString.Lazy Effectful.FileSystem.IO.File+ Effectful.FileSystem.OsPath+ Effectful.Prim.IORef+ Effectful.Prim.IORef.Strict Effectful.Process Effectful.Temporary Effectful.Timeout@@ -105,15 +105,37 @@ reexported-modules: Effectful , Effectful.Dispatch.Dynamic , Effectful.Dispatch.Static- , Effectful.Error.Static , Effectful.Error.Dynamic+ , Effectful.Error.Static+ , Effectful.Exception , Effectful.Fail+ , Effectful.Input.Dynamic+ , Effectful.Input.Static+ , Effectful.Input.Static.Action , 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@@ -124,15 +146,23 @@ test-suite test import: language + if impl(ghc >= 9.8)+ ghc-options: -Wno-x-partial+ ghc-options: -threaded -rtsopts -with-rtsopts=-N4 build-depends: base+ , bytestring , containers , effectful , effectful-core , exceptions+ , filepath , lifted-base , primitive+ , random+ , safe-exceptions+ , strict-mutable-base , tasty , tasty-hunit , unliftio@@ -147,13 +177,20 @@ EnvTests EnvironmentTests ErrorTests+ ExceptionTests+ FileSystemTests+ InputTests+ LabeledTests NonDetTests+ OutputTests PrimTests ReaderTests+ ReturnWithTests StateTests TimeoutTests UnliftTests Utils+ Word64MapTests benchmark bench import: language@@ -169,11 +206,11 @@ if impl(ghc < 9.9) build-depends: freer-simple >= 1.2.1.2 - if impl(ghc < 9.9)- build-depends: fused-effects >= 1.1.2.2+ if impl(ghc < 9.15)+ build-depends: fused-effects >= 1.1.2.3 - if impl(ghc < 9.7)- build-depends: polysemy >= 1.9.1.0+ if impl(ghc < 9.15)+ build-depends: polysemy >= 1.9.2.0 build-depends: base , async
src/Effectful/Concurrent.hs view
@@ -20,6 +20,7 @@ , runConcurrent -- * Basic concurrency operations+ , C.ThreadId , myThreadId , forkIO , forkFinally@@ -59,13 +60,13 @@ , C.rtsSupportsBoundThreads ) where +import Control.Concurrent qualified as C import Control.Exception (Exception, SomeException) import Data.Bifunctor (second)+import GHC.Conc qualified as GHC import System.Mem.Weak (Weak) import System.Posix.Types (Fd) import UnliftIO.STM (STM)-import qualified Control.Concurrent as C-import qualified GHC.Conc as GHC import Effectful import Effectful.Concurrent.Effect@@ -81,14 +82,14 @@ myThreadId = unsafeEff_ C.myThreadId -- | Lifted 'C.forkIO'.-forkIO :: Concurrent :> es => Eff es () -> Eff es C.ThreadId+forkIO :: (HasCallStack, Concurrent :> es) => Eff es () -> Eff es C.ThreadId forkIO k = unsafeEff $ \es -> do esF <- cloneEnv es C.forkIO $ unEff k esF -- | Lifted 'C.forkFinally'. forkFinally- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => Eff es a -> (Either SomeException a -> Eff es ()) -> Eff es C.ThreadId@@ -98,7 +99,7 @@ -- | Lifted 'C.forkIOWithUnmask'. forkIOWithUnmask- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => ((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es C.ThreadId forkIOWithUnmask = liftForkWithUnmask C.forkIOWithUnmask@@ -115,14 +116,14 @@ -- Threads with affinity -- | Lifted 'C.forkOn'.-forkOn :: Concurrent :> es => Int -> Eff es () -> Eff es C.ThreadId+forkOn :: (HasCallStack, Concurrent :> es) => Int -> Eff es () -> Eff es C.ThreadId forkOn n k = unsafeEff $ \es -> do esF <- cloneEnv es C.forkOn n (unEff k esF) -- | Lifted 'C.forkOnWithUnmask'. forkOnWithUnmask- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => Int -> ((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es C.ThreadId@@ -180,14 +181,14 @@ -- Bound threads -- | Lifted 'C.forkOS'.-forkOS :: Concurrent :> es => Eff es () -> Eff es C.ThreadId+forkOS :: (HasCallStack, Concurrent :> es) => Eff es () -> Eff es C.ThreadId forkOS k = unsafeEff $ \es -> do esF <- cloneEnv es C.forkOS $ unEff k esF --- | Lifted 'E.forkOSWithUnmask'.+-- | Lifted 'C.forkOSWithUnmask'. forkOSWithUnmask- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => ((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es C.ThreadId forkOSWithUnmask = liftForkWithUnmask C.forkOSWithUnmask@@ -197,16 +198,18 @@ isCurrentThreadBound = unsafeEff_ C.isCurrentThreadBound -- | Lifted 'C.runInBoundThread'.-runInBoundThread :: Concurrent :> es => Eff es a -> Eff es a-runInBoundThread k = unsafeEff $ \es -> do- esF <- cloneEnv es- C.runInBoundThread $ unEff k esF+runInBoundThread :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es a+runInBoundThread k = reallyUnsafeUnliftIO $ \unlift -> do+ -- The worker thread runs the computation while the calling thread blocks, so+ -- even though a different thread accesses the environment, the execution is+ -- strictly sequential and sharing it is fine.+ C.runInBoundThread $ unlift k -- | Lifted 'C.runInUnboundThread'.-runInUnboundThread :: Concurrent :> es => Eff es a -> Eff es a-runInUnboundThread k = unsafeEff $ \es -> do- esF <- cloneEnv es- C.runInUnboundThread $ unEff k esF+runInUnboundThread :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es a+runInUnboundThread k = reallyUnsafeUnliftIO $ \unlift -> do+ -- See the comment in runInBoundThread.+ C.runInUnboundThread $ unlift k ---------------------------------------- -- Weak references to ThreadIds@@ -219,7 +222,8 @@ -- Helpers liftForkWithUnmask- :: (((forall c. IO c -> IO c) -> IO a) -> IO C.ThreadId)+ :: HasCallStack+ => (((forall c. IO c -> IO c) -> IO a) -> IO C.ThreadId) -> ((forall c. Eff es c -> Eff es c) -> Eff es a) -> Eff es C.ThreadId liftForkWithUnmask fork action = unsafeEff $ \es -> do
src/Effectful/Concurrent/Async.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE UndecidableInstances #-} -- | Lifted "Control.Concurrent.Async". module Effectful.Concurrent.Async ( -- * Effect@@ -18,7 +17,8 @@ -- ** Querying 'Async's , wait, poll, waitCatch, A.asyncThreadId- , cancel, uninterruptibleCancel, cancelWith, A.AsyncCancelled(..)+ , cancel, cancelMany, uninterruptibleCancel, cancelWith+ , A.AsyncCancelled(..) , A.compareAsyncs -- ** High-level utilities@@ -80,9 +80,9 @@ import Control.Exception (Exception, SomeException) import Control.Monad (forever) import Data.Kind (Type)-import qualified Control.Concurrent.Async as A-import qualified UnliftIO.Async as U-import qualified UnliftIO.Internals.Async as I+import Control.Concurrent.Async qualified as A+import UnliftIO.Async qualified as U+import UnliftIO.Internals.Async qualified as I import Effectful import Effectful.Concurrent.Effect@@ -91,27 +91,27 @@ import Effectful.Dispatch.Static.Unsafe -- | Lifted 'A.async'.-async :: Concurrent :> es => Eff es a -> Eff es (Async a)+async :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es (Async a) async = liftAsync A.async -- | Lifted 'A.asyncBound'.-asyncBound :: Concurrent :> es => Eff es a -> Eff es (Async a)+asyncBound :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es (Async a) asyncBound = liftAsync A.asyncBound -- | Lifted 'A.asyncOn'.-asyncOn :: Concurrent :> es => Int -> Eff es a -> Eff es (Async a)+asyncOn :: (HasCallStack, Concurrent :> es) => Int -> Eff es a -> Eff es (Async a) asyncOn cpu = liftAsync (A.asyncOn cpu) -- | Lifted 'A.asyncWithUnmask'. asyncWithUnmask- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => ((forall b. Eff es b -> Eff es b) -> Eff es a) -> Eff es (Async a) asyncWithUnmask = liftAsyncWithUnmask A.asyncWithUnmask -- | Lifted 'A.asyncOnWithUnmask'. asyncOnWithUnmask- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => Int -> ((forall b. Eff es b -> Eff es b) -> Eff es a) -> Eff es (Async a)@@ -119,7 +119,7 @@ -- | Lifted 'A.withAsync'. withAsync- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => Eff es a -> (Async a -> Eff es b) -> Eff es b@@ -127,7 +127,7 @@ -- | Lifted 'A.withAsyncBound'. withAsyncBound- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => Eff es a -> (Async a -> Eff es b) -> Eff es b@@ -135,7 +135,7 @@ -- | Lifted 'A.withAsyncOn'. withAsyncOn- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => Int -> Eff es a -> (Async a -> Eff es b)@@ -144,7 +144,7 @@ -- | Lifted 'A.withAsyncWithUnmask'. withAsyncWithUnmask- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => ((forall c. Eff es c -> Eff es c) -> Eff es a) -> (Async a -> Eff es b) -> Eff es b@@ -152,7 +152,7 @@ -- | Lifted 'A.withAsyncOnWithUnmask'. withAsyncOnWithUnmask- :: Concurrent :> es+ :: (HasCallStack, Concurrent :> es) => Int -> ((forall c. Eff es c -> Eff es c) -> Eff es a) -> (Async a -> Eff es b)@@ -174,6 +174,12 @@ cancel :: Concurrent :> es => Async a -> Eff es () cancel = unsafeEff_ . A.cancel +-- | Lifted 'A.cancelMany'.+--+-- @since 2.6.1.0+cancelMany :: Concurrent :> es => [Async a] -> Eff es ()+cancelMany = unsafeEff_ . A.cancelMany+ -- | Lifted 'A.cancelWith'. cancelWith :: (Exception e, Concurrent :> es) => Async a -> e -> Eff es () cancelWith a = unsafeEff_ . A.cancelWith a@@ -241,7 +247,7 @@ => Async a -> Async b -> Eff es (Either (Either SomeException a) (Either SomeException b))-waitEitherCatchCancel a b = unsafeEff_ $ A.waitEitherCatch a b+waitEitherCatchCancel a b = unsafeEff_ $ A.waitEitherCatchCancel a b -- | Lifted 'A.waitEither_'. waitEither_ :: Concurrent :> es => Async a -> Async b -> Eff es ()@@ -268,22 +274,22 @@ link2Only f a b = unsafeEff_ $ A.link2Only f a b -- | Lifted 'A.race'.-race :: Concurrent :> es => Eff es a -> Eff es b -> Eff es (Either a b)+race :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es b -> Eff es (Either a b) race ma mb = unsafeEff $ \es -> do A.race (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es) -- | Lifted 'A.race_'.-race_ :: Concurrent :> es => Eff es a -> Eff es b -> Eff es ()+race_ :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es b -> Eff es () race_ ma mb = unsafeEff $ \es -> do A.race_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es) -- | Lifted 'A.concurrently'.-concurrently :: Concurrent :> es => Eff es a -> Eff es b -> Eff es (a, b)+concurrently :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es b -> Eff es (a, b) concurrently ma mb = unsafeEff $ \es -> do A.concurrently (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es) -- | Lifted 'A.concurrently_'.-concurrently_ :: Concurrent :> es => Eff es a -> Eff es b -> Eff es ()+concurrently_ :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es b -> Eff es () concurrently_ ma mb = unsafeEff $ \es -> do A.concurrently_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es) @@ -293,7 +299,7 @@ -- | Lifted 'A.mapConcurrently'. mapConcurrently- :: (Traversable f, Concurrent :> es)+ :: (HasCallStack, Traversable f, Concurrent :> es) => (a -> Eff es b) -> f a -> Eff es (f b)@@ -302,7 +308,7 @@ -- | Lifted 'A.mapConcurrently_'. mapConcurrently_- :: (Foldable f, Concurrent :> es)+ :: (HasCallStack, Foldable f, Concurrent :> es) => (a -> Eff es b) -> f a -> Eff es ()@@ -311,7 +317,7 @@ -- | Lifted 'A.forConcurrently'. forConcurrently- :: (Traversable f, Concurrent :> es)+ :: (HasCallStack, Traversable f, Concurrent :> es) => f a -> (a -> Eff es b) -> Eff es (f b)@@ -320,7 +326,7 @@ -- | Lifted 'A.forConcurrently_'. forConcurrently_- :: (Foldable f, Concurrent :> es)+ :: (HasCallStack, Foldable f, Concurrent :> es) => f a -> (a -> Eff es b) -> Eff es ()@@ -328,12 +334,20 @@ U.forConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es) -- | Lifted 'A.replicateConcurrently'.-replicateConcurrently :: Concurrent :> es => Int -> Eff es a -> Eff es [a]+replicateConcurrently+ :: (HasCallStack, Concurrent :> es)+ => Int+ -> Eff es a+ -> Eff es [a] replicateConcurrently n f = unsafeEff $ \es -> do U.replicateConcurrently n (unEff f =<< cloneEnv es) -- | Lifted 'A.replicateConcurrently_'.-replicateConcurrently_ :: Concurrent :> es => Int -> Eff es a -> Eff es ()+replicateConcurrently_+ :: (HasCallStack, Concurrent :> es)+ => Int+ -> Eff es a+ -> Eff es () replicateConcurrently_ n f = unsafeEff $ \es -> do U.replicateConcurrently_ n (unEff f =<< cloneEnv es) @@ -342,7 +356,7 @@ -- | Lifted 'U.pooledMapConcurrentlyN'. pooledMapConcurrentlyN- :: (Concurrent :> es, Traversable t)+ :: (HasCallStack, Concurrent :> es, Traversable t) => Int -> (a -> Eff es b) -> t a@@ -352,16 +366,16 @@ -- | Lifted 'U.pooledMapConcurrently'. pooledMapConcurrently- :: (Concurrent :> es, Traversable t)+ :: (HasCallStack, Concurrent :> es, Traversable t) => (a -> Eff es b) -> t a -> Eff es (t b) pooledMapConcurrently f t = unsafeEff $ \es -> do U.pooledMapConcurrently (\a -> unEff (f a) =<< cloneEnv es) t --- | Lifted 'U.pooledMapConcurrentlyN'.+-- | Lifted 'U.pooledMapConcurrentlyN_'. pooledMapConcurrentlyN_- :: (Concurrent :> es, Foldable f)+ :: (HasCallStack, Concurrent :> es, Foldable f) => Int -> (a -> Eff es b) -> f a@@ -371,7 +385,7 @@ -- | Lifted 'U.pooledMapConcurrently_'. pooledMapConcurrently_- :: (Concurrent :> es, Foldable f)+ :: (HasCallStack, Concurrent :> es, Foldable f) => (a -> Eff es b) -> f a -> Eff es ()@@ -380,7 +394,7 @@ -- | Lifted 'U.pooledForConcurrentlyN'. pooledForConcurrentlyN- :: (Concurrent :> es, Traversable t)+ :: (HasCallStack, Concurrent :> es, Traversable t) => Int -> t a -> (a -> Eff es b)@@ -390,16 +404,16 @@ -- | Lifted 'U.pooledForConcurrently'. pooledForConcurrently- :: (Concurrent :> es, Traversable t)+ :: (HasCallStack, Concurrent :> es, Traversable t) => t a -> (a -> Eff es b) -> Eff es (t b) pooledForConcurrently t f = unsafeEff $ \es -> do U.pooledForConcurrently t (\a -> unEff (f a) =<< cloneEnv es) --- | Lifted 'U.pooledForConcurrentlyN'.+-- | Lifted 'U.pooledForConcurrentlyN_'. pooledForConcurrentlyN_- :: (Concurrent :> es, Foldable f)+ :: (HasCallStack, Concurrent :> es, Foldable f) => Int -> f a -> (a -> Eff es b)@@ -409,7 +423,7 @@ -- | Lifted 'U.pooledForConcurrently_'. pooledForConcurrently_- :: (Concurrent :> es, Foldable f)+ :: (HasCallStack, Concurrent :> es, Foldable f) => f a -> (a -> Eff es b) -> Eff es ()@@ -417,22 +431,40 @@ U.pooledForConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es) -- | Lifted 'U.pooledReplicateConcurrentlyN'.-pooledReplicateConcurrentlyN :: Concurrent :> es => Int -> Int -> Eff es a -> Eff es [a]+pooledReplicateConcurrentlyN+ :: (HasCallStack, Concurrent :> es)+ => Int+ -> Int+ -> Eff es a+ -> Eff es [a] pooledReplicateConcurrentlyN threads n f = unsafeEff $ \es -> do U.pooledReplicateConcurrentlyN threads n (unEff f =<< cloneEnv es) -- | Lifted 'U.pooledReplicateConcurrently'.-pooledReplicateConcurrently :: Concurrent :> es => Int -> Eff es a -> Eff es [a]+pooledReplicateConcurrently+ :: (HasCallStack, Concurrent :> es)+ => Int+ -> Eff es a+ -> Eff es [a] pooledReplicateConcurrently n f = unsafeEff $ \es -> do U.pooledReplicateConcurrently n (unEff f =<< cloneEnv es) -- | Lifted 'U.pooledReplicateConcurrentlyN_'.-pooledReplicateConcurrentlyN_ :: Concurrent :> es => Int -> Int -> Eff es a -> Eff es ()+pooledReplicateConcurrentlyN_+ :: (HasCallStack, Concurrent :> es)+ => Int+ -> Int+ -> Eff es a+ -> Eff es () pooledReplicateConcurrentlyN_ threads n f = unsafeEff $ \es -> do U.pooledReplicateConcurrentlyN_ threads n (unEff f =<< cloneEnv es) -- | Lifted 'U.pooledReplicateConcurrently_'.-pooledReplicateConcurrently_ :: Concurrent :> es => Int -> Eff es a -> Eff es ()+pooledReplicateConcurrently_+ :: (HasCallStack, Concurrent :> es)+ => Int+ -> Eff es a+ -> Eff es () pooledReplicateConcurrently_ n f = unsafeEff $ \es -> do U.pooledReplicateConcurrently_ n (unEff f =<< cloneEnv es) @@ -448,7 +480,7 @@ Alt :: Conc es a -> Conc es a -> Conc es a Empty :: Conc es a -deriving instance Functor (Conc es)+deriving stock instance Functor (Conc es) instance Applicative (Conc es) where pure = Pure@@ -472,7 +504,7 @@ conc = Action -- | Lifted 'U.runConc'.-runConc :: Concurrent :> es => Conc es a -> Eff es a+runConc :: (HasCallStack, Concurrent :> es) => Conc es a -> Eff es a runConc m = unsafeEff $ \es -> U.runConc (unliftConc es m) where unliftConc :: Env es -> Conc es a -> U.Conc IO a@@ -513,7 +545,8 @@ -- Helpers liftAsync- :: (IO a -> IO (Async a))+ :: HasCallStack+ => (IO a -> IO (Async a)) -> Eff es a -> Eff es (Async a) liftAsync fork action = unsafeEff $ \es -> do@@ -521,7 +554,8 @@ fork $ unEff action esA liftAsyncWithUnmask- :: (((forall b. IO b -> IO b) -> IO a) -> IO (Async a))+ :: HasCallStack+ => (((forall b. IO b -> IO b) -> IO a) -> IO (Async a)) -> ((forall b. Eff es b -> Eff es b) -> Eff es a) -> Eff es (Async a) liftAsyncWithUnmask fork action = unsafeEff $ \es -> do@@ -530,7 +564,8 @@ fork $ \unmask -> unEff (action $ reallyUnsafeLiftMapIO unmask) esA liftWithAsync- :: (IO a -> (Async a -> IO b) -> IO b)+ :: HasCallStack+ => (IO a -> (Async a -> IO b) -> IO b) -> Eff es a -> (Async a -> Eff es b) -> Eff es b@@ -540,7 +575,8 @@ (\a -> unEff (k a) es) liftWithAsyncWithUnmask- :: (((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b)+ :: HasCallStack+ => (((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b) -> ((forall c. Eff es c -> Eff es c) -> Eff es a) -> (Async a -> Eff es b) -> Eff es b
src/Effectful/Concurrent/Chan.hs view
@@ -17,7 +17,7 @@ ) where import Control.Concurrent.Chan (Chan)-import qualified Control.Concurrent.Chan as C+import Control.Concurrent.Chan qualified as C import Effectful import Effectful.Concurrent.Effect
+ src/Effectful/Concurrent/Chan/Strict.hs view
@@ -0,0 +1,50 @@+-- | Lifted "Control.Concurrent.Chan.Strict".+--+-- @since 2.4.0.0+module Effectful.Concurrent.Chan.Strict+ ( -- * Effect+ Concurrent++ -- ** Handlers+ , runConcurrent++ -- * Chan+ , Chan+ , newChan+ , writeChan+ , readChan+ , dupChan+ , getChanContents+ , writeList2Chan+ ) where++import Control.Concurrent.Chan.Strict (Chan)+import Control.Concurrent.Chan.Strict qualified as C++import Effectful+import Effectful.Concurrent.Effect+import Effectful.Dispatch.Static++-- | Lifted 'C.newChan'.+newChan :: Concurrent :> es => Eff es (Chan a)+newChan = unsafeEff_ C.newChan++-- | Lifted 'C.writeChan'.+writeChan :: Concurrent :> es => Chan a -> a -> Eff es ()+writeChan c = unsafeEff_ . C.writeChan c++-- | Lifted 'C.readChan'.+readChan :: Concurrent :> es => Chan a -> Eff es a+readChan = unsafeEff_ . C.readChan++-- | Lifted 'C.dupChan'.+dupChan :: Concurrent :> es => Chan a -> Eff es (Chan a)+dupChan = unsafeEff_ . C.dupChan++-- | Lifted 'C.getChanContents'.+getChanContents :: Concurrent :> es => Chan a -> Eff es [a]+getChanContents = unsafeEff_ . C.getChanContents++-- | Lifted 'C.writeList2Chan'.+writeList2Chan :: Concurrent :> es => Chan a -> [a] -> Eff es ()+writeList2Chan c = unsafeEff_ . C.writeList2Chan c
src/Effectful/Concurrent/Effect.hs view
@@ -17,7 +17,7 @@ -- it possible to escape the scope of any scoped effect operation. Consider the -- following: ----- >>> import qualified Effectful.Reader.Static as R+-- >>> import Effectful.Reader.Static qualified as R -- -- >>> printAsk msg = liftIO . putStrLn . (msg ++) . (": " ++) =<< R.ask --@@ -54,14 +54,14 @@ -- a mutable state. That's why statically dispatched @State@ and @Writer@ -- effects come in two flavors, local and shared: ----- >>> import qualified Effectful.State.Static.Local as SL+-- >>> import Effectful.State.Static.Local qualified as SL -- >>> :{ -- runEff . SL.execState "Hi" . runConcurrent $ do -- replicateConcurrently_ 3 $ SL.modify (++ "!") -- :} -- "Hi" ----- >>> import qualified Effectful.State.Static.Shared as SS+-- >>> import Effectful.State.Static.Shared qualified as SS -- >>> :{ -- runEff . SS.execState "Hi" . runConcurrent $ do -- replicateConcurrently_ 3 $ SS.modify (++ "!")@@ -78,7 +78,7 @@ data instance StaticRep Concurrent = Concurrent -- | Run the 'Concurrent' effect.-runConcurrent :: IOE :> es => Eff (Concurrent : es) a -> Eff es a+runConcurrent :: (HasCallStack, IOE :> es) => Eff (Concurrent : es) a -> Eff es a runConcurrent = evalStaticRep Concurrent -- $setup
src/Effectful/Concurrent/MVar.hs view
@@ -29,7 +29,7 @@ import System.Mem.Weak (Weak) import Control.Concurrent.MVar (MVar)-import qualified Control.Concurrent.MVar as M+import Control.Concurrent.MVar qualified as M import Effectful import Effectful.Concurrent.Effect@@ -81,34 +81,47 @@ withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b withMVar var f = reallyUnsafeUnliftIO $ \unlift -> do M.withMVar var $ unlift . f+{-# INLINE withMVar #-} -- | Lifted 'M.withMVarMasked'. withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b withMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do M.withMVarMasked var $ unlift . f+{-# INLINE withMVarMasked #-} -- | Lifted 'M.modifyMVar_'. modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () modifyMVar_ var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVar_ var $ unlift . f+{-# INLINE modifyMVar_ #-} -- | Lifted 'M.modifyMVar'. modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b modifyMVar var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVar var $ unlift . f+{-# INLINE modifyMVar #-} -- | Lifted 'M.modifyMVarMasked_'. modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () modifyMVarMasked_ var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVarMasked_ var $ unlift . f+{-# INLINE modifyMVarMasked_ #-} -- | Lifted 'M.modifyMVarMasked'. modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b modifyMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVarMasked var $ unlift . f+{-# INLINE modifyMVarMasked #-} -- | Lifted 'M.mkWeakMVar'.-mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a))+--+-- /Note:/ the finalizer will run a cloned environment, so any changes it makes+-- to thread local data will not be visible outside of it.+mkWeakMVar+ :: (HasCallStack, Concurrent :> es)+ => MVar a+ -> Eff es ()+ -> Eff es (Weak (MVar a)) mkWeakMVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. M.mkWeakMVar var . unEff f =<< cloneEnv es
src/Effectful/Concurrent/MVar/Strict.hs view
@@ -1,5 +1,6 @@--- | Lifted "Control.Concurrent.MVar" with operations that force values put--- inside an 'MVar' to WHNF.+-- | Lifted "Control.Concurrent.MVar.Strict".+--+-- @since 2.4.0.0 module Effectful.Concurrent.MVar.Strict ( -- * Effect Concurrent@@ -17,6 +18,7 @@ , swapMVar , tryTakeMVar , tryPutMVar+ , tryReadMVar , isEmptyMVar , withMVar , withMVarMasked@@ -24,13 +26,12 @@ , modifyMVar_ , modifyMVarMasked , modifyMVarMasked_- , tryReadMVar , mkWeakMVar ) where import System.Mem.Weak (Weak)-import Control.Concurrent.MVar (MVar)-import qualified Control.Concurrent.MVar as M+import Control.Concurrent.MVar.Strict (MVar)+import Control.Concurrent.MVar.Strict qualified as M import Effectful import Effectful.Concurrent.Effect@@ -42,9 +43,9 @@ newEmptyMVar :: Concurrent :> es => Eff es (MVar a) newEmptyMVar = unsafeEff_ M.newEmptyMVar --- | Lifted 'M.newMVar' that evaluates the value to WHNF.+-- | Lifted 'M.newMVar'. newMVar :: Concurrent :> es => a -> Eff es (MVar a)-newMVar a = unsafeEff_ $ a `seq` M.newMVar a+newMVar = unsafeEff_ . M.newMVar -- | Lifted 'M.takeMVar'. takeMVar :: Concurrent :> es => MVar a -> Eff es a@@ -52,72 +53,76 @@ -- | Lifted 'M.putMVar'. putMVar :: Concurrent :> es => MVar a -> a -> Eff es ()-putMVar var a = unsafeEff_ $ a `seq` M.putMVar var a+putMVar var = unsafeEff_ . M.putMVar var -- | Lifted 'M.readMVar'. readMVar :: Concurrent :> es => MVar a -> Eff es a readMVar = unsafeEff_ . M.readMVar --- | Lifted 'M.swapMVar' that evaluates the new value to WHNF.+-- | Lifted 'M.swapMVar'. swapMVar :: Concurrent :> es => MVar a -> a -> Eff es a-swapMVar var a = unsafeEff_ $ a `seq` M.swapMVar var a+swapMVar var = unsafeEff_ . M.swapMVar var -- | Lifted 'M.tryTakeMVar'. tryTakeMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a) tryTakeMVar = unsafeEff_ . M.tryTakeMVar --- | Lifted 'M.tryPutMVar' that evaluates the new value to WHNF.+-- | Lifted 'M.tryPutMVar'. tryPutMVar :: Concurrent :> es => MVar a -> a -> Eff es Bool-tryPutMVar var a = unsafeEff_ $ a `seq` M.tryPutMVar var a---- | Lifted 'M.isEmptyMVar'.-isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool-isEmptyMVar = unsafeEff_ . M.isEmptyMVar+tryPutMVar var = unsafeEff_ . M.tryPutMVar var -- | Lifted 'M.tryReadMVar'. tryReadMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a) tryReadMVar = unsafeEff_ . M.tryReadMVar +-- | Lifted 'M.isEmptyMVar'.+isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool+isEmptyMVar = unsafeEff_ . M.isEmptyMVar+ -- | Lifted 'M.withMVar'. withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b withMVar var f = reallyUnsafeUnliftIO $ \unlift -> do M.withMVar var $ unlift . f+{-# INLINE withMVar #-} -- | Lifted 'M.withMVarMasked'. withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b withMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do M.withMVarMasked var $ unlift . f+{-# INLINE withMVarMasked #-} --- | Lifted 'M.modifyMVar_' that evaluates the new value to WHNF.+-- | Lifted 'M.modifyMVar_'. modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () modifyMVar_ var f = reallyUnsafeUnliftIO $ \unlift -> do- M.modifyMVar_ var $ \a0 -> do- a <- unlift $ f a0- a `seq` pure a+ M.modifyMVar_ var $ unlift . f+{-# INLINE modifyMVar_ #-} --- | Lifted 'M.modifyMVar' that evaluates the new value to WHNF.+-- | Lifted 'M.modifyMVar'. modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b modifyMVar var f = reallyUnsafeUnliftIO $ \unlift -> do- M.modifyMVar var $ \a0 -> do- (a, b) <- unlift $ f a0- a `seq` pure (a, b)+ M.modifyMVar var $ unlift . f+{-# INLINE modifyMVar #-} --- | Lifted 'M.modifyMVarMasked_' that evaluates the new value to WHNF.+-- | Lifted 'M.modifyMVarMasked_'. modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () modifyMVarMasked_ var f = reallyUnsafeUnliftIO $ \unlift -> do- M.modifyMVarMasked_ var $ \a0 -> do- a <- unlift $ f a0- a `seq` pure a+ M.modifyMVarMasked_ var $ unlift . f+{-# INLINE modifyMVarMasked_ #-} --- | Lifted 'M.modifyMVarMasked' that evaluates the new value to WHNF.+-- | Lifted 'M.modifyMVarMasked'. modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b modifyMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do- M.modifyMVarMasked var $ \a0 -> do- a <- unlift $ f a0- a `seq` pure a+ M.modifyMVarMasked var $ unlift . f+{-# INLINE modifyMVarMasked #-} -- | Lifted 'M.mkWeakMVar'.-mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a))+--+-- /Note:/ the finalizer will run a cloned environment, so any changes it makes+-- to thread local data will not be visible outside of it.+mkWeakMVar+ :: (HasCallStack, Concurrent :> es)+ => MVar a -> Eff es ()+ -> Eff es (Weak (MVar a)) mkWeakMVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. M.mkWeakMVar var . unEff f =<< cloneEnv es
+ src/Effectful/Concurrent/MVar/Strict/Compat.hs view
@@ -0,0 +1,138 @@+-- | Lifted "Control.Concurrent.MVar" with operations that force values put+-- inside an 'MVar' to WHNF.+module Effectful.Concurrent.MVar.Strict.Compat+ {-# DEPRECATED "Use Effectful.Concurrent.MVar.Strict" #-}+ ( -- * Effect+ Concurrent++ -- ** Handlers+ , runConcurrent++ -- * MVar+ , MVar+ , newEmptyMVar+ , newMVar+ , takeMVar+ , putMVar+ , readMVar+ , swapMVar+ , tryTakeMVar+ , tryPutMVar+ , isEmptyMVar+ , withMVar+ , withMVarMasked+ , modifyMVar+ , modifyMVar_+ , modifyMVarMasked+ , modifyMVarMasked_+ , tryReadMVar+ , mkWeakMVar+ ) where++import System.Mem.Weak (Weak)+import Control.Exception (evaluate)+import Control.Concurrent.MVar (MVar)+import Control.Concurrent.MVar qualified as M++import Effectful+import Effectful.Concurrent.Effect+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Dispatch.Static.Unsafe++-- | Lifted 'M.newEmptyMVar'.+newEmptyMVar :: Concurrent :> es => Eff es (MVar a)+newEmptyMVar = unsafeEff_ M.newEmptyMVar++-- | Lifted 'M.newMVar' that evaluates the value to WHNF.+newMVar :: Concurrent :> es => a -> Eff es (MVar a)+newMVar a = unsafeEff_ $ M.newMVar =<< evaluate a++-- | Lifted 'M.takeMVar'.+takeMVar :: Concurrent :> es => MVar a -> Eff es a+takeMVar = unsafeEff_ . M.takeMVar++-- | Lifted 'M.putMVar'.+putMVar :: Concurrent :> es => MVar a -> a -> Eff es ()+putMVar var a = unsafeEff_ $ M.putMVar var =<< evaluate a++-- | Lifted 'M.readMVar'.+readMVar :: Concurrent :> es => MVar a -> Eff es a+readMVar = unsafeEff_ . M.readMVar++-- | Lifted 'M.swapMVar' that evaluates the new value to WHNF.+swapMVar :: Concurrent :> es => MVar a -> a -> Eff es a+swapMVar var a = unsafeEff_ $ M.swapMVar var =<< evaluate a++-- | Lifted 'M.tryTakeMVar'.+tryTakeMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a)+tryTakeMVar = unsafeEff_ . M.tryTakeMVar++-- | Lifted 'M.tryPutMVar' that evaluates the new value to WHNF.+tryPutMVar :: Concurrent :> es => MVar a -> a -> Eff es Bool+tryPutMVar var a = unsafeEff_ $ M.tryPutMVar var =<< evaluate a++-- | Lifted 'M.isEmptyMVar'.+isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool+isEmptyMVar = unsafeEff_ . M.isEmptyMVar++-- | Lifted 'M.tryReadMVar'.+tryReadMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a)+tryReadMVar = unsafeEff_ . M.tryReadMVar++-- | Lifted 'M.withMVar'.+withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b+withMVar var f = reallyUnsafeUnliftIO $ \unlift -> do+ M.withMVar var $ unlift . f+{-# INLINE withMVar #-}++-- | Lifted 'M.withMVarMasked'.+withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b+withMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do+ M.withMVarMasked var $ unlift . f+{-# INLINE withMVarMasked #-}++-- | Lifted 'M.modifyMVar_' that evaluates the new value to WHNF.+modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es ()+modifyMVar_ var f = reallyUnsafeUnliftIO $ \unlift -> do+ M.modifyMVar_ var $ \a0 -> do+ a <- unlift $ f a0+ evaluate a+{-# INLINE modifyMVar_ #-}++-- | Lifted 'M.modifyMVar' that evaluates the new value to WHNF.+modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b+modifyMVar var f = reallyUnsafeUnliftIO $ \unlift -> do+ M.modifyMVar var $ \a0 -> do+ (a, b) <- unlift $ f a0+ (, b) <$> evaluate a+{-# INLINE modifyMVar #-}++-- | Lifted 'M.modifyMVarMasked_' that evaluates the new value to WHNF.+modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es ()+modifyMVarMasked_ var f = reallyUnsafeUnliftIO $ \unlift -> do+ M.modifyMVarMasked_ var $ \a0 -> do+ a <- unlift $ f a0+ evaluate a+{-# INLINE modifyMVarMasked_ #-}++-- | Lifted 'M.modifyMVarMasked' that evaluates the new value to WHNF.+modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b+modifyMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do+ M.modifyMVarMasked var $ \a0 -> do+ (a, b) <- unlift $ f a0+ (, b) <$> evaluate a+{-# INLINE modifyMVarMasked #-}++-- | Lifted 'M.mkWeakMVar'.+--+-- /Note:/ the finalizer will run a cloned environment, so any changes it makes+-- to thread local data will not be visible outside of it.+mkWeakMVar+ :: (HasCallStack, Concurrent :> es)+ => MVar a+ -> Eff es ()+ -> Eff es (Weak (MVar a))+mkWeakMVar var f = unsafeEff $ \es -> do+ -- The finalizer can run at any point and in any thread.+ M.mkWeakMVar var . unEff f =<< cloneEnv es
src/Effectful/Concurrent/QSem.hs view
@@ -14,7 +14,7 @@ ) where import Control.Concurrent.QSem (QSem)-import qualified Control.Concurrent.QSem as Q+import Control.Concurrent.QSem qualified as Q import Effectful import Effectful.Concurrent.Effect
src/Effectful/Concurrent/QSemN.hs view
@@ -14,7 +14,7 @@ ) where import Control.Concurrent.QSemN (QSemN)-import qualified Control.Concurrent.QSemN as Q+import Control.Concurrent.QSemN qualified as Q import Effectful import Effectful.Concurrent.Effect
src/Effectful/Concurrent/STM.hs view
@@ -37,6 +37,7 @@ , STM.takeTMVar , STM.putTMVar , STM.readTMVar+ , STM.writeTMVar , STM.tryReadTMVar , STM.swapTMVar , STM.tryTakeTMVar@@ -90,7 +91,7 @@ ) where import Control.Concurrent.STM (STM, TVar, TMVar, TChan, TQueue, TBQueue)-import qualified Control.Concurrent.STM as STM+import Control.Concurrent.STM qualified as STM import System.Mem.Weak (Weak) import GHC.Natural (Natural) @@ -116,7 +117,14 @@ registerDelay = unsafeEff_ . STM.registerDelay -- | Lifted 'STM.mkWeakTVar'.-mkWeakTVar :: Concurrent :> es => TVar a -> Eff es () -> Eff es (Weak (TVar a))+--+-- /Note:/ the finalizer will run a cloned environment, so any changes it makes+-- to thread local data will not be visible outside of it.+mkWeakTVar+ :: (HasCallStack, Concurrent :> es)+ => TVar a+ -> Eff es ()+ -> Eff es (Weak (TVar a)) mkWeakTVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. STM.mkWeakTVar var . unEff f =<< cloneEnv es@@ -130,7 +138,14 @@ newEmptyTMVarIO = unsafeEff_ STM.newEmptyTMVarIO -- | Lifted 'STM.mkWeakTMVar'.-mkWeakTMVar :: Concurrent :> es => TMVar a -> Eff es () -> Eff es (Weak (TMVar a))+--+-- /Note:/ the finalizer will run a cloned environment, so any changes it makes+-- to thread local data will not be visible outside of it.+mkWeakTMVar+ :: (HasCallStack, Concurrent :> es)+ => TMVar a+ -> Eff es ()+ -> Eff es (Weak (TMVar a)) mkWeakTMVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. STM.mkWeakTMVar var . unEff f =<< cloneEnv es
src/Effectful/Console/ByteString.hs view
@@ -4,9 +4,9 @@ -- to avoid name clashes with the functions provided by "Prelude", e.g.: -- -- > import Data.ByteString (ByteString)--- > import qualified Data.ByteString.Char8 as BS8+-- > import Data.ByteString.Char8 qualified as BS8 -- > import Effectful.Console.ByteString (Console)--- > import qualified Effectful.Console.ByteString as Console+-- > import Effectful.Console.ByteString qualified as Console -- module Effectful.Console.ByteString ( -- * Effect@@ -32,7 +32,7 @@ ) import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as BS8+import Data.ByteString.Char8 qualified as BS8 import Effectful import Effectful.Console.Effect
src/Effectful/Console/ByteString/Lazy.hs view
@@ -4,9 +4,9 @@ -- to avoid name clashes with the functions provided by "Prelude", e.g.: -- -- > import Data.ByteString.Lazy.Char8 (ByteString)--- > import qualified Data.ByteString.Lazy.Char8 as LBS8+-- > import Data.ByteString.Lazy.Char8 qualified as LBS8 -- > import Effectful.Console.ByteString.Lazy (Console)--- > import qualified Effectful.Console.ByteString.Lazy as Console+-- > import Effectful.Console.ByteString.Lazy qualified as Console -- module Effectful.Console.ByteString.Lazy ( -- * Effect@@ -30,7 +30,7 @@ ) import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy.Char8 as LBS8+import Data.ByteString.Lazy.Char8 qualified as LBS8 import Effectful import Effectful.Console.Effect
src/Effectful/Console/Effect.hs view
@@ -17,5 +17,5 @@ data instance StaticRep Console = Console -- | Run the 'Console' effect.-runConsole :: IOE :> es => Eff (Console : es) a -> Eff es a+runConsole :: (HasCallStack, IOE :> es) => Eff (Console : es) a -> Eff es a runConsole = evalStaticRep Console
src/Effectful/Environment.hs view
@@ -20,7 +20,7 @@ , withProgName ) where -import qualified System.Environment as E+import System.Environment qualified as E import Effectful import Effectful.Dispatch.Static@@ -32,7 +32,7 @@ data instance StaticRep Environment = Environment -- | Run the 'Environment' effect.-runEnvironment :: IOE :> es => Eff (Environment : es) a -> Eff es a+runEnvironment :: (HasCallStack, IOE :> es) => Eff (Environment : es) a -> Eff es a runEnvironment = evalStaticRep Environment -- | Lifted 'E.getArgs'.
src/Effectful/FileSystem.hs view
@@ -92,7 +92,7 @@ ) where import Data.Time (UTCTime)-import qualified System.Directory as D+import System.Directory qualified as D import Effectful import Effectful.Dispatch.Static
src/Effectful/FileSystem/Effect.hs view
@@ -16,5 +16,5 @@ data instance StaticRep FileSystem = FileSystem -- | Run the 'FileSystem' effect.-runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a+runFileSystem :: (HasCallStack, IOE :> es) => Eff (FileSystem : es) a -> Eff es a runFileSystem = evalStaticRep FileSystem
+ src/Effectful/FileSystem/File/OsPath.hs view
@@ -0,0 +1,150 @@+-- | Lifted "System.File.OsPath".+module Effectful.FileSystem.File.OsPath+ ( -- * Effect+ FileSystem++ -- ** Handlers+ , runFileSystem++ -- * Files+ , IOMode (..)+ , Handle+ , openBinaryFile+ , withFile+ , withBinaryFile+ , withFile'+ , withBinaryFile'+ , readFile+ , readFile'+ , writeFile+ , writeFile'+ , appendFile+ , appendFile'+ , openFile+ , openExistingFile+ , openTempFile+ , openBinaryTempFile+ , openTempFileWithDefaultPermissions+ , openBinaryTempFileWithDefaultPermissions+ ) where++import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as BSL+import Prelude hiding (appendFile, readFile, writeFile)+import System.File.OsPath qualified as F+import System.IO (Handle, IOMode (..))+import System.OsPath (OsPath, OsString)++import Effectful+import Effectful.Dispatch.Static+import Effectful.FileSystem.Effect++-- | Lifted 'F.openBinaryFile'.+openBinaryFile :: FileSystem :> es => OsPath -> IOMode -> Eff es Handle+openBinaryFile path = unsafeEff_ . F.openBinaryFile path++-- | Lifted 'F.withFile'.+withFile+ :: FileSystem :> es+ => OsPath+ -> IOMode+ -> (Handle -> Eff es a)+ -> Eff es a+withFile path mode inner = unsafeSeqUnliftIO $ \unlift -> do+ F.withFile path mode $ unlift . inner++-- | Lifted 'F.withBinaryFile'.+withBinaryFile+ :: FileSystem :> es+ => OsPath+ -> IOMode+ -> (Handle -> Eff es a)+ -> Eff es a+withBinaryFile path mode inner = unsafeSeqUnliftIO $ \unlift -> do+ F.withBinaryFile path mode $ unlift . inner++-- | Lifted 'F.withFile''.+withFile'+ :: FileSystem :> es+ => OsPath+ -> IOMode+ -> (Handle -> Eff es a)+ -> Eff es a+withFile' path mode inner = unsafeSeqUnliftIO $ \unlift -> do+ F.withFile' path mode $ unlift . inner++-- | Lifted 'F.withBinaryFile''.+withBinaryFile'+ :: FileSystem :> es+ => OsPath+ -> IOMode+ -> (Handle -> Eff es a)+ -> Eff es a+withBinaryFile' path mode inner = unsafeSeqUnliftIO $ \unlift -> do+ F.withBinaryFile' path mode $ unlift . inner++-- | Lifted 'F.readFile'.+readFile :: FileSystem :> es => OsPath -> Eff es BSL.ByteString+readFile = unsafeEff_ . F.readFile++-- | Lifted 'F.readFile''.+readFile' :: FileSystem :> es => OsPath -> Eff es ByteString+readFile' = unsafeEff_ . F.readFile'++-- | Lifted 'F.writeFile'.+writeFile :: FileSystem :> es => OsPath -> BSL.ByteString -> Eff es ()+writeFile path = unsafeEff_ . F.writeFile path++-- | Lifted 'F.writeFile''.+writeFile' :: FileSystem :> es => OsPath -> ByteString -> Eff es ()+writeFile' path = unsafeEff_ . F.writeFile' path++-- | Lifted 'F.appendFile'.+appendFile :: FileSystem :> es => OsPath -> BSL.ByteString -> Eff es ()+appendFile path = unsafeEff_ . F.appendFile path++-- | Lifted 'F.appendFile''.+appendFile' :: FileSystem :> es => OsPath -> ByteString -> Eff es ()+appendFile' path = unsafeEff_ . F.appendFile' path++-- | Lifted 'F.openFile'.+openFile :: FileSystem :> es => OsPath -> IOMode -> Eff es Handle+openFile path = unsafeEff_ . F.openFile path++-- | Lifted 'F.openExistingFile'.+openExistingFile :: FileSystem :> es => OsPath -> IOMode -> Eff es Handle+openExistingFile path = unsafeEff_ . F.openExistingFile path++-- | Lifted 'F.openTempFile'.+openTempFile+ :: FileSystem :> es+ => OsPath+ -> OsString+ -> Eff es (OsPath, Handle)+openTempFile dir = unsafeEff_ . F.openTempFile dir++-- | Lifted 'F.openBinaryTempFile'.+openBinaryTempFile+ :: FileSystem :> es+ => OsPath+ -> OsString+ -> Eff es (OsPath, Handle)+openBinaryTempFile dir = unsafeEff_ . F.openBinaryTempFile dir++-- | Lifted 'F.openTempFileWithDefaultPermissions'.+openTempFileWithDefaultPermissions+ :: FileSystem :> es+ => OsPath+ -> OsString+ -> Eff es (OsPath, Handle)+openTempFileWithDefaultPermissions dir =+ unsafeEff_ . F.openTempFileWithDefaultPermissions dir++-- | Lifted 'F.openBinaryTempFileWithDefaultPermissions'.+openBinaryTempFileWithDefaultPermissions+ :: FileSystem :> es+ => OsPath+ -> OsString+ -> Eff es (OsPath, Handle)+openBinaryTempFileWithDefaultPermissions dir =+ unsafeEff_ . F.openBinaryTempFileWithDefaultPermissions dir
src/Effectful/FileSystem/IO.hs view
@@ -39,7 +39,7 @@ ) where import System.IO (Handle, IOMode (..))-import qualified System.IO as IO+import System.IO qualified as IO import Effectful import Effectful.Dispatch.Static
src/Effectful/FileSystem/IO/ByteString.hs view
@@ -5,8 +5,8 @@ -- to avoid name clashes with the functions provided by "Prelude", e.g.: -- -- > import Data.ByteString (ByteString)--- > import qualified Data.ByteString as BS--- > import qualified Effectful.FileSystem.IO.ByteString as EBS+-- > import Data.ByteString qualified as BS+-- > import Effectful.FileSystem.IO.ByteString qualified as EBS -- module Effectful.FileSystem.IO.ByteString #if MIN_VERSION_bytestring(0,11,2)@@ -35,20 +35,18 @@ , hPutStrLn ) where -import Prelude hiding- ( appendFile- , readFile- , writeFile- )- import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8+import Data.ByteString.Char8 qualified as BS8+import Prelude hiding (appendFile, readFile, writeFile) import System.IO (Handle) import Effectful import Effectful.Dispatch.Static import Effectful.FileSystem++#if MIN_VERSION_bytestring(0,11,2)+import Data.ByteString qualified as BS+#endif ---------------------------------------- -- Introducing and eliminating ByteStrings
src/Effectful/FileSystem/IO/ByteString/Builder.hs view
@@ -5,8 +5,8 @@ -- to avoid name clashes with the functions provided by "Prelude", e.g.: -- -- > import Data.ByteString.Builder (Builder)--- > import qualified Data.ByteString.Builder as BSB--- > import qualified Effectful.FileSystem.IO.ByteString.Builder as EBSB+-- > import Data.ByteString.Builder qualified as BSB+-- > import Effectful.FileSystem.IO.ByteString.Builder qualified as EBSB -- module Effectful.FileSystem.IO.ByteString.Builder ( -- * Executing Builders@@ -16,10 +16,9 @@ #endif ) where -import Prelude hiding (writeFile)- import Data.ByteString.Builder (Builder)-import qualified Data.ByteString.Builder as BSB+import Data.ByteString.Builder qualified as BSB+import Prelude hiding (writeFile) import System.IO (Handle) import Effectful@@ -29,12 +28,12 @@ ---------------------------------------- -- Executing Builders --- | Lifted 'BS.Builder.hPutBuilder'.+-- | Lifted 'BSB.hPutBuilder'. hPutBuilder :: FileSystem :> es => Handle -> Builder -> Eff es () hPutBuilder h = unsafeEff_ . BSB.hPutBuilder h #if MIN_VERSION_bytestring(0,11,2)--- | Lifted 'BS.Builder.writeFile'.+-- | Lifted 'BSB.writeFile'. writeFile :: FileSystem :> es => FilePath -> Builder -> Eff es () writeFile fp = unsafeEff_ . BSB.writeFile fp #endif
src/Effectful/FileSystem/IO/ByteString/Lazy.hs view
@@ -3,8 +3,8 @@ -- to avoid name clashes with the functions provided by "Prelude", e.g.: -- -- > import Data.ByteString.Lazy (ByteString)--- > import qualified Data.ByteString.Lazy.Char8 as LBS8--- > import qualified Effectful.FileSystem.IO.ByteString.Lazy as ELBS+-- > import Data.ByteString.Lazy.Char8 qualified as LBS8+-- > import Effectful.FileSystem.IO.ByteString.Lazy qualified as ELBS -- module Effectful.FileSystem.IO.ByteString.Lazy ( -- * Files@@ -29,7 +29,7 @@ ) import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy.Char8 as LBS8+import Data.ByteString.Lazy.Char8 qualified as LBS8 import System.IO (Handle) import Effectful
src/Effectful/FileSystem/IO/File.hs view
@@ -15,7 +15,7 @@ import Data.ByteString (ByteString) import System.IO (Handle, IOMode (..))-import qualified UnliftIO.IO.File as U+import UnliftIO.IO.File qualified as U import Effectful import Effectful.Dispatch.Static
+ src/Effectful/FileSystem/OsPath.hs view
@@ -0,0 +1,345 @@+-- | Lifted "System.Directory.OsPath".+module Effectful.FileSystem.OsPath+ ( -- * Effect+ FileSystem++ -- ** Handlers+ , runFileSystem++ -- * Actions on directories+ , createDirectory+ , createDirectoryIfMissing+ , removeDirectory+ , removeDirectoryRecursive+ , removePathForcibly+ , renameDirectory+ , listDirectory+ , getDirectoryContents++ -- ** Current working directory+ , getCurrentDirectory+ , setCurrentDirectory+ , withCurrentDirectory++ -- * Pre-defined directories+ , getHomeDirectory+ , getXdgDirectory+ , getXdgDirectoryList+ , getAppUserDataDirectory+ , getUserDocumentsDirectory+ , getTemporaryDirectory++ -- * Actions on files+ , removeFile+ , renameFile+ , renamePath+ , copyFile+ , copyFileWithMetadata+ , getFileSize+ , canonicalizePath+ , makeAbsolute+ , makeRelativeToCurrentDirectory++ -- * Existence tests+ , doesPathExist+ , doesFileExist+ , doesDirectoryExist+ , findExecutable+ , findExecutables+ , findExecutablesInDirectories+ , findFile+ , findFiles+ , findFileWith+ , findFilesWith++ -- * Symbolic links+ , createFileLink+ , createDirectoryLink+ , removeDirectoryLink+ , pathIsSymbolicLink+ , getSymbolicLinkTarget++ -- * Permissions+ , getPermissions+ , setPermissions+ , copyPermissions++ -- * Timestamps+ , getAccessTime+ , getModificationTime+ , setAccessTime+ , setModificationTime++ -- * Re-exports++ -- ** Pre-defined directories+ , D.XdgDirectory(..)+ , D.XdgDirectoryList(..)++ -- ** Existence tests+ , D.exeExtension++ -- ** Permissions+ , D.Permissions+ , D.emptyPermissions+ , D.readable+ , D.writable+ , D.executable+ , D.searchable+ , D.setOwnerReadable+ , D.setOwnerWritable+ , D.setOwnerExecutable+ , D.setOwnerSearchable+ ) where++import Data.Time (UTCTime)+import System.Directory.OsPath qualified as D+import System.OsPath (OsPath, OsString)++import Effectful+import Effectful.Dispatch.Static+import Effectful.FileSystem.Effect++----------------------------------------+-- Actions on directories++-- | Lifted 'D.createDirectory'.+createDirectory :: FileSystem :> es => OsPath -> Eff es ()+createDirectory = unsafeEff_ . D.createDirectory++-- | Lifted 'D.createDirectoryIfMissing'.+createDirectoryIfMissing :: FileSystem :> es => Bool -> OsPath -> Eff es ()+createDirectoryIfMissing doCreateParents =+ unsafeEff_ . D.createDirectoryIfMissing doCreateParents++-- | Lifted 'D.removeDirectory'.+removeDirectory :: FileSystem :> es => OsPath -> Eff es ()+removeDirectory = unsafeEff_ . D.removeDirectory++-- | Lifted 'D.removeDirectoryRecursive'.+removeDirectoryRecursive :: FileSystem :> es => OsPath -> Eff es ()+removeDirectoryRecursive = unsafeEff_ . D.removeDirectoryRecursive++-- | Lifted 'D.removePathForcibly'.+removePathForcibly :: FileSystem :> es => OsPath -> Eff es ()+removePathForcibly = unsafeEff_ . D.removePathForcibly++-- | Lifted 'D.renameDirectory'.+renameDirectory :: FileSystem :> es => OsPath -> OsPath -> Eff es ()+renameDirectory old = unsafeEff_ . D.renameDirectory old++-- | Lifted 'D.listDirectory'.+listDirectory :: FileSystem :> es => OsPath -> Eff es [OsPath]+listDirectory = unsafeEff_ . D.listDirectory++-- | Lifted 'D.getDirectoryContents'.+getDirectoryContents :: FileSystem :> es => OsPath -> Eff es [OsPath]+getDirectoryContents = unsafeEff_ . D.getDirectoryContents++----------------------------------------+-- Current working directory++-- | Lifted 'D.getCurrentDirectory'.+getCurrentDirectory :: FileSystem :> es => Eff es OsPath+getCurrentDirectory = unsafeEff_ D.getCurrentDirectory++-- | Lifted 'D.setCurrentDirectory'.+setCurrentDirectory :: FileSystem :> es => OsPath -> Eff es ()+setCurrentDirectory = unsafeEff_ . D.setCurrentDirectory++-- | Lifted 'D.withCurrentDirectory'.+withCurrentDirectory :: FileSystem :> es => OsPath -> Eff es a -> Eff es a+withCurrentDirectory path = unsafeLiftMapIO (D.withCurrentDirectory path)++----------------------------------------+-- Pre-defined directories++-- | Lifted 'D.getHomeDirectory'.+getHomeDirectory :: FileSystem :> es => Eff es OsPath+getHomeDirectory = unsafeEff_ D.getHomeDirectory++-- | Lifted 'D.getXdgDirectory'.+getXdgDirectory+ :: FileSystem :> es+ => D.XdgDirectory+ -> OsPath+ -> Eff es OsPath+getXdgDirectory xdgDir = unsafeEff_ . D.getXdgDirectory xdgDir++-- | Lifted 'D.getXdgDirectoryList'.+getXdgDirectoryList+ :: FileSystem :> es+ => D.XdgDirectoryList+ -> Eff es [OsPath]+getXdgDirectoryList = unsafeEff_ . D.getXdgDirectoryList++-- | Lifted 'D.getAppUserDataDirectory'.+getAppUserDataDirectory :: FileSystem :> es => OsPath -> Eff es OsPath+getAppUserDataDirectory = unsafeEff_ . D.getAppUserDataDirectory++-- | Lifted 'D.getUserDocumentsDirectory'.+getUserDocumentsDirectory :: FileSystem :> es => Eff es OsPath+getUserDocumentsDirectory = unsafeEff_ D.getUserDocumentsDirectory++-- | Lifted 'D.getTemporaryDirectory'.+getTemporaryDirectory :: FileSystem :> es => Eff es OsPath+getTemporaryDirectory = unsafeEff_ D.getTemporaryDirectory++----------------------------------------+-- Actions on files++-- | Lifted 'D.removeFile'.+removeFile :: FileSystem :> es => OsPath -> Eff es ()+removeFile = unsafeEff_ . D.removeFile++-- | Lifted 'D.renameFile'.+renameFile :: FileSystem :> es => OsPath -> OsPath -> Eff es ()+renameFile old = unsafeEff_ . D.renameFile old++-- | Lifted 'D.renamePath'.+renamePath :: FileSystem :> es => OsPath -> OsPath -> Eff es ()+renamePath old = unsafeEff_ . D.renamePath old++-- | Lifted 'D.copyFile'.+copyFile :: FileSystem :> es => OsPath -> OsPath -> Eff es ()+copyFile src = unsafeEff_ . D.copyFile src++-- | Lifted 'D.copyFileWithMetadata'.+copyFileWithMetadata :: FileSystem :> es => OsPath -> OsPath -> Eff es ()+copyFileWithMetadata src = unsafeEff_ . D.copyFileWithMetadata src++-- | Lifted 'D.getFileSize'.+getFileSize :: FileSystem :> es => OsPath -> Eff es Integer+getFileSize = unsafeEff_ . D.getFileSize++-- | Lifted 'D.canonicalizePath'.+canonicalizePath :: FileSystem :> es => OsPath -> Eff es OsPath+canonicalizePath = unsafeEff_ . D.canonicalizePath++-- | Lifted 'D.makeAbsolute'.+makeAbsolute :: FileSystem :> es => OsPath -> Eff es OsPath+makeAbsolute = unsafeEff_ . D.makeAbsolute++-- | Lifted 'D.makeRelativeToCurrentDirectory'.+makeRelativeToCurrentDirectory+ :: FileSystem :> es+ => OsPath+ -> Eff es OsPath+makeRelativeToCurrentDirectory = unsafeEff_ . D.makeRelativeToCurrentDirectory++----------------------------------------+-- Existence tests++-- | Lifted 'D.doesPathExist'.+doesPathExist :: FileSystem :> es => OsPath -> Eff es Bool+doesPathExist = unsafeEff_ . D.doesPathExist++-- | Lifted 'D.doesFileExist'.+doesFileExist :: FileSystem :> es => OsPath -> Eff es Bool+doesFileExist = unsafeEff_ . D.doesFileExist++-- | Lifted 'D.doesDirectoryExist'.+doesDirectoryExist :: FileSystem :> es => OsPath -> Eff es Bool+doesDirectoryExist = unsafeEff_ . D.doesDirectoryExist++-- | Lifted 'D.findExecutable'.+findExecutable :: FileSystem :> es => OsString -> Eff es (Maybe OsPath)+findExecutable = unsafeEff_ . D.findExecutable++-- | Lifted 'D.findExecutables'.+findExecutables :: FileSystem :> es => OsString -> Eff es [OsPath]+findExecutables = unsafeEff_ . D.findExecutables++-- | Lifted 'D.findExecutablesInDirectories'.+findExecutablesInDirectories+ :: FileSystem :> es+ => [OsPath]+ -> OsString+ -> Eff es [OsPath]+findExecutablesInDirectories dirs =+ unsafeEff_ . D.findExecutablesInDirectories dirs++-- | Lifted 'D.findFile'.+findFile :: FileSystem :> es => [OsPath] -> OsString -> Eff es (Maybe OsPath)+findFile dirs = unsafeEff_ . D.findFile dirs++-- | Lifted 'D.findFiles'.+findFiles :: FileSystem :> es => [OsPath] -> OsString -> Eff es [OsPath]+findFiles dirs = unsafeEff_ . D.findFiles dirs++-- | Lifted 'D.findFileWith'.+findFileWith+ :: FileSystem :> es+ => (OsPath -> Eff es Bool)+ -> [OsPath]+ -> OsString+ -> Eff es (Maybe OsPath)+findFileWith p dirs n = unsafeSeqUnliftIO $ \unlift -> do+ D.findFileWith (unlift . p) dirs n++-- | Lifted 'D.findFilesWith'.+findFilesWith+ :: FileSystem :> es+ => (OsPath -> Eff es Bool)+ -> [OsPath]+ -> OsString+ -> Eff es [OsPath]+findFilesWith p dirs ns = unsafeSeqUnliftIO $ \unlift -> do+ D.findFilesWith (unlift . p) dirs ns++----------------------------------------+-- Symbolic links++-- | Lifted 'D.createFileLink'.+createFileLink :: FileSystem :> es => OsPath -> OsPath -> Eff es ()+createFileLink target = unsafeEff_ . D.createFileLink target++-- | Lifted 'D.createDirectoryLink'.+createDirectoryLink :: FileSystem :> es => OsPath -> OsPath -> Eff es ()+createDirectoryLink target = unsafeEff_ . D.createDirectoryLink target++-- | Lifted 'D.removeDirectoryLink'.+removeDirectoryLink :: FileSystem :> es => OsPath -> Eff es ()+removeDirectoryLink = unsafeEff_ . D.removeDirectoryLink++-- | Lifted 'D.pathIsSymbolicLink'.+pathIsSymbolicLink :: FileSystem :> es => OsPath -> Eff es Bool+pathIsSymbolicLink = unsafeEff_ . D.pathIsSymbolicLink++-- | Lifted 'D.getSymbolicLinkTarget'.+getSymbolicLinkTarget :: FileSystem :> es => OsPath -> Eff es OsPath+getSymbolicLinkTarget = unsafeEff_ . D.getSymbolicLinkTarget++----------------------------------------+-- Permissions++-- | Lifted 'D.getPermissions'.+getPermissions :: FileSystem :> es => OsPath -> Eff es D.Permissions+getPermissions = unsafeEff_ . D.getPermissions++-- | Lifted 'D.setPermissions'.+setPermissions :: FileSystem :> es => OsPath -> D.Permissions -> Eff es ()+setPermissions path = unsafeEff_ . D.setPermissions path++-- | Lifted 'D.copyPermissions'.+copyPermissions :: FileSystem :> es => OsPath -> OsPath -> Eff es ()+copyPermissions src = unsafeEff_ . D.copyPermissions src++----------------------------------------+-- Timestamps++-- | Lifted 'D.getAccessTime'.+getAccessTime :: FileSystem :> es => OsPath -> Eff es UTCTime+getAccessTime = unsafeEff_ . D.getAccessTime++-- | Lifted 'D.getModificationTime'.+getModificationTime :: FileSystem :> es => OsPath -> Eff es UTCTime+getModificationTime = unsafeEff_ . D.getModificationTime++-- | Lifted 'D.setAccessTime'.+setAccessTime :: FileSystem :> es => OsPath -> UTCTime -> Eff es ()+setAccessTime path = unsafeEff_ . D.setAccessTime path++-- | Lifted 'D.setModificationTime'.+setModificationTime :: FileSystem :> es => OsPath -> UTCTime -> Eff es ()+setModificationTime path = unsafeEff_ . D.setModificationTime path
+ src/Effectful/Prim/IORef.hs view
@@ -0,0 +1,79 @@+-- | Lifted "Data.IORef".+--+-- /Note:/ it requires 'Prim' because @MutVar@ from the @primitive@ library is a+-- generalization of 'IORef'.+--+-- @since 2.4.0.0+module Effectful.Prim.IORef+ ( -- * Effect+ Prim++ -- ** Handlers+ , runPrim++ -- * IORef+ , IORef+ , newIORef+ , readIORef+ , writeIORef+ , modifyIORef+ , modifyIORef'+ , atomicModifyIORef+ , atomicModifyIORef'+ , atomicWriteIORef+ , mkWeakIORef+ ) where++import Data.IORef (IORef)+import Data.IORef qualified as Ref+import System.Mem.Weak (Weak)++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Prim++-- | Lifted 'Ref.newIORef'.+newIORef :: Prim :> es => a -> Eff es (IORef a)+newIORef = unsafeEff_ . Ref.newIORef++-- | Lifted 'Ref.readIORef'.+readIORef :: Prim :> es => IORef a -> Eff es a+readIORef = unsafeEff_ . Ref.readIORef++-- | Lifted 'Ref.writeIORef'.+writeIORef :: Prim :> es => IORef a -> a -> Eff es ()+writeIORef var = unsafeEff_ . Ref.writeIORef var++-- | Lifted 'Ref.modifyIORef'.+modifyIORef :: Prim :> es => IORef a -> (a -> a) -> Eff es ()+modifyIORef var = unsafeEff_ . Ref.modifyIORef var++-- | Lifted 'Ref.modifyIORef''.+modifyIORef' :: Prim :> es => IORef a -> (a -> a) -> Eff es ()+modifyIORef' var = unsafeEff_ . Ref.modifyIORef' var++-- | Lifted 'Ref.atomicModifyIORef'.+atomicModifyIORef :: Prim :> es => IORef a -> (a -> (a, b)) -> Eff es b+atomicModifyIORef var = unsafeEff_ . Ref.atomicModifyIORef var++-- | Lifted 'Ref.atomicModifyIORef''.+atomicModifyIORef' :: Prim :> es => IORef a -> (a -> (a, b)) -> Eff es b+atomicModifyIORef' var = unsafeEff_ . Ref.atomicModifyIORef' var++-- | Lifted 'Ref.atomicWriteIORef'.+atomicWriteIORef :: Prim :> es => IORef a -> a -> Eff es ()+atomicWriteIORef var = unsafeEff_ . Ref.atomicWriteIORef var++-- | Lifted 'Ref.mkWeakIORef'.+--+-- /Note:/ the finalizer will run a cloned environment, so any changes it makes+-- to thread local data will not be visible outside of it.+mkWeakIORef+ :: (HasCallStack, Prim :> es)+ => IORef a+ -> Eff es ()+ -> Eff es (Weak (IORef a))+mkWeakIORef var f = unsafeEff $ \es -> do+ -- The finalizer can run at any point and in any thread.+ Ref.mkWeakIORef var . unEff f =<< cloneEnv es
+ src/Effectful/Prim/IORef/Strict.hs view
@@ -0,0 +1,66 @@+-- | Lifted "Data.IORef.Strict".+--+-- @since 2.4.0.0+module Effectful.Prim.IORef.Strict+ ( -- * Effect+ Prim++ -- ** Handlers+ , runPrim++ -- * IORef+ , IORef+ , newIORef+ , readIORef+ , writeIORef+ , modifyIORef+ , atomicModifyIORef+ , atomicWriteIORef+ , mkWeakIORef+ ) where++import Data.IORef.Strict (IORef)+import Data.IORef.Strict qualified as Ref+import System.Mem.Weak (Weak)++import Effectful+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Prim++-- | Lifted 'Ref.newIORef'.+newIORef :: Prim :> es => a -> Eff es (IORef a)+newIORef = unsafeEff_ . Ref.newIORef++-- | Lifted 'Ref.readIORef'.+readIORef :: Prim :> es => IORef a -> Eff es a+readIORef = unsafeEff_ . Ref.readIORef++-- | Lifted 'Ref.writeIORef'.+writeIORef :: Prim :> es => IORef a -> a -> Eff es ()+writeIORef var = unsafeEff_ . Ref.writeIORef var++-- | Lifted 'Ref.modifyIORef'.+modifyIORef :: Prim :> es => IORef a -> (a -> a) -> Eff es ()+modifyIORef var = unsafeEff_ . Ref.modifyIORef var++-- | Lifted 'Ref.atomicModifyIORef'.+atomicModifyIORef :: Prim :> es => IORef a -> (a -> (a, b)) -> Eff es b+atomicModifyIORef var = unsafeEff_ . Ref.atomicModifyIORef var++-- | Lifted 'Ref.atomicWriteIORef'.+atomicWriteIORef :: Prim :> es => IORef a -> a -> Eff es ()+atomicWriteIORef var = unsafeEff_ . Ref.atomicWriteIORef var++-- | Lifted 'Ref.mkWeakIORef'.+--+-- /Note:/ the finalizer will run a cloned environment, so any changes it makes+-- to thread local data will not be visible outside of it.+mkWeakIORef+ :: (HasCallStack, Prim :> es)+ => IORef a+ -> Eff es ()+ -> Eff es (Weak (IORef a))+mkWeakIORef var f = unsafeEff $ \es -> do+ -- The finalizer can run at any point and in any thread.+ Ref.mkWeakIORef var . unEff f =<< cloneEnv es
src/Effectful/Process.hs view
@@ -51,7 +51,7 @@ import System.Exit (ExitCode) import System.IO (Handle) import System.Posix.Internals (FD)-import qualified System.Process as P+import System.Process qualified as P import Effectful import Effectful.Dispatch.Static@@ -62,7 +62,7 @@ type instance DispatchOf Process = Static WithSideEffects data instance StaticRep Process = Process -runProcess :: IOE :> es => Eff (Process : es) a -> Eff es a+runProcess :: (HasCallStack, IOE :> es) => Eff (Process : es) a -> Eff es a runProcess = evalStaticRep Process ----------------------------------------
src/Effectful/Temporary.hs view
@@ -13,7 +13,7 @@ ) where import System.IO-import qualified UnliftIO.Temporary as T+import UnliftIO.Temporary qualified as T import Effectful import Effectful.Dispatch.Static@@ -25,7 +25,7 @@ data instance StaticRep Temporary = Temporary -- | Run the 'Temporary' effect.-runTemporary :: IOE :> es => Eff (Temporary : es) a -> Eff es a+runTemporary :: (HasCallStack, IOE :> es) => Eff (Temporary : es) a -> Eff es a runTemporary = evalStaticRep Temporary -- | Lifted 'T.withSystemTempFile'.
src/Effectful/Timeout.hs view
@@ -9,7 +9,7 @@ , timeout ) where -import qualified System.Timeout as T+import System.Timeout qualified as T import Effectful import Effectful.Dispatch.Static@@ -21,7 +21,7 @@ data instance StaticRep Timeout = Timeout -- | Run the 'Timeout' effect.-runTimeout :: IOE :> es => Eff (Timeout : es) a -> Eff es a+runTimeout :: (HasCallStack, IOE :> es) => Eff (Timeout : es) a -> Eff es a runTimeout = evalStaticRep Timeout -- | Lifted 'T.timeout'.
tests/AsyncTests.hs view
@@ -2,16 +2,16 @@ import Control.Concurrent (threadDelay) import Control.Monad+import Data.Set qualified as S import Test.Tasty import Test.Tasty.HUnit-import qualified Data.Set as S import Effectful import Effectful.Concurrent.Async import Effectful.Error.Static import Effectful.State.Dynamic -import qualified Utils as U+import Utils qualified as U asyncTests :: TestTree asyncTests = testGroup "Async"
tests/ConcurrencyTests.hs view
@@ -2,15 +2,18 @@ import Control.Concurrent (threadDelay) import Control.Monad+import Data.Set qualified as S import Test.Tasty import Test.Tasty.HUnit import UnliftIO-import qualified Data.Set as S import Effectful+import Effectful.Concurrent qualified as E+import Effectful.Concurrent.Async qualified as E+import Effectful.Dispatch.Dynamic import Effectful.Error.Static import Effectful.State.Dynamic-import qualified Utils as U+import Utils qualified as U concurrencyTests :: TestTree concurrencyTests = testGroup "Concurrency"@@ -20,6 +23,10 @@ , testCase "unlifting several times" test_unliftMany , testCase "async with unmask" test_asyncWithUnmask , testCase "pooled workers" test_pooledWorkers+ , testCase "using local unlift correctly works" test_correctLocalUnlift+ , testCase "using local unlift incorrectly doesn't work" test_wrongLocalUnlift+ , testCase "runInBoundThread shares the environment" test_runInBoundThread+ , testCase "runInUnboundThread shares the environment" test_runInUnboundThread ] test_localState :: Assertion@@ -119,3 +126,44 @@ where n = 10 threads = 4++test_correctLocalUnlift :: Assertion+test_correctLocalUnlift = runEff . E.runConcurrent $ do+ x <- runFork . send . RunAsyncCorrect $ pure ()+ E.wait x++test_wrongLocalUnlift :: Assertion+test_wrongLocalUnlift = runEff . E.runConcurrent $ do+ U.assertThrowsErrorCall "invalid LocalEnv use" $ do+ x <- runFork . send . RunAsyncWrong $ pure ()+ E.wait x++test_runInBoundThread :: Assertion+test_runInBoundThread = runEff . E.runConcurrent . evalStateLocal @Int 0 $ do+ E.runInBoundThread $ put @Int 1+ U.assertEqual "state change visible" 1 =<< get @Int++test_runInUnboundThread :: Assertion+test_runInUnboundThread = runEff . E.runConcurrent . evalStateLocal @Int 0 $ do+ E.runInUnboundThread $ put @Int 1+ U.assertEqual "state change visible" 1 =<< get @Int++data Fork :: Effect where+ RunAsyncCorrect :: m a -> Fork m (E.Async a)+ RunAsyncWrong :: m a -> Fork m (E.Async a)+type instance DispatchOf Fork = Dynamic++runFork :: (IOE :> es, E.Concurrent :> es) => Eff (Fork : es) a -> Eff es a+runFork = interpret $ \env -> \case+ RunAsyncCorrect action -> do+ -- LocalEnv is correctly used in the thread in belongs to, so creation of+ -- the unlifting function should succeed.+ localUnlift env strategy $ \unlift -> do+ E.async $ unlift action+ RunAsyncWrong action -> E.async $ do+ -- LocalEnv is incorrectly passed to a different thread, so creation of the+ -- unlifting function should fail.+ localUnlift env strategy $ \unlift -> do+ unlift action+ where+ strategy = ConcUnlift Ephemeral $ Limited 1
tests/EnvTests.hs view
@@ -11,17 +11,24 @@ import Effectful.Dispatch.Static.Primitive import Effectful.Reader.Static import Effectful.Provider+import Effectful.Provider.List import Effectful.State.Static.Local-import qualified Utils as U+import Utils qualified as U envTests :: TestTree envTests = testGroup "Env" [ testCase "tailEnv works" test_tailEnv+ , testCase "unconsEnv of a derived environment errors out" test_unconsDerivedEnv , testCase "subsume works" test_subsumeEnv , testCase "inject works" test_injectEnv , testCase "unsafeCoerce doesn't work" test_noUnsafeCoerce , testCase "interpose works" test_interpose , testCase "interpose/provider works" test_interposeProvider+ , testCase "provider interposition works" test_providerInterposition+ , testCase "provider list interposition works" test_providerListInterposition+ , testCase "localSeqLend/localSeqBorrow works" test_lendBorrowSeparate+ , testCase "localLendBorrow works" test_lendBorrowCombined+ , testCase "lend/borrow combined shares storage" test_lendBorrowForkShares ] test_tailEnv :: Assertion@@ -36,6 +43,14 @@ s0 :: Int s0 = 1337 +-- | 'unconsEnv' is only meant to form a bracket with 'consEnv', so it must+-- reject environments with a non-zero offset instead of deleting an effect+-- different than the requested one.+test_unconsDerivedEnv :: Assertion+test_unconsDerivedEnv = runEff . evalState @Int 0 . evalState @Bool False $ do+ U.assertThrowsErrorCall "unconsEnv of a derived environment" $ do+ unsafeEff $ \es -> unconsEnv =<< tailEnv es+ test_subsumeEnv :: Assertion test_subsumeEnv = runEff $ do s <- execState @Int 0 . subsume @(State Int) $ do@@ -103,8 +118,6 @@ test_noUnsafeCoerce = do r1 <- try @ErrorCall . evaluate $ unsafeCoerce1 @Int 'a' assertBool "unsafeCoerce1" (isLeft r1)- r2 <- try @ErrorCall . evaluate $ unsafeCoerce2 @Int 'a'- assertBool "unsafeCoerce2" (isLeft r2) unsafeCoerce1 :: forall b a. a -> b unsafeCoerce1 a = runPureEff $ do@@ -121,26 +134,6 @@ Box b <- runReader (Box a) $ raise oops pure b -unsafeCoerce2 :: forall b a. a -> b-unsafeCoerce2 a = runPureEff $ do- backupEs <- unsafeEff cloneEnv- -- 'oops' gains access to the effect stack with Reader (Box b) via the- -- unlifting function that escaped its scope. The problem here is that this- -- effect is no longer in scope.- oops <- runReader @(Box b) (Box undefined) $ do- raiseWith SeqUnlift $ \unlift -> do- pure . unlift $ ask @(Box b)- -- If restoreEnv messes up versioning (i.e. restores the version counter from- -- before the above Reader was used), below code will succeed because the- -- Reader (Box a) will have the same version as Reader (Box b).- unsafeEff $ \es -> restoreEnv es backupEs- -- Put Reader (Box a) where the Reader (Box b) was before and attempt to- -- retrieve 'a' coerced to 'b'. It should fail because 'getLocation' in- -- 'Effectful.Internal.Env' checks that version of the reference is the same- -- as version of the effect.- Box b <- runReader (Box a) $ raise oops- pure b- data Box a = Box a ----------------------------------------@@ -186,16 +179,52 @@ U.assertEqual "b6" 4 b6 U.assertEqual "b7" 8 b7 +test_providerInterposition :: IO ()+test_providerInterposition = runEff $ do+ runProvider_ @B @Int (\n -> interpret_ $ \case B -> pure n) $ do+ b1 <- provideWith_ @B @Int 2 $ send B+ U.assertEqual "b1 original" 2 b1+ doubleProviderInput $ do+ b2 <- provideWith_ @B @Int 2 $ send B+ U.assertEqual "b2 interposed" 4 b2+ b3 <- provideWith_ @B @Int 2 $ send B+ U.assertEqual "b3 original" 2 b3++-- | Modify the input of a provider and delegate to the original one.+doubleProviderInput :: Provider_ B Int :> es => Eff es a -> Eff es a+doubleProviderInput = interpose @(Provider_ B Int) $ \env -> \case+ ProvideWith n action -> passthrough env $ ProvideWith (n * 2) action++test_providerListInterposition :: IO ()+test_providerListInterposition = runEff $ do+ runProviderList_ @[B, A] (\(n :: Int) -> runA n . runB) $ do+ b1 <- provideListWith_ @[B, A] @Int 2 $ send B+ U.assertEqual "b1 original" 2 b1+ doubleInput $ do+ b2 <- provideListWith_ @[B, A] @Int 2 $ send B+ U.assertEqual "b2 interposed" 4 b2+ b3 <- provideListWith_ @[B, A] @Int 2 $ send B+ U.assertEqual "b3 original" 2 b3+ where+ -- Delegates manually instead of using passthrough to exercise+ -- localSeqLend with effects introduced by an upstream handler.+ doubleInput :: ProviderList_ [B, A] Int :> es => Eff es a -> Eff es a+ doubleInput = interpose @(ProviderList_ [B, A] Int) $ \env -> \case+ ProvideListWith n action -> provideListWith @[B, A] (n * 2) $ do+ localSeqUnlift env $ \unlift -> do+ localSeqLend @[B, A] env $ \lend -> do+ unlift (lend action)+ data A :: Effect where A :: A m Int type instance DispatchOf A = Dynamic runA :: Int -> Eff (A : es) a -> Eff es a-runA n = interpret $ \_ -> \case+runA n = interpret_ $ \case A -> pure n doubleA :: A :> es => Eff es a -> Eff es a-doubleA = interpose $ \_ -> \case+doubleA = interpose_ $ \case A -> (+) <$> send A <*> send A data B :: Effect where@@ -203,9 +232,89 @@ type instance DispatchOf B = Dynamic runB :: A :> es => Eff (B : es) a -> Eff es a-runB = interpret $ \_ -> \case+runB = interpret_ $ \case B -> send A doubleB :: B :> es => Eff es a -> Eff es a-doubleB = interpose $ \_ -> \case+doubleB = interpose_ $ \case B -> (+) <$> send B <*> send B++----------------------------------------++test_lendBorrowSeparate :: Assertion+test_lendBorrowSeparate = runEff $ do+ runX1 1 2 . evalState @[Int] [3] . runReader () . runReader @[Int] [4] $ do+ U.assertEqual "expected result" [1,2,3,4,1,2,3,4] =<< send X++test_lendBorrowCombined :: Assertion+test_lendBorrowCombined = runEff $ do+ runX2 1 2 . evalState @[Int] [3] . runReader () . runReader @[Int] [4] $ do+ U.assertEqual "expected result" [1,2,3,4,1,2,3,4] =<< send X++data X :: Effect where+ X :: (State [Int] :> es, Reader [Int] :> es, Reader () :> es) => X (Eff es) [Int]+type instance DispatchOf X = Dynamic++runX1 :: Int -> Int -> Eff (X : es) a -> Eff es a+runX1 s0 r0 = reinterpret (evalState s0 . evalState () . runReader r0) $ \env -> \case+ X -> localSeqUnlift env $ \unlift -> do+ localSeqLend @[State Int, Reader Int] env $ \lend -> do+ localSeqBorrow @[Reader [Int], State [Int], Reader ()] env $ \borrow -> do+ as <- unlift . lend $ do+ () <- ask+ s <- get @Int+ r <- ask @Int+ ss <- get @[Int]+ rs <- ask @[Int]+ pure $ [s, r] ++ ss ++ rs+ bs <- borrow $ do+ () <- ask+ s <- get @Int+ r <- ask @Int+ ss <- get @[Int]+ rs <- ask @[Int]+ pure $ [s, r] ++ ss ++ rs+ pure $ as ++ bs++runX2 :: Int -> Int -> Eff (X : es) a -> Eff es a+runX2 s0 r0 = reinterpret (evalState s0 . evalState () . runReader r0) $ \env -> \case+ X -> localSeqUnlift env $ \unlift -> do+ localLendBorrow+ @[State Int, Reader Int]+ @[Reader [Int], State [Int], Reader ()]+ env SeqUnlift $ \lend borrow -> do+ as <- unlift . lend $ do+ () <- ask+ s <- get @Int+ r <- ask @Int+ ss <- get @[Int]+ rs <- ask @[Int]+ pure $ [s, r] ++ ss ++ rs+ bs <- borrow $ do+ () <- ask+ s <- get @Int+ r <- ask @Int+ ss <- get @[Int]+ rs <- ask @[Int]+ pure $ [s, r] ++ ss ++ rs+ pure $ as ++ bs++-- | Under 'SeqForkUnlift' state modification done via the borrowing function+-- must also be visible via the lending function (they share the forked+-- storage), but invisible to the handler.+test_lendBorrowForkShares :: Assertion+test_lendBorrowForkShares = runEff . evalState @Int 0 . runY $ do+ U.assertEqual "lend sees borrow's write" 1 =<< send Y+ U.assertEqual "handler is isolated" 0 =<< get @Int++data Y :: Effect where+ Y :: State Int :> es => Y (Eff es) Int+type instance DispatchOf Y = Dynamic++runY :: State Int :> es => Eff (Y : es) a -> Eff es a+runY = interpret $ \env Y ->+ localLendBorrow @'[State Int] @'[State Int] env SeqForkUnlift $ \lend borrow -> do+ -- Write via borrow (runs against the forked clone)...+ borrow $ put @Int 1+ -- ...and read it back via lend (against the same forked clone).+ localSeqUnlift env $ \unlift -> unlift . lend $ get @Int
tests/EnvironmentTests.hs view
@@ -6,7 +6,7 @@ import Effectful import Effectful.Environment-import qualified Utils as U+import Utils qualified as U environmentTests :: TestTree environmentTests = testCaseSteps "Environment" $ \step -> do
tests/ErrorTests.hs view
@@ -5,11 +5,14 @@ import Effectful import Effectful.Dispatch.Dynamic+import Effectful.Error.Dynamic qualified as D import Effectful.Error.Static errorTests :: TestTree errorTests = testGroup "Error" [ testCase "different handlers are independent" test_independentHandlers+ , testCase "call stack of dynamic throwError doesn't show internal details" test_dynamicThrowErrorCallStack+ , testCase "rethrowError attaches the given call stack" test_rethrowError ] test_independentHandlers :: Assertion@@ -21,6 +24,27 @@ "outerThrow" == fst (last $ getCallStack cs) Right _ -> assertFailure "error caught by the wrong (inner) handler" +test_dynamicThrowErrorCallStack :: Assertion+test_dynamicThrowErrorCallStack = do+ Left (cs, ()) <- runEff . D.runError @() $ D.throwError ()+ case getCallStack cs of+ [("throwError", _)] -> pure ()+ _ -> assertFailure $ "invalid call stack: " ++ prettyCallStack cs++test_rethrowError :: Assertion+test_rethrowError = runEff $ do+ result <- runError @Int . runError @String $ do+ originalThrow `catchError` \cs (_ :: String) -> rethrowError cs (42 :: Int)+ liftIO $ case result of+ Left (cs, e) -> do+ assertEqual "rethrown error" 42 e+ assertBool "stack trace points to the original throw" $+ "originalThrow" == fst (last $ getCallStack cs)+ Right _ -> assertFailure "error not rethrown"+ where+ originalThrow :: (HasCallStack, Error String :> es) => Eff es a+ originalThrow = throwError "oops"+ ---------------------------------------- -- Helpers @@ -33,5 +57,5 @@ outerThrow = send OuterThrow runOuterThrow :: Error String :> es => Eff (OuterThrow : es) a -> Eff es a-runOuterThrow = interpret $ \_ -> \case+runOuterThrow = interpret_ $ \case OuterThrow -> throwError "outer"
+ tests/ExceptionTests.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE CPP #-}+module ExceptionTests (exceptionTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Effectful+import Effectful.Exception+import Effectful.State.Static.Local++import Utils qualified as U++exceptionTests :: TestTree+exceptionTests = testGroup "Exception"+ [ testCase "cleanup actions run in the correct order" test_cleanupOrder+ , testCase "cleanup actions run masked" test_cleanupMasking+#if MIN_VERSION_base(4,21,0)+ , testCase "throwing cleanup action doesn't lose the original exception"+ test_cleanupKeepsOriginalException+#endif+ ]++test_cleanupOrder :: Assertion+test_cleanupOrder = runEff $ do+ checkOrder "bracket (success)" ["acquire", "action", "release"] $+ bracket (record "acquire") (\_ -> record "release") (\_ -> record "action")+ checkOrder "bracket (failure)" ["acquire", "action", "release"] $+ bracket (record "acquire") (\_ -> record "release") (\_ -> failingAction)+ checkOrder "bracket_ (failure)" ["acquire", "action", "release"] $+ bracket_ (record "acquire") (record "release") failingAction+ checkOrder "bracketOnError (success)" ["acquire", "action"] $+ bracketOnError (record "acquire") (\_ -> record "release") (\_ -> record "action")+ checkOrder "bracketOnError (failure)" ["acquire", "action", "release"] $+ bracketOnError (record "acquire") (\_ -> record "release") (\_ -> failingAction)+ checkOrder "finally (success)" ["action", "release"] $+ record "action" `finally` record "release"+ checkOrder "finally (failure)" ["action", "release"] $+ failingAction `finally` record "release"+ checkOrder "onException (success)" ["action"] $+ record "action" `onException` record "release"+ checkOrder "onException (failure)" ["action", "release"] $+ failingAction `onException` record "release"+ where+ record :: State [String] :> es => String -> Eff es ()+ record msg = modify (msg :)++ failingAction :: State [String] :> es => Eff es ()+ failingAction = record "action" >> throwIO Original++ checkOrder+ :: (HasCallStack, IOE :> es)+ => String+ -> [String]+ -> Eff (State [String] : es) a+ -> Eff es ()+ checkOrder name expected action = do+ recorded <- execState [] . trySync $ action+ U.assertEqual name expected (reverse recorded)++test_cleanupMasking :: Assertion+test_cleanupMasking = runEff $ do+ bracket getMaskingState+ (\acquire -> do+ release <- getMaskingState+ U.assertEqual "acquire is masked" MaskedInterruptible acquire+ U.assertEqual "release is masked" MaskedInterruptible release+ )+ (\_ -> do+ action <- getMaskingState+ U.assertEqual "action is unmasked" Unmasked action+ )++#if MIN_VERSION_base(4,21,0)+test_cleanupKeepsOriginalException :: Assertion+test_cleanupKeepsOriginalException = runEff $ do+ check "bracket" $+ bracket (pure ()) (\_ -> failingCleanup) (\_ -> failingAction)+ check "bracket_" $+ bracket_ (pure ()) failingCleanup failingAction+ check "bracketOnError" $+ bracketOnError (pure ()) (\_ -> failingCleanup) (\_ -> failingAction)+ check "finally" $+ failingAction `finally` failingCleanup+ check "onException" $+ failingAction `onException` failingCleanup+ check "withException" $+ withException failingAction (\Original -> failingCleanup)+ where+ failingAction, failingCleanup :: Eff es ()+ failingAction = throwIO Original+ failingCleanup = throwIO Cleanup++ check :: (HasCallStack, IOE :> es) => String -> Eff es () -> Eff es ()+ check name action = trySync action >>= \case+ Right () -> U.assertFailure $ name ++ ": no exception was thrown"+ Left ex -> do+ U.assertBool (name ++ ": exception of the cleanup action propagates")+ $ isCleanup ex+ U.assertBool (name ++ ": the original exception is preserved")+ $ any isOriginal (whileHandling ex)++ -- | Exceptions recorded in the 'WhileHandling' annotations of the given one.+ whileHandling :: SomeException -> [SomeException]+ whileHandling ex =+ [ orig+ | WhileHandling orig <- getExceptionAnnotations (someExceptionContext ex)+ ]++ isOriginal :: SomeException -> Bool+ isOriginal ex = case fromException ex of+ Just Original -> True+ Nothing -> False++ isCleanup :: SomeException -> Bool+ isCleanup ex = case fromException ex of+ Just Cleanup -> True+ Nothing -> False+#endif++----------------------------------------+-- Helpers++data Original = Original+ deriving stock (Eq, Show)+instance Exception Original++#if MIN_VERSION_base(4,21,0)+data Cleanup = Cleanup+ deriving stock (Eq, Show)+instance Exception Cleanup+#endif
+ tests/FileSystemTests.hs view
@@ -0,0 +1,53 @@+module FileSystemTests (fileSystemTests) where++import Data.ByteString.Char8 qualified as BS8+import System.OsPath ((</>))+import System.OsPath qualified as OsPath+import Test.Tasty+import Test.Tasty.HUnit++import Effectful+import Effectful.FileSystem.File.OsPath qualified as F+import Effectful.FileSystem.OsPath+import Effectful.Temporary+import Utils qualified as U++fileSystemTests :: TestTree+fileSystemTests = testGroup "FileSystem"+ [ testCase "OsPath directory operations" test_directoryOperations+ , testCase "OsPath file operations" test_fileOperations+ ]++test_directoryOperations :: Assertion+test_directoryOperations = runEff . runFileSystem . runTemporary $ do+ withSystemTempDirectory "effectful" $ \tmpDirFp -> do+ tmpDir <- OsPath.encodeUtf tmpDirFp+ subDirName <- OsPath.encodeUtf "subdir"+ let subDir = tmpDir </> subDirName+ createDirectory subDir+ subDirExists <- doesDirectoryExist subDir+ U.assertBool "subdirectory was not created" subDirExists+ newDirName <- OsPath.encodeUtf "newdir"+ let newDir = tmpDir </> newDirName+ renameDirectory subDir newDir+ contents <- listDirectory tmpDir+ U.assertEqual "unexpected directory contents" [newDirName] contents+ removeDirectory newDir+ newDirExists <- doesDirectoryExist newDir+ U.assertBool "directory was not removed" (not newDirExists)++test_fileOperations :: Assertion+test_fileOperations = runEff . runFileSystem . runTemporary $ do+ withSystemTempDirectory "effectful" $ \tmpDirFp -> do+ tmpDir <- OsPath.encodeUtf tmpDirFp+ fileName <- OsPath.encodeUtf "test.txt"+ let file = tmpDir </> fileName+ F.writeFile' file (BS8.pack "hello")+ F.appendFile' file (BS8.pack " world")+ contents <- F.readFile' file+ U.assertEqual "unexpected file contents" (BS8.pack "hello world") contents+ size <- getFileSize file+ U.assertEqual "unexpected file size" 11 size+ removeFile file+ fileExists <- doesFileExist file+ U.assertBool "file was not removed" (not fileExists)
+ tests/InputTests.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+module InputTests (inputTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Effectful+import Effectful.State.Static.Local+import Effectful.Input.Dynamic qualified as ID+import Effectful.Input.Static qualified as IS+import Effectful.Input.Static.Action qualified as IA+import Effectful.Labeled.Input qualified as LI+import Utils qualified as U++inputTests :: TestTree+inputTests = testGroup "Input"+ [ testCase "static" test_static+ , testCase "static action reruns the action" test_staticAction+ , testCase "dynamic (value)" test_dynamicValue+ , testCase "dynamic (action) reruns the action" test_dynamicAction+ , testCase "labeled inputs are independent" test_labeled+ ]++test_static :: Assertion+test_static = runEff . IS.runInput @Int 42 $ do+ U.assertEqual "input" 42 =<< IS.input @Int+ U.assertEqual "inputs" 43 =<< IS.inputs @Int (+ 1)++test_staticAction :: Assertion+test_staticAction = runEff . evalState @Int 0 . IA.runInput nextValue $ do+ U.assertEqual "1st input" 1 =<< IA.input @Int+ U.assertEqual "2nd input" 2 =<< IA.input @Int+ U.assertEqual "inputs" 3 =<< IA.inputs @Int id++test_dynamicValue :: Assertion+test_dynamicValue = runEff . ID.runInput @Int 42 $ do+ U.assertEqual "input" 42 =<< ID.input @Int+ U.assertEqual "inputs" 43 =<< ID.inputs @Int (+ 1)++test_dynamicAction :: Assertion+test_dynamicAction = runEff . evalState @Int 0 . ID.runInputAction nextValue $ do+ U.assertEqual "1st input" 1 =<< ID.input @Int+ U.assertEqual "2nd input" 2 =<< ID.input @Int+ U.assertEqual "inputs" 3 =<< ID.inputs @Int id++test_labeled :: Assertion+test_labeled = runEff+ . evalState @Int 0+ . LI.runInput @"a" @Int 1+ . LI.runInputAction @"b" nextValue+ $ do+ U.assertEqual "a" 1 =<< LI.input @"a" @Int+ U.assertEqual "inputs a" 11 =<< LI.inputs @"a" @Int (+ 10)+ U.assertEqual "1st b" 1 =<< LI.input @"b" @Int+ U.assertEqual "2nd b" 2 =<< LI.input @"b" @Int+ -- "a" is unaffected by reads of "b".+ U.assertEqual "a again" 1 =<< LI.input @"a" @Int++-- | An action that returns consecutive integers, so that re-running it is+-- observable.+nextValue :: State Int :> es => Eff es Int+nextValue = do+ modify @Int (+ 1)+ get
+ tests/LabeledTests.hs view
@@ -0,0 +1,61 @@+module LabeledTests (labeledTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Labeled+import Effectful.Reader.Static+import Utils qualified as U++labeledTests :: TestTree+labeledTests = testGroup "Labeled"+ [ testCase "labeled behaves correctly" $ test_labeledBehavior+ , testCase "(labeled . send) and (send . Labeled) behave the same" $ test_labeledSend+ ]++test_labeledBehavior :: Assertion+test_labeledBehavior = do+ v <- runEff+ . runLabeled @"a" (runReader "a")+ . runLabeled @"b" (runReader "b")+ . runReader "c"+ $ action+ assertEqual "expected result" "abc" v+ where+ action+ :: ( Labeled "a" (Reader String) :> es+ , Labeled "b" (Reader String) :> es+ , Reader String :> es+ )+ => Eff es String+ action = do+ a <- labeled @"b" @(Reader String) $ do+ labeled @"a" @(Reader String) $ do+ ask+ b <- labeled @"b" @(Reader String) $ do+ ask+ c <- ask+ pure $ a ++ b ++ c++test_labeledSend :: Assertion+test_labeledSend = runEff $ do+ runX 1 . runLabeled @"x" (runX 2) $ do+ v0 <- send X2+ U.assertEqual "expected result" 1 v0+ v1 <- (labeled @"x" @X . send) X2+ U.assertEqual "expected result" 2 v1+ v2 <- (send . Labeled @"x") X2+ U.assertEqual "expected result" 2 v2++data X :: Effect where+ X1 :: X m Int+ X2 :: (X :> es, Labeled "x" X :> es) => X (Eff es) Int++type instance DispatchOf X = Dynamic++runX :: Int -> Eff (X : es) a -> Eff es a+runX x = interpret $ \env -> \case+ X1 -> pure x+ X2 -> localSeqUnlift env $ \unlift -> unlift $ send X1
tests/Main.hs view
@@ -7,12 +7,19 @@ import EnvTests import EnvironmentTests import ErrorTests+import ExceptionTests+import FileSystemTests+import InputTests+import LabeledTests import NonDetTests+import OutputTests import PrimTests import ReaderTests+import ReturnWithTests import StateTests import TimeoutTests import UnliftTests+import Word64MapTests main :: IO () main = defaultMain $ testGroup "effectful"@@ -21,10 +28,17 @@ , envTests , environmentTests , errorTests+ , exceptionTests+ , fileSystemTests+ , inputTests+ , labeledTests , nonDetTests+ , outputTests , primTests , readerTests+ , returnWithTests , stateTests , timeoutTests , unliftTests+ , word64MapTests ]
tests/NonDetTests.hs view
@@ -1,15 +1,21 @@ module NonDetTests (nonDetTests) where +import Data.IORef.Strict qualified as S+import Data.Primitive.PrimArray import Test.Tasty import Test.Tasty.HUnit import Effectful import Effectful.Dispatch.Dynamic+import Effectful.Dispatch.Static+import Effectful.Dispatch.Static.Primitive+import Effectful.Internal.Env qualified as I+import Effectful.Internal.Utils import Effectful.NonDet import Effectful.Reader.Static import Effectful.State.Dynamic -import qualified Utils as U+import Utils qualified as U nonDetTests :: TestTree nonDetTests = testGroup "NonDet"@@ -19,7 +25,9 @@ [ testCaseSteps "local state" $ test_state evalStateLocal expectedLocalState , testCaseSteps "shared state" $ test_state evalStateShared expectedSharedState ]+ , testCaseSteps "local mutable state" $ test_mutState expectedLocalState , testCaseSteps "different handlers are independent" test_independentHandlers+ , testCase "stale reference is detected after rollback" test_staleReferenceAfterRollback ] where leftEmpty :: NonDet :> es => Eff es Bool@@ -30,11 +38,11 @@ expectedLocalState :: OnEmptyPolicy -> Int expectedLocalState = \case- OnEmptyKeep -> 3- OnEmptyRollback -> 2+ OnEmptyKeep -> 7+ OnEmptyRollback -> 0 expectedSharedState :: OnEmptyPolicy -> Int- expectedSharedState _ = 3+ expectedSharedState _ = 7 test_empty :: Eff [NonDet, IOE] Bool@@ -53,13 +61,33 @@ test_state evalState expectedState step = runEff $ do evalState 0 . runNonDetBoth test $ \policy result -> do liftIO . step $ show policy- U.assertEqual "result" (Just ()) (dropLeft result)+ U.assertEqual "result" Nothing (dropLeft result) s <- state @Int $ \s -> (s, 0) U.assertEqual "state" (expectedState policy) s where test :: (NonDet :> es, State Int :> es) => Eff es ()- test = (modify @Int (+1) >> empty) <|> modify @Int (+2)+ test = do+ modify @Int (+1)+ _<- (modify @Int (+2) >> empty) <|> (modify @Int (+4) >> empty)+ modify @Int (+8) +test_mutState+ :: (OnEmptyPolicy -> Int)+ -> (String -> IO ())+ -> IO ()+test_mutState expectedState step = runEff $ do+ runMutInt 0 . runNonDetBoth test $ \policy result -> do+ liftIO . step $ show policy+ s <- stateMutInt $ \s -> (s, 0)+ U.assertEqual "result" Nothing (dropLeft result)+ U.assertEqual "state" (expectedState policy) s+ where+ test :: (NonDet :> es, MutInt :> es) => Eff es ()+ test = do+ modifyMutInt (+1)+ _<- (modifyMutInt (+2) >> empty) <|> (modifyMutInt (+4) >> empty)+ modifyMutInt (+8)+ test_independentHandlers :: (String -> IO ()) -> Assertion test_independentHandlers step = runEff $ do runNonDetBoth test $ \policy result -> liftIO $ do@@ -72,9 +100,73 @@ test :: NonDet :> es => Eff es (Either CallStack Bool) test = runOuterEmpty . runNonDet OnEmptyKeep $ outerEmpty <|> pure True +-- | A reference to an effect captured inside a rolled back branch must be+-- detected as out of date even if the storage was grown within the branch, in+-- which case the rollback must not shrink its capacity.+test_staleReferenceAfterRollback :: Assertion+test_staleReferenceAfterRollback = runEff $ do+ ref <- liftIO $ S.newIORef Nothing+ result <- runNonDet OnEmptyRollback $+ (do stale <- captureStaleReference 16+ capacity <- getStorageCapacity+ liftIO $ S.writeIORef ref $ Just (capacity, stale)+ emptyEff)+ <|> pure True+ U.assertEqual "result" (Just True) (dropLeft result)+ liftIO (S.readIORef ref) >>= \case+ Nothing -> U.assertFailure "stale reference not captured"+ Just (capacity, stale) -> do+ -- If the rollback shrunk the capacity of the storage, evaluation of the+ -- stale reference below would read out of bounds.+ U.assertEqual "capacity" capacity =<< getStorageCapacity+ U.assertThrowsErrorCall "stale reference detected" $ liftIO stale++-- | Run a computation under the given number of effect handlers to grow the+-- storage, then capture an unlifted reference to the innermost one.+captureStaleReference :: IOE :> es => Int -> Eff es (IO Int)+captureStaleReference n = evalStateLocal @Int n $+ if n <= 0+ then withEffToIO SeqUnlift $ \unlift -> pure . unlift $ get @Int+ else captureStaleReference (n - 1)++-- | Get the current capacity of the underlying storage of effects.+getStorageCapacity :: Eff es Int+getStorageCapacity = unsafeEff $ \es -> do+ I.Storage _ storageData <- S.readIORef es.storage+ getSizeofMutablePrimArray storageData.versions+ ---------------------------------------- -- Helpers +data MutInt :: Effect+type instance DispatchOf MutInt = Static NoSideEffects+newtype instance StaticRep MutInt = MutInt (S.IORef Int)++runMutInt :: Int -> Eff (MutInt : es) a -> Eff es a+runMutInt s action = unsafeEff $ \es -> do+ ref <- S.newIORef s+ inlineBracket+ (consEnv (MutInt ref) relinkMutInt es)+ unconsEnv+ (unEff action)+ where+ relinkMutInt :: Relinker StaticRep MutInt+ relinkMutInt = Relinker $ \_ (MutInt ref0) -> do+ ref <- S.newIORef =<< S.readIORef ref0+ pure $ MutInt ref++stateMutInt :: MutInt :> es => (Int -> (a, Int)) -> Eff es a+stateMutInt f = unsafeEff $ \es -> do+ MutInt ref <- getEnv es+ (r, s) <- f <$> S.readIORef ref+ S.writeIORef ref s+ pure r++modifyMutInt :: MutInt :> es => (Int -> Int) -> Eff es ()+modifyMutInt f = stateMutInt $ ((),) . f++----+ data OuterEmpty :: Effect where OuterEmpty :: OuterEmpty m a @@ -84,7 +176,7 @@ outerEmpty = send OuterEmpty runOuterEmpty :: NonDet :> es => Eff (OuterEmpty : es) a -> Eff es a-runOuterEmpty = interpret $ \_ -> \case+runOuterEmpty = interpret_ $ \case OuterEmpty -> emptyEff ----
+ tests/OutputTests.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+module OutputTests (outputTests) where++import Data.Foldable qualified as F+import Test.Tasty+import Test.Tasty.HUnit++import Effectful+import Effectful.State.Static.Local+import Effectful.Output.Dynamic qualified as OD+import Effectful.Output.Static.Action qualified as OA+import Effectful.Output.Static.Local.Array qualified as OLA+import Effectful.Output.Static.Local.List qualified as OLL+import Effectful.Output.Static.Shared.Array qualified as OSA+import Effectful.Output.Static.Shared.List qualified as OSL+import Effectful.Labeled.Output qualified as LO+import Utils qualified as U++outputTests :: TestTree+outputTests = testGroup "Output"+ [ testCase "static local list" test_localList+ , testCase "static local array" test_localArray+ , testCase "static shared list" test_sharedList+ , testCase "static shared array" test_sharedArray+ , testCase "static action" test_action+ , testCase "dynamic dispatches to all backends" test_dynamic+ , testCase "labeled outputs are independent" test_labeled+ ]++test_localList :: Assertion+test_localList = runEff $ do+ (r, xs) <- OLL.runOutput $ do+ mapM_ OLL.output values+ pure "done"+ U.assertEqual "value" "done" r+ U.assertEqual "list" values xs++test_localArray :: Assertion+test_localArray = runEff $ do+ (r, arr) <- OLA.runOutput $ do+ mapM_ OLA.output values+ pure "done"+ U.assertEqual "value" "done" r+ U.assertEqual "array" values (F.toList arr)++test_sharedList :: Assertion+test_sharedList = runEff $ do+ (r, xs) <- OSL.runOutput $ do+ mapM_ OSL.output values+ pure "done"+ U.assertEqual "value" "done" r+ U.assertEqual "list" values xs++test_sharedArray :: Assertion+test_sharedArray = runEff $ do+ (r, arr) <- OSA.runOutput $ do+ mapM_ OSA.output values+ pure "done"+ U.assertEqual "value" "done" r+ U.assertEqual "array" values (F.toList arr)++test_action :: Assertion+test_action = runEff $ do+ (_, acc) <- runState @[Int] [] . OA.runOutput @Int (\o -> modify (o :)) $ do+ mapM_ OA.output values+ U.assertEqual "values fed in order" (reverse values) acc++test_dynamic :: Assertion+test_dynamic = runEff $ do+ (_, la) <- OD.runOutputLocalArray prog+ U.assertEqual "local array" values (F.toList la)+ (_, ll) <- OD.runOutputLocalList prog+ U.assertEqual "local list" values ll+ (_, sa) <- OD.runOutputSharedArray prog+ U.assertEqual "shared array" values (F.toList sa)+ (_, sl) <- OD.runOutputSharedList prog+ U.assertEqual "shared list" values sl+ (_, acc) <- runState @[Int] [] . OD.runOutputAction @Int (\o -> modify (o :)) $ prog+ U.assertEqual "action" (reverse values) acc+ where+ prog :: (HasCallStack, OD.Output Int :> es) => Eff es ()+ prog = mapM_ OD.output values++test_labeled :: Assertion+test_labeled = runEff $ do+ ((_, bs), as) <- LO.runOutputLocalList @"a" @Int . LO.runOutputLocalList @"b" @Int $ do+ LO.output @"a" @Int 1+ LO.output @"b" @Int 10+ LO.output @"a" @Int 2+ LO.output @"b" @Int 20+ U.assertEqual "label a" [1, 2] as+ U.assertEqual "label b" [10, 20] bs++-- | Emitting more values than the initial (zero) capacity exercises the array+-- growth path in the array backends.+values :: [Int]+values = [1 .. 10]
tests/PrimTests.hs view
@@ -3,7 +3,7 @@ import Data.Primitive.MutVar import Test.Tasty import Test.Tasty.HUnit-import qualified Utils as U+import Utils qualified as U import Effectful import Effectful.Prim
tests/ReaderTests.hs view
@@ -5,13 +5,14 @@ import Effectful import Effectful.Dispatch.Dynamic-import Effectful.Reader.Dynamic-import qualified Utils as U+import Effectful.Reader.Dynamic qualified as D+import Effectful.Reader.Static qualified as S+import Utils qualified as U readerTests :: TestTree readerTests = testGroup "Reader"- [ testCase "local works in handlers (dynamic/static)" $ test_localInHandler runReader- , testCase "local works in handlers (dynamic/pure)" $ test_localInHandler runPureReader+ [ testCase "local works in handlers (static)" test_localInHandlerStatic+ , testCase "local works in handlers (dynamic)" test_localInHandlerDynamic ] data SomeEff :: Effect where@@ -19,21 +20,16 @@ type instance DispatchOf SomeEff = Dynamic -test_localInHandler- :: (forall r es a. r -> Eff (Reader r : es) a -> Eff es a)- -> Assertion-test_localInHandler runR = runEff . runR "global" . interpret f $ do- local (const "local") $ send SomeAction+test_localInHandlerStatic :: Assertion+test_localInHandlerStatic = runEff . S.runReader "global" . interpret f $ do+ S.local (const "local") $ send SomeAction where- f :: (IOE :> es, Reader String :> es) => EffectHandler SomeEff es- f _ SomeAction = U.assertEqual "expected result" "local" =<< ask+ f :: (IOE :> es, S.Reader String :> es) => EffectHandler SomeEff es+ f _ SomeAction = U.assertEqual "expected result" "local" =<< S.ask --- | Purely dynamic Reader for testing purposes.-runPureReader :: r -> Eff (Reader r : es) a -> Eff es a-runPureReader r0 = interpret (handler r0)+test_localInHandlerDynamic :: Assertion+test_localInHandlerDynamic = runEff . D.runReader "global" . interpret f $ do+ D.local (const "local") $ send SomeAction where- handler :: r -> EffectHandler (Reader r) handlerEs- handler r env = \case- Ask -> pure r- Local f m -> localSeqUnlift env $ \unlift -> do- unlift $ interpose (handler $ f r) m+ f :: (IOE :> es, D.Reader String :> es) => EffectHandler SomeEff es+ f _ SomeAction = U.assertEqual "expected result" "local" =<< D.ask
+ tests/ReturnWithTests.hs view
@@ -0,0 +1,88 @@+module ReturnWithTests (returnWithTests) where++import Test.Tasty+import Test.Tasty.HUnit++import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Exception (finally)+import Effectful.Labeled.ReturnWith qualified as LR+import Effectful.ReturnWith.Dynamic qualified as RD+import Effectful.ReturnWith.Static qualified as RS+import Effectful.State.Static.Local+import Utils qualified as U++returnWithTests :: TestTree+returnWithTests = testGroup "ReturnWith"+ [ testCase "static short-circuits" test_static+ , testCase "static falls through" test_staticFallThrough+ , testCase "different handlers are independent" test_independentHandlers+ , testCase "cleanup actions run on early return" test_cleanup+ , testCase "dynamic short-circuits" test_dynamic+ , testCase "labeled handlers are targeted correctly" test_labeled+ ]++test_static :: Assertion+test_static = runEff . evalState @Int 0 $ do+ r <- RS.runReturnWith @String $ do+ modify @Int (+1)+ _ <- RS.returnWith "early"+ modify @Int (+1)+ pure "late"+ U.assertEqual "result" "early" r+ U.assertEqual "state changes before returnWith persist" 1 =<< get @Int++test_staticFallThrough :: Assertion+test_staticFallThrough = runEff $ do+ r <- RS.runReturnWith @String $ pure "done"+ U.assertEqual "result" "done" r++test_independentHandlers :: Assertion+test_independentHandlers = runEff $ do+ r <- RS.runReturnWith @String . runOuterReturn $ do+ inner <- RS.runReturnWith @String $ do+ outerReturn+ pure "inner"+ pure $ "inner handler caught " ++ inner+ U.assertEqual "correct value returned" "outer" r++test_cleanup :: Assertion+test_cleanup = runEff . evalState @Int 0 $ do+ r <- RS.runReturnWith @String $ do+ (RS.returnWith "early" >> pure "late") `finally` modify @Int (+1)+ U.assertEqual "result" "early" r+ U.assertEqual "cleanup ran" 1 =<< get @Int++test_dynamic :: Assertion+test_dynamic = runEff . evalState @Int 0 $ do+ r <- RD.runReturnWith @String $ do+ modify @Int (+1)+ _ <- RD.returnWith "early"+ modify @Int (+1)+ pure "late"+ U.assertEqual "result" "early" r+ U.assertEqual "state changes before returnWith persist" 1 =<< get @Int++test_labeled :: Assertion+test_labeled = runEff $ do+ r <- LR.runReturnWith @"outer" @String $ do+ n <- LR.runReturnWith @"inner" @Int $ do+ _ <- LR.returnWith @"outer" "outer wins"+ pure 0+ pure $ "inner returned " ++ show n+ U.assertEqual "value caught by the outer handler" "outer wins" r++----------------------------------------+-- Helpers++data OuterReturn :: Effect where+ OuterReturn :: OuterReturn m ()++type instance DispatchOf OuterReturn = Dynamic++outerReturn :: OuterReturn :> es => Eff es ()+outerReturn = send OuterReturn++runOuterReturn :: RS.ReturnWith String :> es => Eff (OuterReturn : es) a -> Eff es a+runOuterReturn = interpret_ $ \case+ OuterReturn -> RS.returnWith "outer"
tests/StateTests.hs view
@@ -1,15 +1,22 @@+-- The deprecated stateM needs to be tested until it's removed.+{-# OPTIONS_GHC -Wno-deprecations #-} module StateTests (stateTests) where +import Control.Exception.Lifted qualified as LE+import Control.Exception.Safe qualified as Safe+import Control.Monad+import Control.Monad.Catch qualified as C+import Data.IORef.Strict qualified as S import Test.Tasty import Test.Tasty.HUnit-import qualified Control.Monad.Catch as E-import qualified Control.Exception.Lifted as LE-import qualified UnliftIO.Exception as UE+import UnliftIO.Exception qualified as UE import Effectful import Effectful.Dispatch.Dynamic+import Effectful.Dispatch.Static+import Effectful.Internal.Env import Effectful.State.Static.Local-import qualified Utils as U+import Utils qualified as U stateTests :: TestTree stateTests = testGroup "State"@@ -34,9 +41,19 @@ test_stateM :: Assertion test_stateM = runEff $ do- (a, b) <- runState "hi" . stateM $ \s -> pure (s, s ++ "!!!")+ (a, b) <- runState "hi" $ do+ stateM $ \s -> do+ effs0 <- getEffectReps+ -- Trigger reallocation of the internal array in Storage.+ _ <- evalState () $ pure ()+ effs1 <- getEffectReps+ when (effs0 == effs1) $ do+ U.assertFailure "Internal array was not reallocated"+ pure (s, s ++ "!!!") U.assertEqual "correct a" "hi" a U.assertEqual "correct b" "hi!!!" b+ where+ getEffectReps = unsafeEff $ \es -> (.effects) . (.data_) <$> S.readIORef es.storage test_deepStack :: Assertion test_deepStack = runEff $ do@@ -52,12 +69,14 @@ test_exceptions :: Assertion test_exceptions = runEff $ do- testTry "exceptions" E.try- testCatch "exceptions" E.catch- testTry "lifted-base" LE.try- testCatch "lifted-base" LE.catch- testTry "unliftio" UE.try- testCatch "unliftio" UE.catch+ testTry "exceptions" C.try+ testCatch "exceptions" C.catch+ testTry "safe-exceptions" Safe.try+ testCatch "safe-exceptions" Safe.catch+ testTry "lifted-base" LE.try+ testCatch "lifted-base" LE.catch+ testTry "unliftio" UE.try+ testCatch "unliftio" UE.catch where testTry :: String@@ -82,7 +101,7 @@ action :: State Int :> es => Eff es () action = do modify @Int (+1)- _ <- E.throwM U.Ex+ _ <- C.throwM U.Ex modify @Int (+2) test_localEffects :: Assertion@@ -117,7 +136,7 @@ runHasInt :: Int -> Eff (HasInt : es) a -> Eff es a runHasInt n = -- reinterpret with redundant local effects- reinterpret (evalState () . evalState n . evalState True) $ \_ -> \case+ reinterpret_ (evalState () . evalState n . evalState True) $ \case GetInt -> get PutInt i -> put i
tests/TimeoutTests.hs view
@@ -6,7 +6,7 @@ import Effectful import Effectful.Timeout-import qualified Utils as U+import Utils qualified as U timeoutTests :: TestTree timeoutTests = testGroup "Timeout"@@ -16,7 +16,7 @@ test_returnBeforeTimeout :: Assertion test_returnBeforeTimeout = runEff $ do- result <- runTimeout $ timeout 1000 $ return ()+ result <- runTimeout $ timeout 1000000 $ return () U.assertEqual "return value" (Just ()) result test_timeoutBeforeReturn :: Assertion
tests/UnliftTests.hs view
@@ -1,12 +1,16 @@ module UnliftTests (unliftTests) where -import Control.Exception+import Data.List (isInfixOf) import Test.Tasty import Test.Tasty.HUnit-import qualified UnliftIO.Async as A+import UnliftIO.Async qualified as A import Effectful-import qualified Utils as U+import Effectful.Concurrent.Async qualified as E+import Effectful.Dispatch.Dynamic+import Effectful.Exception+import Effectful.State.Static.Local+import Utils qualified as U unliftTests :: TestTree unliftTests = testGroup "Unlift"@@ -22,6 +26,9 @@ , testCase "Uses in same thread" test_persistentSameThread , testCase "Uses in multiple threads" test_persistentMultipleThreads ]+ , testCase "Unlifting functions work correctly" test_unliftingFunctions+ , testCase "Escaped setup of reinterpret" test_escapedReinterpretSetup+ , testCase "Escaped setup of impose" test_escapedImposeSetup ] test_threadStrategy :: Assertion@@ -34,32 +41,32 @@ test_seqUnliftInNewThread :: Assertion test_seqUnliftInNewThread = runEff $ do- assertThrowsUnliftError "InvalidUseOfSeqUnlift error" $ do+ U.assertThrowsErrorCall "InvalidUseOfSeqUnlift error" $ do withEffToIO SeqUnlift $ \runInIO -> do inThread $ runInIO $ return () test_ephemeralInvalid :: Assertion test_ephemeralInvalid = runEff $ do- assertThrowsUnliftError "InvalidNumberOfUses error" $ do+ U.assertThrowsErrorCall "InvalidNumberOfUses error" $ do withEffToIO (ConcUnlift Ephemeral $ Limited 0) $ \_ -> return () test_ephemeralSameThread :: Assertion test_ephemeralSameThread = runEff $ do- assertThrowsUnliftError "ExceededNumberOfUses error" $ do+ U.assertThrowsErrorCall "ExceededNumberOfUses error" $ do withEffToIO (ConcUnlift Ephemeral $ Limited 1) $ \runInIO -> inThread $ do runInIO $ return () runInIO $ return () test_ephemeralMultipleThreads :: Assertion test_ephemeralMultipleThreads = runEff $ do- assertThrowsUnliftError "ExceededNumberOfUses error" $ do+ U.assertThrowsErrorCall "ExceededNumberOfUses error" $ do withEffToIO (ConcUnlift Ephemeral $ Limited 1) $ \runInIO -> do inThread $ runInIO $ return () inThread $ runInIO $ return () test_persistentInvalid :: Assertion test_persistentInvalid = runEff $ do- assertThrowsUnliftError "InvalidNumberOfThreads error" $ do+ U.assertThrowsErrorCall "InvalidNumberOfThreads error" $ do withEffToIO (ConcUnlift Persistent $ Limited 0) $ \_ -> return () test_persistentSameThread :: Assertion@@ -70,18 +77,97 @@ test_persistentMultipleThreads :: Assertion test_persistentMultipleThreads = runEff $ do- assertThrowsUnliftError "ExceededNumberOfThreads error" $ do+ U.assertThrowsErrorCall "ExceededNumberOfThreads error" $ do withEffToIO (ConcUnlift Persistent $ Limited 1) $ \runInIO -> do inThread $ runInIO $ return () inThread $ runInIO $ return () +test_unliftingFunctions :: Assertion+test_unliftingFunctions = runEff . E.runConcurrent $ do+ testFork "runFork1" runFork1+ testFork "runFork2" runFork2+ testFork "runFork3" runFork3+ testFork "runFork4" runFork4+ where+ testFork description runFork = do+ a <- runFork . send $ ForkWithUnmask $ \unmask -> do+ evalState @Int 0 $ raiseWith SeqUnlift $ \unlift -> do+ unlift $ modify @Int (+1)+ unmask . unlift $ modify @Int (+2)+ unlift $ modify @Int (+4)+ unmask . unlift $ modify @Int (+8)+ unlift $ U.assertEqual (description ++ ": correct state") 15 =<< get @Int+ E.waitCatch a >>= \case+ Right () -> pure ()+ Left err -> U.assertFailure $ description ++ ": " ++ show err++test_escapedReinterpretSetup :: Assertion+test_escapedReinterpretSetup = runEff $ do+ io <- reinterpret_ smuggle (\case E -> pure ()) $ send E+ U.assertThrows "EscapedSetup error" escapedSetupError $ liftIO io++test_escapedImposeSetup :: Assertion+test_escapedImposeSetup = runEff . interpret_ (\case E -> pure ()) $ do+ io <- impose_ smuggle (\case E -> pure ()) $ send E+ U.assertThrows "EscapedSetup error" escapedSetupError $ liftIO io+ -- The escaped computation didn't corrupt the environment.+ send E++-- | Smuggle the computation out of the scope of the setup function.+smuggle :: IOE :> es => Eff es a -> Eff es (IO a)+smuggle m = withEffToIO SeqForkUnlift $ \unlift -> pure (unlift m)++escapedSetupError :: ErrorCall -> Bool+escapedSetupError e = "cloned environment" `isInfixOf` show e++data E :: Effect where+ E :: E m ()+type instance DispatchOf E = Dynamic++data Fork :: Effect where+ ForkWithUnmask :: ((forall a. m a -> m a) -> m r) -> Fork m (A.Async r)+type instance DispatchOf Fork = Dynamic++-- | Uses 'localUnliftIO' and 'withLiftMapIO'.+runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a+runFork1 = interpret $ \env -> \case+ ForkWithUnmask m -> do+ withLiftMapIO env $ \liftMap -> do+ localUnliftIO env strategy $ \unlift -> do+ A.asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask+ where+ strategy = ConcUnlift Ephemeral $ Limited 1++-- | Uses 'localLiftUnliftIO'.+runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a+runFork2 = interpret $ \env -> \case+ ForkWithUnmask m -> do+ localLiftUnliftIO env strategy $ \lift unlift -> do+ A.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift+ where+ strategy = ConcUnlift Persistent $ Limited 1++-- | Uses 'localLiftUnlift'.+runFork3 :: (IOE :> es, E.Concurrent :> es) => Eff (Fork : es) a -> Eff es a+runFork3 = interpret $ \env -> \case+ ForkWithUnmask m -> do+ localLiftUnlift env strategy $ \lift unlift -> do+ E.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift+ where+ strategy = ConcUnlift Persistent $ Limited 1++-- | Uses 'localLift' and 'localUnlift'.+runFork4 :: (IOE :> es, E.Concurrent :> es) => Eff (Fork : es) a -> Eff es a+runFork4 = interpret $ \env -> \case+ ForkWithUnmask m -> do+ localLift env strategy $ \lift -> do+ localUnlift env strategy $ \unlift -> do+ E.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift+ where+ strategy = ConcUnlift Persistent $ Limited 1+ ---------------------------------------- -- Helpers--assertThrowsUnliftError- :: IOE :> es- => String -> Eff es a -> Eff es ()-assertThrowsUnliftError err = U.assertThrows err (\ErrorCall{} -> True) inThread :: IO a -> IO a inThread k = A.async k >>= A.wait
tests/Utils.hs view
@@ -3,14 +3,15 @@ , assertEqual , assertFailure , assertThrows+ , assertThrowsErrorCall , Ex(..) ) where -import Control.Monad.Catch import GHC.Stack-import qualified Test.Tasty.HUnit as T+import Test.Tasty.HUnit qualified as T import Effectful+import Effectful.Exception assertBool :: (HasCallStack, IOE :> es) => String -> Bool -> Eff es () assertBool msg p = liftIO $ T.assertBool msg p@@ -37,5 +38,11 @@ (k >> liftIO (T.assertFailure msg)) pure -data Ex = Ex deriving (Eq, Show)+assertThrowsErrorCall+ :: IOE :> es+ => String -> Eff es a -> Eff es ()+assertThrowsErrorCall err = assertThrows err (\ErrorCall{} -> True)++data Ex = Ex+ deriving stock (Eq, Show) instance Exception Ex
+ tests/Word64MapTests.hs view
@@ -0,0 +1,95 @@+module Word64MapTests (word64MapTests) where++import Data.List qualified as L+import Data.Map.Strict qualified as M+import Data.Word+import System.Random+import Test.Tasty+import Test.Tasty.HUnit++import Effectful.Internal.Utils.Word64Map qualified as WM++word64MapTests :: TestTree+word64MapTests = testGroup "Word64Map"+ [ testCase "Matches Data.Map over a mix of operations" test_differential+ , testCase "Distinguishes keys colliding in the low 32 bits" test_truncation+ , testCase "Handles boundary keys" test_boundary+ , testCase "updateLookupWithKey returns the original value" test_updateLookup+ ]++-- | Run a large mix of inserts and deletes through both 'WM.Word64Map' and+-- 'M.Map' and check that they agree on the value of every key ever touched.+test_differential :: Assertion+test_differential = do+ let poolSize = 5000 :: Word64+ flags = randoms (mkStdGen 1) :: [Bool]+ keys = randomRs (0, poolSize - 1) (mkStdGen 2)+ ops :: [(Bool, Word64, Int)]+ ops = take 200000 (zip3 flags keys [0 ..])+ step (wm, m) (ins, k, v)+ | ins = (WM.insert k v wm, M.insert k v m)+ | otherwise = (WM.delete k wm, M.delete k m)+ (wmFinal, mFinal) = L.foldl' step (WM.empty, M.empty) ops+ case [ k | (_, k, _) <- ops, WM.lookup k wmFinal /= M.lookup k mFinal ] of+ [] -> pure ()+ (k : _) -> assertFailure $+ "Word64Map and Data.Map disagree on key " ++ show k ++ ": "+ ++ show (WM.lookup k wmFinal) ++ " vs " ++ show (M.lookup k mFinal)++-- | Run a mix of inserts, updates and deletes through both 'WM.Word64Map' and+-- 'M.Map', where updates and deletes go through 'WM.updateLookupWithKey'.+-- Check that it returns the original value (like its 'Data.IntMap' counterpart+-- and unlike the one from 'Data.Map', which returns the updated value) and+-- that both maps agree on the value of every key ever touched.+test_updateLookup :: Assertion+test_updateLookup = do+ let poolSize = 500 :: Word64+ sels = randomRs (0 :: Int, 2) (mkStdGen 3)+ keys = randomRs (0, poolSize - 1) (mkStdGen 4)+ ops :: [(Int, Word64, Int)]+ ops = take 50000 (zip3 sels keys [0 ..])+ step (wm, m, bad) (sel, k, v) = case sel of+ 0 -> (WM.insert k v wm, M.insert k v m, bad)+ 1 -> let (mv, wm') = WM.updateLookupWithKey (\_ _ -> Nothing) k wm+ in (wm', M.delete k m, [k | mv /= M.lookup k m] ++ bad)+ _ -> let (mv, wm') = WM.updateLookupWithKey (\_ x -> Just (x + 1)) k wm+ in (wm', M.adjust (+ 1) k m, [k | mv /= M.lookup k m] ++ bad)+ (wmFinal, mFinal, mismatches) = L.foldl' step (WM.empty, M.empty, []) ops+ case mismatches of+ [] -> pure ()+ (k : _) -> assertFailure $+ "updateLookupWithKey returned a wrong value for key " ++ show k+ case [ k | (_, k, _) <- ops, WM.lookup k wmFinal /= M.lookup k mFinal ] of+ [] -> pure ()+ (k : _) -> assertFailure $+ "Word64Map and Data.Map disagree on key " ++ show k ++ ": "+ ++ show (WM.lookup k wmFinal) ++ " vs " ++ show (M.lookup k mFinal)++-- | Two keys that are equal in their low 32 bits but differ in the high bits+-- must not collide (the reason for not using @IntMap@, which truncates keys to+-- 'Int' on 32-bit platforms).+test_truncation :: Assertion+test_truncation = do+ let a = 0x0000000100000001 :: Word64+ b = 0x0000000200000001 :: Word64+ m = WM.insert b 'b' (WM.insert a 'a' WM.empty)+ WM.lookup a m @?= Just 'a'+ WM.lookup b m @?= Just 'b'++-- | Boundary keys, in particular the ones around the sign bit, are handled the+-- same as any other (the keys are compared as unsigned).+test_boundary :: Assertion+test_boundary = do+ let ks = [ 0, 1, maxBound, maxBound - 1+ , 0x8000000000000000, 0x7fffffffffffffff+ ] :: [Word64]+ m = L.foldl' (\acc k -> WM.insert k k acc) WM.empty ks+ -- Everything inserted is present with the correct value.+ mapM_ (\k -> WM.lookup k m @?= Just k) ks+ -- A key that was never inserted is absent.+ WM.lookup 12345 m @?= Nothing+ -- Deleting one key leaves the others intact.+ let removed = 0x8000000000000000+ m' = WM.delete removed m+ WM.lookup removed m' @?= Nothing+ mapM_ (\k -> WM.lookup k m' @?= Just k) (filter (/= removed) ks)