effectful 2.6.1.0 → 2.7.1.0

raw patch · 29 files changed

Files

• CHANGELOG.md +94/−1
• bench/Concurrency.hs +31/−25
• bench/Countdown.hs +19/−4
• bench/FileSizes.hs +24/−4
• bench/Main.hs +14/−6
• effectful.cabal +47/−30
• src/Effectful/Concurrent.hs +9/−7
• src/Effectful/Concurrent/Async.hs +3/−3
• src/Effectful/Concurrent/Chan/Strict.hs +26/−26
• src/Effectful/Concurrent/MVar/Strict.hs +85/−85
• src/Effectful/FileSystem/File/OsPath.hs +150/−0
• src/Effectful/FileSystem/IO/ByteString/Builder.hs +2/−2
• src/Effectful/FileSystem/OsPath.hs +345/−0
• src/Effectful/Prim/IORef.hs +1/−1
• src/Effectful/Prim/IORef/Strict.hs +33/−33
• tests/ConcurrencyTests.hs +13/−0
• tests/EnvTests.hs +121/−23
• tests/ErrorTests.hs +15/−0
• tests/ExceptionTests.hs +131/−0
• tests/FileSystemTests.hs +53/−0
• tests/InputTests.hs +64/−0
• tests/Main.hs +12/−0
• tests/NonDetTests.hs +89/−0
• tests/OutputTests.hs +97/−0
• tests/ReturnWithTests.hs +88/−0
• tests/StateTests.hs +4/−2
• tests/TimeoutTests.hs +1/−1
• tests/UnliftTests.hs +33/−17
• tests/Word64MapTests.hs +95/−0

@@ -1,10 +1,103 @@+# 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-core-2.6.0.0 (2025-06-13)+# 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`.

@@ -9,45 +9,58 @@ import Test.Tasty.Bench hiding (env) #endif +import Control.Concurrent import Control.Concurrent.Async import Control.Monad  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

@@ -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@@ -95,17 +98,29 @@       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   $ programMtl   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 

@@ -1,5 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FieldSelectors #-} module FileSizes where  import Control.Exception@@ -438,6 +439,9 @@ 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 newtype (Functor, Applicative, Monad, MonadIO) @@ -457,6 +461,9 @@ 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 newtype (Functor, Applicative, Monad, MonadIO, M.MonadTrans) @@ -491,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 

@@ -103,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"@@ -148,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

@@ -1,7 +1,7 @@-cabal-version:      3.0+cabal-version:      3.8 build-type:         Simple name:               effectful-version:            2.6.1.0+version:            2.7.1.0 license:            BSD-3-Clause license-file:       LICENSE category:           Control@@ -12,7 +12,7 @@ description:   An easy to use, performant extensible effects library with seamless   integration with the existing Haskell ecosystem.-  .+   This 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,7 +22,7 @@   CHANGELOG.md   README.md -tested-with: GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.2, 9.12.2, 9.14.1 }+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@@ -36,48 +36,35 @@ common language     ghc-options:        -Wall                         -Wcompat-                        -Wno-unticked-promoted-constructors                         -Wmissing-deriving-strategies                         -Werror=prepositive-qualified-module -    default-language:   Haskell2010+    default-language:   GHC2021 -    default-extensions: BangPatterns-                        ConstraintKinds-                        DataKinds-                        DeriveFunctor-                        DeriveGeneric+    default-extensions: DataKinds+                        DeepSubsumption                         DerivingStrategies-                        FlexibleContexts-                        FlexibleInstances-                        GADTs-                        GeneralizedNewtypeDeriving-                        ImportQualifiedPost+                        DuplicateRecordFields                         LambdaCase-                        MultiParamTypeClasses+                        NoFieldSelectors                         NoStarIsType-                        PolyKinds-                        RankNTypes-                        RecordWildCards+                        OverloadedRecordDot                         RoleAnnotations-                        ScopedTypeVariables-                        StandaloneDeriving-                        TupleSections-                        TypeApplications                         TypeFamilies-                        TypeOperators                         UndecidableInstances  library     import:         language -    build-depends:    base                >= 4.14      && < 5+    build-depends:    base                >= 4.18      && < 5                     , async               >= 2.2.5                     , bytestring          >= 0.10-                    , directory           >= 1.3.2-                    , effectful-core      >= 2.6.1.0   && < 2.6.2.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 >= 1.1.0.0+                    , strict-mutable-base >= 2.0.0.0   && < 3                     , time                >= 1.9.2                     , stm                 >= 2.5.1.0                     , unliftio            >= 0.2.20@@ -98,11 +85,13 @@                      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@@ -116,21 +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@@ -141,15 +146,21 @@ 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@@ -166,14 +177,20 @@                     EnvTests                     EnvironmentTests                     ErrorTests+                    ExceptionTests+                    FileSystemTests+                    InputTests                     LabeledTests                     NonDetTests+                    OutputTests                     PrimTests                     ReaderTests+                    ReturnWithTests                     StateTests                     TimeoutTests                     UnliftTests                     Utils+                    Word64MapTests  benchmark bench     import:         language

@@ -186,7 +186,7 @@   esF <- cloneEnv es   C.forkOS $ unEff k esF --- | Lifted 'E.forkOSWithUnmask'.+-- | Lifted 'C.forkOSWithUnmask'. forkOSWithUnmask   :: (HasCallStack, Concurrent :> es)   => ((forall a. Eff es a -> Eff es a) -> Eff es ())@@ -199,15 +199,17 @@  -- | Lifted 'C.runInBoundThread'. runInBoundThread :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es a-runInBoundThread k = unsafeEff $ \es -> do-  esF <- cloneEnv es-  C.runInBoundThread $ unEff k esF+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 :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es a-runInUnboundThread k = unsafeEff $ \es -> do-  esF <- cloneEnv es-  C.runInUnboundThread $ unEff k esF+runInUnboundThread k = reallyUnsafeUnliftIO $ \unlift -> do+  -- See the comment in runInBoundThread.+  C.runInUnboundThread $ unlift k  ---------------------------------------- -- Weak references to ThreadIds

@@ -247,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 ()@@ -373,7 +373,7 @@ pooledMapConcurrently f t = unsafeEff $ \es -> do   U.pooledMapConcurrently (\a -> unEff (f a) =<< cloneEnv es) t --- | Lifted 'U.pooledMapConcurrentlyN'.+-- | Lifted 'U.pooledMapConcurrentlyN_'. pooledMapConcurrentlyN_   :: (HasCallStack, Concurrent :> es, Foldable f)   => Int@@ -411,7 +411,7 @@ pooledForConcurrently t f = unsafeEff $ \es -> do   U.pooledForConcurrently t (\a -> unEff (f a) =<< cloneEnv es) --- | Lifted 'U.pooledForConcurrentlyN'.+-- | Lifted 'U.pooledForConcurrentlyN_'. pooledForConcurrentlyN_   :: (HasCallStack, Concurrent :> es, Foldable f)   => Int

@@ -9,42 +9,42 @@   , runConcurrent      -- * Chan-  , Chan'-  , newChan'-  , writeChan'-  , readChan'-  , dupChan'-  , getChan'Contents-  , writeList2Chan'+  , Chan+  , newChan+  , writeChan+  , readChan+  , dupChan+  , getChanContents+  , writeList2Chan   ) where -import Control.Concurrent.Chan.Strict (Chan')+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.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.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.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.dupChan'.+dupChan :: Concurrent :> es => Chan a -> Eff es (Chan a)+dupChan = unsafeEff_ . C.dupChan --- | Lifted 'C.getChan'Contents'.-getChan'Contents :: Concurrent :> es => Chan' a -> Eff es [a]-getChan'Contents = unsafeEff_ . C.getChan'Contents+-- | 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+-- | Lifted 'C.writeList2Chan'.+writeList2Chan :: Concurrent :> es => Chan a -> [a] -> Eff es ()+writeList2Chan c = unsafeEff_ . C.writeList2Chan c

@@ -9,28 +9,28 @@   , runConcurrent      -- * MVar-  , MVar'-  , newEmptyMVar'-  , newMVar'-  , takeMVar'-  , putMVar'-  , readMVar'-  , swapMVar'-  , tryTakeMVar'-  , tryPutMVar'-  , tryReadMVar'-  , isEmptyMVar'-  , withMVar'-  , withMVar'Masked-  , modifyMVar'-  , modifyMVar'_-  , modifyMVar'Masked-  , modifyMVar'Masked_-  , mkWeakMVar'+  , MVar+  , newEmptyMVar+  , newMVar+  , takeMVar+  , putMVar+  , readMVar+  , swapMVar+  , tryTakeMVar+  , tryPutMVar+  , tryReadMVar+  , isEmptyMVar+  , withMVar+  , withMVarMasked+  , modifyMVar+  , modifyMVar_+  , modifyMVarMasked+  , modifyMVarMasked_+  , mkWeakMVar   ) where  import System.Mem.Weak (Weak)-import Control.Concurrent.MVar.Strict (MVar')+import Control.Concurrent.MVar.Strict (MVar) import Control.Concurrent.MVar.Strict qualified as M  import Effectful@@ -39,90 +39,90 @@ 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.newEmptyMVar'.+newEmptyMVar :: Concurrent :> es => Eff es (MVar a)+newEmptyMVar = unsafeEff_ M.newEmptyMVar --- | Lifted 'M.newMVar''.-newMVar' :: Concurrent :> es => a -> Eff es (MVar' a)-newMVar' = unsafeEff_ . M.newMVar'+-- | Lifted 'M.newMVar'.+newMVar :: Concurrent :> es => a -> Eff es (MVar a)+newMVar = unsafeEff_ . M.newMVar --- | Lifted 'M.takeMVar''.-takeMVar' :: Concurrent :> es => MVar' a -> Eff es a-takeMVar' = unsafeEff_ . M.takeMVar'+-- | 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 = unsafeEff_ . M.putMVar' var+-- | Lifted 'M.putMVar'.+putMVar :: Concurrent :> es => MVar a -> a -> Eff es ()+putMVar var = unsafeEff_ . M.putMVar var --- | Lifted 'M.readMVar''.-readMVar' :: Concurrent :> es => MVar' a -> Eff es a-readMVar' = unsafeEff_ . M.readMVar'+-- | Lifted 'M.readMVar'.+readMVar :: Concurrent :> es => MVar a -> Eff es a+readMVar = unsafeEff_ . M.readMVar --- | Lifted 'M.swapMVar''.-swapMVar' :: Concurrent :> es => MVar' a -> a -> Eff es a-swapMVar' var = unsafeEff_ . M.swapMVar' var+-- | Lifted 'M.swapMVar'.+swapMVar :: Concurrent :> es => MVar a -> a -> Eff es 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.tryTakeMVar'.+tryTakeMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a)+tryTakeMVar = unsafeEff_ . M.tryTakeMVar --- | Lifted 'M.tryPutMVar''.-tryPutMVar' :: Concurrent :> es => MVar' a -> a -> Eff es Bool-tryPutMVar' var = unsafeEff_ . M.tryPutMVar' var+-- | Lifted 'M.tryPutMVar'.+tryPutMVar :: Concurrent :> es => MVar a -> a -> Eff es Bool+tryPutMVar var = unsafeEff_ . M.tryPutMVar var --- | Lifted 'M.tryReadMVar''.-tryReadMVar' :: Concurrent :> es => MVar' a -> Eff es (Maybe a)-tryReadMVar' = unsafeEff_ . M.tryReadMVar'+-- | 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.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.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.withMVar'Masked'.-withMVar'Masked :: Concurrent :> es => MVar' a -> (a -> Eff es b) -> Eff es b-withMVar'Masked var f = reallyUnsafeUnliftIO $ \unlift -> do-  M.withMVar'Masked var $ unlift . f-{-# INLINE withMVar'Masked #-}+-- | 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) -> 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.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.modifyMVar'Masked_'.-modifyMVar'Masked_ :: Concurrent :> es => MVar' a -> (a -> Eff es a) -> Eff es ()-modifyMVar'Masked_ var f = reallyUnsafeUnliftIO $ \unlift -> do-  M.modifyMVar'Masked_ var $ unlift . f-{-# INLINE modifyMVar'Masked_ #-}+-- | 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.modifyMVar'Masked'.-modifyMVar'Masked :: Concurrent :> es => MVar' a -> (a -> Eff es (a, b)) -> Eff es b-modifyMVar'Masked var f = reallyUnsafeUnliftIO $ \unlift -> do-  M.modifyMVar'Masked var $ unlift . f-{-# INLINE modifyMVar'Masked #-}+-- | 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''.+-- | 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'+mkWeakMVar   :: (HasCallStack, Concurrent :> es)-  => MVar' a -> Eff es ()-  -> Eff es (Weak (MVar' a))-mkWeakMVar' var f = unsafeEff $ \es -> do+  => 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+  M.mkWeakMVar var . unEff f =<< cloneEnv es

@@ -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

@@ -28,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

@@ -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

@@ -61,7 +61,7 @@ atomicModifyIORef' :: Prim :> es => IORef a -> (a -> (a, b)) -> Eff es b atomicModifyIORef' var = unsafeEff_ . Ref.atomicModifyIORef' var --- | Lifted 'Ref.atomicWriteIORef''.+-- | Lifted 'Ref.atomicWriteIORef'. atomicWriteIORef :: Prim :> es => IORef a -> a -> Eff es () atomicWriteIORef var = unsafeEff_ . Ref.atomicWriteIORef var 

@@ -9,17 +9,17 @@   , runPrim      -- * IORef-  , IORef'-  , newIORef'-  , readIORef'-  , writeIORef'-  , modifyIORef'-  , atomicModifyIORef'-  , atomicWriteIORef'-  , mkWeakIORef'+  , IORef+  , newIORef+  , readIORef+  , writeIORef+  , modifyIORef+  , atomicModifyIORef+  , atomicWriteIORef+  , mkWeakIORef   ) where -import Data.IORef.Strict (IORef')+import Data.IORef.Strict (IORef) import Data.IORef.Strict qualified as Ref import System.Mem.Weak (Weak) @@ -28,39 +28,39 @@ 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.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.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.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.atomicWriteIORef'.+atomicWriteIORef :: Prim :> es => IORef a -> a -> Eff es ()+atomicWriteIORef var = unsafeEff_ . Ref.atomicWriteIORef var --- | Lifted 'Ref.mkWeakIORef''.+-- | 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'+mkWeakIORef   :: (HasCallStack, Prim :> es)-  => IORef' a+  => IORef a   -> Eff es ()-  -> Eff es (Weak (IORef' a))-mkWeakIORef' var f = unsafeEff $ \es -> do+  -> 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+  Ref.mkWeakIORef var . unEff f =<< cloneEnv es

@@ -8,6 +8,7 @@ import UnliftIO  import Effectful+import Effectful.Concurrent qualified as E import Effectful.Concurrent.Async qualified as E import Effectful.Dispatch.Dynamic import Effectful.Error.Static@@ -24,6 +25,8 @@   , 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@@ -134,6 +137,16 @@   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)

@@ -11,18 +11,24 @@ import Effectful.Dispatch.Static.Primitive import Effectful.Reader.Static import Effectful.Provider+import Effectful.Provider.List import Effectful.State.Static.Local 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 "borrow/lend works" test_borrowLend+  , 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@@ -37,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@@ -165,6 +179,42 @@         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@@ -191,32 +241,80 @@  ---------------------------------------- -test_borrowLend :: Assertion-test_borrowLend = runEff $ do-  runX 1 2 . evalState @[Int] [3] . runReader () . runReader @[Int] [4] $ do+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 -runX :: Int -> Int -> Eff (X : es) a -> Eff es a-runX s0 r0 = reinterpret (evalState s0 . evalState () . runReader r0) $ \env -> \case+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-    as <- localSeqLend @[State Int, Reader Int] env $ \withHandlerEffs -> do-      unlift . withHandlerEffs $ do-        () <- ask-        s <- get @Int-        r <- ask @Int-        ss <- get @[Int]-        rs <- ask @[Int]-        pure $ [s, r] ++ ss ++ rs-    bs <- localSeqBorrow @[Reader [Int], State [Int], Reader ()] env $ \withEffs -> do-      withEffs $ do-        () <- ask-        s <- get @Int-        r <- ask @Int-        ss <- get @[Int]-        rs <- ask @[Int]-        pure $ [s, r] ++ ss ++ rs-    pure $ as ++ bs+    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

@@ -12,6 +12,7 @@ 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@@ -29,6 +30,20 @@   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

@@ -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

@@ -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)

@@ -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

@@ -7,13 +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"@@ -22,11 +28,17 @@   , envTests   , environmentTests   , errorTests+  , exceptionTests+  , fileSystemTests+  , inputTests   , labeledTests   , nonDetTests+  , outputTests   , primTests   , readerTests+  , returnWithTests   , stateTests   , timeoutTests   , unliftTests+  , word64MapTests   ]

@@ -1,10 +1,16 @@ 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@@ -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@@ -63,6 +71,23 @@       _<- (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@@ -75,8 +100,72 @@     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

@@ -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]

@@ -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"

@@ -1,10 +1,12 @@+-- 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+import Data.IORef.Strict qualified as S import Test.Tasty import Test.Tasty.HUnit import UnliftIO.Exception qualified as UE@@ -51,7 +53,7 @@   U.assertEqual "correct a" "hi"    a   U.assertEqual "correct b" "hi!!!" b   where-    getEffectReps = unsafeEff $ \es -> sdEffects . stData <$> readIORef' (envStorage es)+    getEffectReps = unsafeEff $ \es -> (.effects) . (.data_) <$> S.readIORef es.storage  test_deepStack :: Assertion test_deepStack = runEff $ do

@@ -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

@@ -1,5 +1,6 @@ module UnliftTests (unliftTests) where +import Data.List (isInfixOf) import Test.Tasty import Test.Tasty.HUnit import UnliftIO.Async qualified as A@@ -7,6 +8,7 @@ import Effectful import Effectful.Concurrent.Async qualified as E import Effectful.Dispatch.Dynamic+import Effectful.Exception import Effectful.State.Static.Local import Utils qualified as U @@ -25,6 +27,8 @@     , 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@@ -84,7 +88,6 @@   testFork "runFork2" runFork2   testFork "runFork3" runFork3   testFork "runFork4" runFork4-  testFork "runFork5" runFork5   where     testFork description runFork = do       a <- runFork . send $ ForkWithUnmask $ \unmask -> do@@ -98,6 +101,29 @@         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@@ -112,19 +138,9 @@   where     strategy = ConcUnlift Ephemeral $ Limited 1 --- | Uses 'localUnlift' and 'withLiftMap'.-runFork2 :: (IOE :> es, E.Concurrent :> es) => Eff (Fork : es) a -> Eff es a-runFork2 = interpret $ \env -> \case-  ForkWithUnmask m -> do-    withLiftMap env $ \liftMap -> do-      localUnlift env strategy $ \unlift -> do-        E.asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask-  where-    strategy = ConcUnlift Ephemeral $ Limited 1- -- | 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 strategy $ \lift unlift -> do       A.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift@@ -132,8 +148,8 @@     strategy = ConcUnlift Persistent $ Limited 1  -- | Uses 'localLiftUnlift'.-runFork4 :: (IOE :> es, E.Concurrent :> es) => Eff (Fork : es) a -> Eff es a-runFork4 = interpret $ \env -> \case+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@@ -141,8 +157,8 @@     strategy = ConcUnlift Persistent $ Limited 1  -- | Uses 'localLift' and 'localUnlift'.-runFork5 :: (IOE :> es, E.Concurrent :> es) => Eff (Fork : es) a -> Eff es a-runFork5 = interpret $ \env -> \case+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

@@ -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)